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