1# ---------------------------------------------------------------------------
2#  color.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: color.tcl,v 1.14 2009/09/06 21:04:47 oberdorfer Exp $
5# ---------------------------------------------------------------------------
6
7
8namespace eval SelectColor {
9    Widget::define SelectColor color Dialog
10
11    Widget::declare SelectColor {
12        {-title     String     "Select a color" 0}
13        {-parent    String     ""               0}
14        {-color     Color      "SystemWindowFrame"  0}
15	{-type      Enum       "dialog"         1 {dialog popup}}
16	{-placement String     "center"         1}
17        {-background		Color      "SystemWindowFrame" 0}
18        {-highlightcolor 	Color      "SystemHighlight"   0}
19    }
20
21    variable _baseColors {
22        \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00
23        \#000099 \#009900 \#009999 \#990000 \#990099 \#999900
24        \#000000 \#333333 \#666666 \#999999 \#cccccc \#ffffff
25    }
26
27    variable _userColors {
28        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
29        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
30    }
31
32    if {[string equal $::tcl_platform(platform) "unix"]} {
33        set useTkDialogue 0
34    } else {
35        set useTkDialogue 1
36    }
37
38    variable _selectype
39    variable _selection
40    variable _wcolor
41    variable _image
42    variable _hsv
43}
44
45proc SelectColor::create { path args } {
46    Widget::init SelectColor $path $args
47
48    set type [Widget::cget $path -type]
49
50    switch -- [Widget::cget $path -type] {
51	"dialog" {
52	    return [eval [list SelectColor::dialog $path] $args]
53	}
54
55	"popup" {
56	    set list      [list at center left right above below]
57	    set placement [Widget::cget $path -placement]
58	    set where     [lindex $placement 0]
59
60	    if {[lsearch $list $where] < 0} {
61		return -code error \
62		    [BWidget::badOptionString placement $placement $list]
63	    }
64
65	    ## If they specified a parent and didn't pass a second argument
66	    ## in the placement, set the placement relative to the parent.
67	    set parent [Widget::cget $path -parent]
68	    if {[string length $parent]} {
69		if {[llength $placement] == 1} { lappend placement $parent }
70	    }
71	    return [eval [list SelectColor::menu $path $placement] $args]
72	}
73    }
74}
75
76proc SelectColor::menu {path placement args} {
77    variable _baseColors
78    variable _userColors
79    variable _wcolor
80    variable _selectype
81    variable _selection
82
83    Widget::init SelectColor $path $args
84
85    set top [toplevel $path]
86    set parent [winfo toplevel [winfo parent $top]]
87    wm withdraw  $top
88    wm transient $top $parent
89    wm overrideredirect $top 1
90    catch { wm attributes $top -topmost 1 }
91
92    set frame [frame $top.frame \
93                   -highlightthickness 0 \
94                   -relief raised -borderwidth 2]
95    set col    0
96    set row    0
97    set count  0
98    set colors [concat $_baseColors $_userColors]
99    foreach color $colors {
100        set f [frame $frame.c$count \
101                   -highlightthickness 2 \
102                   -highlightcolor [Widget::getoption $path -highlightcolor] \
103                   -relief solid -borderwidth 1 \
104                   -width 16 -height 16 -background $color]
105        bind $f <1>     "set SelectColor::_selection $count; break"
106        bind $f <Enter> {focus %W}
107        grid $f -column $col -row $row
108        incr count
109        if {[incr col] == 6 } {
110            set  col 0
111            incr row
112        }
113    }
114    set f [label $frame.c$count \
115               -highlightthickness 2 \
116               -highlightcolor [Widget::getoption $path -highlightcolor] \
117               -relief flat -borderwidth 0 \
118               -width 16 -height 16 -image [Bitmap::get palette]]
119    grid $f -column $col -row $row
120    bind $f <1>     "set SelectColor::_selection $count; break"
121    bind $f <Enter> {focus %W}
122    pack $frame
123
124    bind $top <1>      {set SelectColor::_selection -1}
125    bind $top <Escape> {set SelectColor::_selection -2}
126    bind $top <FocusOut> [subst {if {"%W" == "$top"} \
127				     {set SelectColor::_selection -2}}]
128    eval [list BWidget::place $top 0 0] $placement
129
130    wm deiconify $top
131    raise $top
132    if {$::tcl_platform(platform) == "unix"} {
133	tkwait visibility $top
134	update
135    }
136    BWidget::SetFocusGrab $top $frame.c0
137
138    vwait SelectColor::_selection
139    BWidget::RestoreFocusGrab $top $frame.c0 destroy
140    Widget::destroy $top
141    if {$_selection == $count} {
142	array set opts {
143	    -parent -parent
144	    -title  -title
145	    -color  -initialcolor
146	}
147	if {[Widget::theme]} {
148	    set native 1
149	    set nativecmd [list tk_chooseColor -parent $parent]
150	    foreach {key val} $args {
151		if {![info exists opts($key)]} {
152		    set native 0
153		    break
154		}
155		lappend nativecmd $opts($key) $val
156	    }
157	    if {$native} {
158		return [eval $nativecmd]
159	    }
160	}
161	return [eval [list dialog $path] $args]
162    } else {
163        return [lindex $colors $_selection]
164    }
165}
166
167
168proc SelectColor::dialog {path args} {
169    variable _baseColors
170    variable _userColors
171    variable _widget
172    variable _selection
173    variable _image
174    variable _hsv
175
176    Widget::init SelectColor $path:SelectColor $args
177    set top   [Dialog::create $path \
178                   -title  [Widget::cget $path:SelectColor -title]  \
179                   -parent [Widget::cget $path:SelectColor -parent] \
180                   -separator 1 -default 0 -cancel 1 -anchor e]
181    wm resizable $top 0 0
182    set dlgf  [$top getframe]
183
184    if { [BWidget::using ttk] } {
185             set fg [ttk::frame $dlgf.fg]
186    } else { set fg [frame $dlgf.fg] }
187
188    set desc  [list \
189                   base _baseColors "Base colors" \
190                   user _userColors "User colors"]
191    set count 0
192    foreach {type varcol defTitle} $desc {
193        set col   0
194        set lin   0
195        set title [lindex [BWidget::getname "${type}Colors"] 0]
196        if {![string length $title]} {
197            set title $defTitle
198        }
199        set titf  [TitleFrame $fg.$type -text $title]
200        set subf  [$titf getframe]
201        foreach color [set $varcol] {
202            set fround [frame $fg.round$count \
203                            -highlightthickness 1 \
204                            -relief sunken -borderwidth 2]
205            set fcolor [frame $fg.color$count -width 16 -height 12 \
206                            -highlightthickness 0 \
207                            -relief flat -borderwidth 0 \
208                            -background $color]
209            pack $fcolor -in $fround
210            grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1
211
212            bind $fround <ButtonPress-1> [list SelectColor::_select_rgb $count]
213            bind $fcolor <ButtonPress-1> [list SelectColor::_select_rgb $count]
214
215	    bind $fround <Double-1> \
216	    	"SelectColor::_select_rgb [list $count]; [list $top] invoke 0"
217	    bind $fcolor <Double-1> \
218	    	"SelectColor::_select_rgb [list $count]; [list $top] invoke 0"
219
220            incr count
221            if {[incr col] == 6} {
222                incr lin
223                set  col 0
224            }
225        }
226        pack $titf -anchor w -pady 2
227    }
228
229    set fround [frame $fg.round \
230                      -highlightthickness 0 \
231                      -relief sunken -borderwidth 2]
232    set fcolor [frame $fg.color \
233                      -width 50 \
234                      -highlightthickness 0 \
235                      -relief flat -borderwidth 0]
236
237    pack $fcolor -in $fround -fill y -expand yes
238    pack $fround -anchor e -pady 2 -fill y -expand yes
239
240    if { [BWidget::using ttk] } {
241        set fd  [ttk::frame $dlgf.fd]
242        set f1  [ttk::frame $fd.f1 -relief sunken]
243        set f2  [ttk::frame $fd.f2 -relief sunken]
244    } else {
245        set fd  [frame $dlgf.fd]
246        set f1  [frame $fd.f1 -relief sunken -borderwidth 2]
247        set f2  [frame $fd.f2 -relief sunken -borderwidth 2]
248    }
249    set c1  [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0]
250    set c2  [canvas $f2.c -width 15  -height 200 -bd 0 -highlightthickness 0]
251
252    for {set val 0} {$val < 40} {incr val} {
253        $c2 create rectangle 0 [expr {5*$val}] 15 [expr {5*$val+5}] -tags val[expr {39-$val}]
254    }
255    $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target
256
257    pack $c1 $c2
258    pack $f1 $f2 -side left -padx 10 -anchor n
259
260    pack $fg $fd -side left -anchor n -fill y
261
262    bind $c1 <ButtonPress-1> [list SelectColor::_select_hue_sat %x %y]
263    bind $c1 <B1-Motion>     [list SelectColor::_select_hue_sat %x %y]
264
265    bind $c2 <ButtonPress-1> [list SelectColor::_select_value %x %y]
266    bind $c2 <B1-Motion>     [list SelectColor::_select_value %x %y]
267
268    if {![info exists _image] || [catch {image type $_image}]} {
269        set _image [image create photo -width 200 -height 200]
270        for {set x 0} {$x < 200} {incr x 4} {
271            for {set y 0} {$y < 200} {incr y 4} {
272                $_image put \
273		    [eval [list format "\#%04x%04x%04x"] \
274			[hsvToRgb [expr {$x/196.0}] [expr {(196-$y)/196.0}] 0.85]] \
275			-to $x $y [expr {$x+4}] [expr {$y+4}]
276            }
277        }
278    }
279    $c1 create image  0 0 -anchor nw -image $_image
280    $c1 create bitmap 0 0 \
281        -bitmap @[file join $::BWIDGET::LIBRARY "images" "target.xbm"] \
282        -anchor nw -tags target
283
284    set _selection -1
285    set _widget(fcolor) $fg
286    set _widget(chs)    $c1
287    set _widget(cv)     $c2
288    set rgb             [winfo rgb $path [Widget::cget $path:SelectColor -color]]
289    set _hsv            [eval rgbToHsv $rgb]
290    _set_rgb     [eval [list format "\#%04x%04x%04x"] $rgb]
291    _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
292    _set_value   [lindex $_hsv 2]
293
294    $top add -name ok
295    $top add -name cancel
296    set res [$top draw]
297    if {$res == 0} {
298        set color [$fg.color cget -background]
299    } else {
300        set color ""
301    }
302    destroy $top
303    return $color
304}
305
306proc SelectColor::setcolor { idx color } {
307    variable _userColors
308    set _userColors [lreplace $_userColors $idx $idx $color]
309}
310
311proc SelectColor::_select_rgb {count} {
312    variable _baseColors
313    variable _userColors
314    variable _selection
315    variable _widget
316    variable _hsv
317
318    set frame $_widget(fcolor)
319    if {$_selection >= 0} {
320        $frame.round$_selection configure \
321            -relief sunken -highlightthickness 1 -borderwidth 2
322    }
323    $frame.round$count configure \
324        -relief flat -highlightthickness 2 -borderwidth 1
325    focus $frame.round$count
326    set _selection $count
327    set bg   [$frame.color$count cget -background]
328    set user [expr {$_selection-[llength $_baseColors]}]
329    if {$user >= 0 &&
330        [string equal \
331              [winfo rgb $frame.color$_selection $bg] \
332              [winfo rgb $frame.color$_selection white]]} {
333        set bg [$frame.color cget -bg]
334        $frame.color$_selection configure -background $bg
335        set _userColors [lreplace $_userColors $user $user $bg]
336    } else {
337        set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]]
338        _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
339        _set_value   [lindex $_hsv 2]
340        $frame.color configure -background $bg
341    }
342}
343
344
345proc SelectColor::_set_rgb {rgb} {
346    variable _selection
347    variable _baseColors
348    variable _userColors
349    variable _widget
350
351    set frame $_widget(fcolor)
352    $frame.color configure -background $rgb
353    set user [expr {$_selection-[llength $_baseColors]}]
354    if {$user >= 0} {
355        $frame.color$_selection configure -background $rgb
356        set _userColors [lreplace $_userColors $user $user $rgb]
357    }
358}
359
360
361proc SelectColor::_select_hue_sat {x y} {
362    variable _widget
363    variable _hsv
364
365    if {$x < 0} {
366        set x 0
367    } elseif {$x > 200} {
368        set x 200
369    }
370    if {$y < 0 } {
371        set y 0
372    } elseif {$y > 200} {
373        set y 200
374    }
375    set hue  [expr {$x/200.0}]
376    set sat  [expr {(200-$y)/200.0}]
377    set _hsv [lreplace $_hsv 0 1 $hue $sat]
378    $_widget(chs) coords target [expr {$x-9}] [expr {$y-9}]
379    _draw_values $hue $sat
380    _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]]
381}
382
383
384proc SelectColor::_set_hue_sat {hue sat} {
385    variable _widget
386
387    set x [expr {$hue*200-9}]
388    set y [expr {(1-$sat)*200-9}]
389    $_widget(chs) coords target $x $y
390    _draw_values $hue $sat
391}
392
393
394
395proc SelectColor::_select_value {x y} {
396    variable _widget
397    variable _hsv
398
399    if {$y < 0} {
400        set y 0
401    } elseif {$y > 200} {
402        set y 200
403    }
404    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
405    set _hsv [lreplace $_hsv 2 2 [expr {(200-$y)/200.0}]]
406    _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]]
407}
408
409
410proc SelectColor::_draw_values {hue sat} {
411    variable _widget
412
413    for {set val 0} {$val < 40} {incr val} {
414        set l   [hsvToRgb $hue $sat [expr {$val/39.0}]]
415        set col [eval [list format "\#%04x%04x%04x"] $l]
416        $_widget(cv) itemconfigure val$val -fill $col -outline $col
417    }
418}
419
420
421proc SelectColor::_set_value {value} {
422    variable _widget
423
424    set y [expr {int((1-$value)*200)}]
425    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
426}
427
428
429# --
430#  Taken from tk8.0/demos/tcolor.tcl
431# --
432# The procedure below converts an HSB value to RGB.  It takes hue, saturation,
433# and value components (floating-point, 0-1.0) as arguments, and returns a
434# list containing RGB components (integers, 0-65535) as result.  The code
435# here is a copy of the code on page 616 of "Fundamentals of Interactive
436# Computer Graphics" by Foley and Van Dam.
437
438proc SelectColor::hsvToRgb {hue sat val} {
439    set v [expr {round(65535.0*$val)}]
440    if {$sat == 0} {
441	return [list $v $v $v]
442    } else {
443	set hue [expr {$hue*6.0}]
444	if {$hue >= 6.0} {
445	    set hue 0.0
446	}
447	set i [expr {int($hue)}]
448	set f [expr {$hue-$i}]
449	set p [expr {round(65535.0*$val*(1 - $sat))}]
450        set q [expr {round(65535.0*$val*(1 - ($sat*$f)))}]
451        set t [expr {round(65535.0*$val*(1 - ($sat*(1 - $f))))}]
452        switch $i {
453	    0 {return [list $v $t $p]}
454	    1 {return [list $q $v $p]}
455	    2 {return [list $p $v $t]}
456	    3 {return [list $p $q $v]}
457	    4 {return [list $t $p $v]}
458            5 {return [list $v $p $q]}
459        }
460    }
461}
462
463
464# --
465#  Taken from tk8.0/demos/tcolor.tcl
466# --
467# The procedure below converts an RGB value to HSB.  It takes red, green,
468# and blue components (0-65535) as arguments, and returns a list containing
469# HSB components (floating-point, 0-1) as result.  The code here is a copy
470# of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
471# by Foley and Van Dam.
472
473proc SelectColor::rgbToHsv {red green blue} {
474    if {$red > $green} {
475	set max $red.0
476	set min $green.0
477    } else {
478	set max $green.0
479	set min $red.0
480    }
481    if {$blue > $max} {
482	set max $blue.0
483    } else {
484	if {$blue < $min} {
485	    set min $blue.0
486	}
487    }
488    set range [expr {$max-$min}]
489    if {$max == 0} {
490	set sat 0
491    } else {
492	set sat [expr {($max-$min)/$max}]
493    }
494    if {$sat == 0} {
495	set hue 0
496    } else {
497	set rc [expr {($max - $red)/$range}]
498	set gc [expr {($max - $green)/$range}]
499	set bc [expr {($max - $blue)/$range}]
500	if {$red == $max} {
501	    set hue [expr {.166667*($bc - $gc)}]
502	} else {
503	    if {$green == $max} {
504		set hue [expr {.166667*(2 + $rc - $bc)}]
505	    } else {
506		set hue [expr {.166667*(4 + $gc - $rc)}]
507	    }
508	}
509	if {$hue < 0.0} {
510	    set hue [expr {$hue + 1.0}]
511	}
512    }
513    return [list $hue $sat [expr {$max/65535}]]
514}
515
516