1
2proc color_generate {index} {
3  set index [expr abs($index) % 132]
4  set i [expr $index % 12]
5  set h [lindex {0 1 2 3 4 5 .5 1.25 2.65 3.4 4.5 5.5} $i]
6  set i [expr int($h)]
7  set h [expr $h - double($i)]
8  set j [expr $index / 12]
9  if {[expr $j % 2] == 0} {
10    set v 1.0
11    set s [expr 1.0 - sqrt(double($j) / 22.0)]
12  } else {
13    set v [expr 1.0 - sqrt(double($j) / 44.0)]
14    set s 1.0
15  }
16  switch $i {
17    0 {
18        set r $v
19        set g [expr $v * (1.0 - ($s * (1.0 - $h)))]
20        set b [expr $v * (1.0 - $s)]
21      }
22    1 {
23        set r [expr $v * (1.0 - ($s * $h))]
24        set g $v
25        set b [expr $v * (1.0 - $s)]
26      }
27    2 {
28        set r [expr $v * (1.0 - $s)]
29        set g $v
30        set b [expr $v * (1.0 - ($s * (1.0 - $h)))]
31      }
32    3 {
33        set r [expr $v * (1.0 - $s)]
34        set g [expr $v * (1.0 - ($s * $h))]
35        set b $v
36      }
37    4 {
38        set r [expr $v * (1.0 - ($s * (1.0 - $h)))]
39        set g [expr $v * (1.0 - $s)]
40        set b $v
41      }
42    5 {
43        set r $v
44        set g [expr $v * (1.0 - $s)]
45        set b [expr $v * (1.0 - ($s * $h))]
46      }
47    6 {
48        set r $v
49        set g [expr $v * (1.0 - $s)]
50        set b [expr $v * (1.0 - $s)]
51      }
52  }
53
54  if [expr $r < 0.0] {set r 0.0}
55  if [expr $r > 1.0] {set r 1.0}
56  if [expr $g < 0.0] {set g 0.0}
57  if [expr $g > 1.0] {set g 1.0}
58  if [expr $b < 0.0] {set b 0.0}
59  if [expr $b > 1.0] {set b 1.0}
60
61  return [list $r $g $b]
62}
63
64proc color_value {rgb} {
65  return [format "#%2.2x%2.2x%2.2x" \
66    [expr int(255.0 * [lindex $rgb 0])] \
67    [expr int(255.0 * [lindex $rgb 1])] \
68    [expr int(255.0 * [lindex $rgb 2])]]
69}
70
71proc color_lighten {rgb {amt 0.25}} {
72  set newclr ""
73  foreach c $rgb {
74    set nc [expr $c + $amt]
75    if [expr $nc < 0.0] {set nc 0.0}
76    if [expr $nc > 1.0] {set nc 1.0}
77    lappend newclr $nc
78  }
79  return $newclr
80}
81
82proc color_darken {rgb {amt 0.25}} {
83  set newclr ""
84  foreach c $rgb {
85    set nc [expr $c - $amt]
86    if [expr $nc < 0.0] {set nc 0.0}
87    if [expr $nc > 1.0] {set nc 1.0}
88    lappend newclr $nc
89  }
90  return $newclr
91}
92
93proc color_gray {rgb} {
94  set gray [expr 0.30 * [lindex $rgb 0] + \
95                 0.59 * [lindex $rgb 1] + \
96                 0.11 * [lindex $rgb 2]]
97  if [expr $gray < 0.0] {return 0.0}
98  if [expr $gray > 1.0] {return 1.0}
99  return $gray
100}
101
102array set _ColorData {
103  win ""
104  done 0
105  red 127
106  green 127
107  blue 127
108  red,y 0
109  green,y 0
110  blue,y 0
111  colorbars 16
112  arrowsize 5
113  hue {0 6 1 2 3 9 10 5}
114  sat {10 6 2 0 1 5 9}
115}
116
117proc color_select {w title {oldclr ""} {loc ""}} {
118  global _ColorData
119
120  if {[llength $oldclr] == 3} {
121    set r [expr int(255.0 * [lindex $oldclr 0])]
122    if {$r < 0} {
123      set _ColorData(red) 0
124    } elseif {$r > 255} {
125      set _ColorData(red) 255
126    } else {
127      set _ColorData(red) $r
128    }
129    set g [expr int(255.0 * [lindex $oldclr 1])]
130    if {$g < 0} {
131      set _ColorData(green) 0
132    } elseif {$g > 255} {
133      set _ColorData(green) 255
134    } else {
135      set _ColorData(green) $g
136    }
137    set b [expr int(255.0 * [lindex $oldclr 2])]
138    if {$b < 0} {
139      set _ColorData(blue) 0
140    } elseif {$b > 255} {
141      set _ColorData(blue) 255
142    } else {
143      set _ColorData(blue) $b
144    }
145  }
146
147  set _ColorData(win) $w
148  catch {destroy $w}
149  toplevel $w
150  wm protocol $w WM_DELETE_WINDOW {set _ColorData(done) 0}
151  wm title $w $title
152  wm transient $w [winfo toplevel [winfo parent $w]]
153  wm resizable $w 0 0
154
155  frame $w.l
156  pack $w.l -side left -fill y -expand yes -padx 5 -pady 5
157
158  frame $w.l.t
159  pack $w.l.t -side top -pady 5 -anchor n
160
161  for {set j 0} {$j < 7} {incr j} {
162    set f [frame $w.l.t.y$j]
163    pack $f -side top -fill x
164    set sat [lindex $_ColorData(sat) $j]
165    for {set i 0} {$i < 8} {incr i} {
166      set hue [lindex $_ColorData(hue) $i]
167      set n [expr $hue + 12 * $sat]
168      set rgb [color_generate $n]
169      set clr [color_value $rgb]
170      button $f.b$i -padx 3m -pady 1m -bg $clr -activebackground $clr \
171        -command "color:setrgb $rgb"
172      pack $f.b$i -side left
173    }
174  }
175  set f [frame $w.l.t.y8]
176  pack $f -side top -fill x
177  for {set i 0} {$i < 8} {incr i} {
178    set g [expr double($i) / 7.0]
179    set rgb [list $g $g $g]
180    set clr [color_value $rgb]
181    button $f.b$i  -padx 3m -pady 1m -bg $clr -activebackground $clr \
182      -command "color:setrgb $rgb"
183    pack $f.b$i -side left
184  }
185
186  frame $w.l.b
187  pack $w.l.b -side bottom -fill both -expand yes
188
189  set f [frame $w.l.b.b]
190  pack $f -side left -padx 5 -pady 5 -fill y -expand yes
191  button $f.a -text Accept -underline 0 -padx 3m -pady 1m \
192    -command {set _ColorData(done) 1}
193  button $f.c -text Cancel -underline 0 -padx 3m -pady 1m \
194    -command {set _ColorData(done) 0}
195  pack $f.a $f.c -side top -expand yes
196
197  bind $w <Alt-a> "$f.a flash; set _ColorData(done) 1"
198  bind $w <Alt-c> "$f.c flash; set _ColorData(done) 0"
199
200  frame $w.l.b.s -relief sunken -bd 2 -width 100 -height 50 \
201    -bg [format "#%2.2x%2.2x%2.2x" \
202       $_ColorData(red) $_ColorData(green) $_ColorData(blue)]
203  pack $w.l.b.s -side right -expand yes -fill both -padx 2 -pady 5
204
205  frame $w.r
206  pack $w.r -side right -fill y -expand yes -padx 5 -pady 10
207
208  set width [expr {[winfo reqwidth $w.l.t.y0.b0] - \
209      2*([$w.l.t.y0.b0 cget -highlightthickness] + \
210         [$w.l.t.y0.b0 cget -bd])}]
211  set height [expr 8 * [winfo reqheight $w.l.t.y0.b0]]
212
213  foreach {c l} {red R green G blue B} {
214    set f [frame $w.r.$c]
215    if {$c == "green"} {
216      pack $f -side left -fill y -expand yes -padx 5
217    } else {
218      pack $f -side left -fill y -expand yes
219    }
220
221    set box [frame $f.box]
222    pack $box -side bottom -fill x -expand yes
223
224    label $box.lab -text $l
225    entry $box.ent -width 4 -textvariable _ColorData($c)
226    pack $box.lab $box.ent -side top -fill x -expand yes
227
228    bind $box.ent <Return> [list color:entryvalue $c]
229
230    canvas $f.color -height $height -width $width -relief sunken -bd 2
231    pack $f.color -side left -expand yes -fill both
232    canvas $f.sel -height $height -width [expr 2 * $_ColorData(arrowsize)] \
233      -highlightthickness 0
234    pack $f.sel -side right -expand yes -fill y
235
236    bind $f.color <Configure> "color:drawscale $c"
237
238    bind $f.color <Enter> "color:selColor $f $c red"
239    bind $f.color <Leave> "color:selColor $f $c black"
240    bind $f.color <ButtonPress-1> "color:Move $f $c %y"
241    bind $f.color <B1-Motion> "color:Move $f $c %y"
242    bind $f.color <ButtonRelease-1> "color:endMove $f $c %y"
243
244    bind $f.sel <Enter> "color:selColor $f $c red"
245    bind $f.sel <Leave> "color:selColor $f $c black"
246    bind $f.sel <ButtonPress-1> "color:Move $f $c %y"
247    bind $f.sel <B1-Motion> "color:Move $f $c %y"
248    bind $f.sel <ButtonRelease-1> "color:endMove $f $c %y"
249  }
250
251  if {$loc != ""} {center_window $w $loc}
252
253  set oldFocus [focus]
254  set oldGrab [grab current $w]
255  if {$oldGrab != ""} {
256    set grabStatus [grab status $oldGrab]
257  }
258  catch {grab $w}
259  tkwait visibility $w
260  raise $w
261  focus $w
262  tkwait variable _ColorData(done)
263  catch {focus $oldFocus}
264  destroy $w
265  if {$oldGrab != ""} {
266    if {$grabStatus == "global"} {
267      grab -global $oldGrab
268    } else {
269      grab $oldGrab
270    }
271  }
272
273  if {$_ColorData(done)} {
274    set r [format "%.3f" [expr double($_ColorData(red)) / 255.0]]
275    set g [format "%.3f" [expr double($_ColorData(green)) / 255.0]]
276    set b [format "%.3f" [expr double($_ColorData(blue)) / 255.0]]
277    return [list $r $g $b]
278  }
279  return ""
280}
281
282proc color:setrgb {r g b} {
283  global _ColorData
284
285  set _ColorData(red) [expr int(255.0 * $r)]
286  set _ColorData(green) [expr int(255.0 * $g)]
287  set _ColorData(blue) [expr int(255.0 * $b)]
288
289  color:updateall
290}
291
292proc color:entryvalue {clr} {
293  global _ColorData
294
295  if {[catch {
296    set val [expr int($_ColorData($clr))]}
297      ]} {set val 0}
298  if {$val < 0} {set val 0}
299  if {$val > 255} {set val 255}
300  set _ColorData($clr) $val
301
302  color:updateall
303}
304
305proc color:drawcolor {} {
306  global _ColorData
307
308  set color [format "#%2.2x%2.2x%2.2x" \
309    $_ColorData(red) $_ColorData(green) $_ColorData(blue)]
310  $_ColorData(win).l.b.s configure -bg $color
311}
312
313proc color:drawscale {clr} {
314  global _ColorData
315
316  set dc [expr 255.0 / double($_ColorData(colorbars))]
317  set bar $_ColorData(win).r.$clr.color
318  $bar delete all
319  set height [winfo height $bar]
320  set dx [winfo width $bar]
321  set dy [expr double($height) / $_ColorData(colorbars)]
322  for {set i 0} {$i < $_ColorData(colorbars)} {incr i} {
323    set y [expr $i * $dy]
324    set c [expr 255 - int($i * $dc)]
325    if {$clr == "red"} {
326      set color [format "#%2.2x%2.2x%2.2x" \
327                 $c $_ColorData(green) $_ColorData(blue)]
328    } elseif {$clr == "green"} {
329      set color [format "#%2.2x%2.2x%2.2x" \
330                 $_ColorData(red) $c $_ColorData(blue)]
331    } else {
332      set color [format "#%2.2x%2.2x%2.2x" \
333                 $_ColorData(red) $_ColorData(green) $c]
334    }
335    $bar create rect 0 $y $dx [expr $y + $dy] \
336      -fill $color -outline $color
337  }
338
339  set sel $_ColorData(win).r.$clr.sel
340  set y [expr $_ColorData(arrowsize) + \
341         ($height - 2 * $_ColorData(arrowsize)) * \
342         (1.0 - $_ColorData($clr) / 255.0)]
343  set _ColorData($clr,y) $y
344  $sel delete all
345  set _ColorData($clr,sel) [$sel create polygon 0 $y \
346    [expr 2 * $_ColorData(arrowsize)] [expr $y + $_ColorData(arrowsize)] \
347    [expr 2 * $_ColorData(arrowsize)] [expr $y - $_ColorData(arrowsize)]]
348}
349
350proc color:updateall {} {
351  color:drawcolor
352  color:drawscale red
353  color:drawscale green
354  color:drawscale blue
355}
356
357proc color:selColor {f clr selclr} {
358  global _ColorData
359
360  $f.sel itemconfigure $_ColorData($clr,sel) -fill $selclr
361}
362
363proc color:Move {f clr y} {
364  global _ColorData
365
366  set bar $f.color
367  set height [winfo height $bar]
368  if {$y < 0} {set y 0}
369  if {$y > $height} {set y $height}
370  set c [expr int(255.0 * (1.0 - double($y) / double($height)))]
371  if {$c < 0} {set c 0}
372  if {$c > 255} {set c 255}
373  set _ColorData($clr) $c
374  color:drawcolor
375
376  incr height -$_ColorData(arrowsize)
377  if {$y < $_ColorData(arrowsize)} {set y $_ColorData(arrowsize)}
378  if {$y > $height} {set y $height}
379  set diff [expr $y - $_ColorData($clr,y)]
380  $f.sel move $_ColorData($clr,sel) 0 $diff
381  set _ColorData($clr,y) [expr $_ColorData($clr,y) + $diff]
382}
383
384proc color:endMove {f clr y} {
385  color:Move $f $clr $y
386  color:drawscale red
387  color:drawscale green
388  color:drawscale blue
389}
390
391proc color:allcolors {{w .allcolor}} {
392  catch {destroy $w}
393  toplevel $w
394  wm title $w "All Colors"
395
396  set n 0
397  for {set j 0} {$j < 11} {incr j} {
398    set f [frame $w.y$j]
399    pack $f -side top -fill x
400    for {set i 0} {$i < 12} {incr i} {
401      set clr [color_value [color_generate $n]]
402      button $f.b$i -bg $clr -activebackground $clr
403      pack $f.b$i -side left
404      incr n
405    }
406  }
407}
408
409
410