**colorpicker** [FF] - 2009-09-15 - This is a [GPL] multi-mode color picker. Actually features two color picker types: `switches` and `hsv`. Usage: ====== if {[catch {package require colorpicker}]} {source colorpicker.tcl; package require colorpicker} namespace import ::colorpicker::colorpicker colorpicker .picker1 switches -command {.picker2 set} pack .picker1 colorpicker .picker2 hsv -textvar ::color2 pack picker2 puts [.picker2 get] .picker1 set "#ff0033" ====== I use it also as a multiple color picker, by '''[grid]'''ding two of it (switches and hsv) to the same cell, linking them with `-command`/`set`, then using raise to select the one which should be visible. [http://dev.gentoo.org/~mescalinum/tclwiki-img/colorpicker.gif] See also: [Color pickers] Code: ====== if {[info exists ::colorpicker::version]} {return} namespace eval ::colorpicker { namespace export colorpicker # ========================================= # colorpicker set version 0.1 # (C) 2009 - Federico Ferri # mescalinum (at) gmail (dot) com # # Released under GPL-3 license: # http://www.gnu.org/licenses/gpl-3.0.html # ========================================= package provide colorpicker $version variable presets { ffffff dfdfdf bbbbbb ffc7c6 ffe3c6 feffc6 c6ffc7 c6feff c7c6ff e3c6ff 9f9f9f 7c7c7c 606060 ff0400 ff8300 faff00 00ff04 00faff 0400ff 9c00ff 404040 202020 000000 551312 553512 535512 0f4710 0e4345 131255 2f004d } proc colorpicker {w mode args} { variable {} set modes {switches hsv} if {[lsearch -exact $modes $mode] == -1} { error "bad mode: $mode. must be one of: $modes." } set ($w:mode) $mode set ($w:color) "#000000" set ($w:command) {} set ($w:textvar) {} frame $w init_$mode $w rename $w ::colorpicker::_$w interp alias {} $w {} ::colorpicker::dispatch $w if {$args != {}} {uplevel 1 ::colorpicker::config $w $args} return $w } proc dispatch {w cmd args} { variable {} switch -glob -- $cmd { get {set ($w:color)} set {uplevel 1 [linsert $args 0 ::colorpicker::set_color_ext $w]} con* {uplevel 1 [linsert $args 0 ::colorpicker::config $w]} default {uplevel 1 [linsert $args 0 ::colorpicker::_$w $cmd]} } } proc config {w args} { variable {} set options {} set flag 0 foreach {key value} $args { switch -glob -- $key { -com* { set ($w:command) $value set flag 1 } -textvar* { set ($w:textvar) $value set flag 1 } default { lappend options $key $value } } } if {!$flag || $options != ""} { uplevel 1 [linsert $options 0 ::scrolledframe::_$w config] } } proc set_color_ext {w c} { # called by the widget public method variable {} set c [string tolower $c] if {![regexp {^#[0-9a-f]{6,6}$} $c]} { error "Invalid color: $c. Specify a color in the format #HHHHHH" } switch -exact -- $($w:mode) { switches { set_color $w $c } hsv { set r [expr 0x[string range $c 1 2]] set g [expr 0x[string range $c 3 4]] set b [expr 0x[string range $c 5 6]] set hsv [rgbToHsv $r $g $b] hsv_set $w h [lindex $hsv 0] hsv_set $w s [lindex $hsv 1] hsv_set $w v [lindex $hsv 2] set_color $w $c } } } proc set_color {w c} { # called internally in reaction to events variable {} set c [string tolower $c] set ($w:color) $c if {$($w:command) != {}} { set cmd $($w:command) lappend cmd $c uplevel #0 $cmd } if {$($w:textvar) != {}} { uplevel #0 [list set $($w:textvar) $c] } switch -exact -- $($w:mode) { switches { variable presets set q 0 for {set row 0} {$row < 3} {incr row} { for {set col 0} {$col < 10} {incr col} { set b [expr {$c == "#[lindex $presets $q]"}] ${w}.r${row}c${col} configure \ -relief [lindex {raised sunken} $b] incr q } } } hsv { } } } proc mkColor {rgb} { set r [lindex $rgb 0]; set g [lindex $rgb 1]; set b [lindex $rgb 2] if {$r < 0} {set r 0} elseif {$r > 255} {set r 255} if {$g < 0} {set g 0} elseif {$g > 255} {set g 255} if {$b < 0} {set b 0} elseif {$b > 255} {set b 255} return #[format "%2.2x%2.2x%2.2x" $r $g $b] } proc rgbToHsv {r g b} { set sorted [lsort -real [list $r $g $b]] set temp [lindex $sorted 0] set v [lindex $sorted 2] set value $v set bottom [expr {$v-$temp}] if {$bottom == 0} { set hue 0 set saturation 0 set value $v } else { if {$v == $r} { set top [expr {$g-$b}] if {$g >= $b} { set angle 0 } else { set angle 360 } } elseif {$v == $g} { set top [expr {$b-$r}] set angle 120 } elseif {$v == $b} { set top [expr {$r-$g}] set angle 240 } set hue [expr {round(60*(double($top)/$bottom)+$angle)}] } if {$v == 0} { set saturation 0 } else { set saturation [expr {round(255-255*(double($temp)/$v))}] } return [list $hue $saturation $value] } proc hsvToRgb {h s v} { set hi [expr {int(double($h)/60)%6}] set f [expr {double($h)/60-$hi}] set s [expr {double($s)/255}] set v [expr {double($v)/255}] set p [expr {double($v)*(1-$s)}] set q [expr {double($v)*(1-$f*$s)}] set t [expr {double($v)*(1-(1-$f)*$s)}] switch -- $hi { 0 {set r $v; set g $t; set b $p} 1 {set r $q; set g $v; set b $p} 2 {set r $p; set g $v; set b $t} 3 {set r $p; set g $q; set b $v} 4 {set r $t; set g $p; set b $v} 5 {set r $v; set g $p; set b $q} default {error "[lindex [info level 0] 0]: bad H value"} } set r [expr {round($r*255)}] set g [expr {round($g*255)}] set b [expr {round($b*255)}] return [list $r $g $b] } proc init_switches {w} { variable {} variable presets set q 0 for {set row 0} {$row < 3} {incr row} { for {set col 0} {$col < 10} {incr col} { set c "#[lindex $presets $q]" set b [expr {$($w:color) == $c}] grid [frame ${w}.r${row}c${col} -width 18 -height 16 \ -borderwidth 1 -relief [lindex {raised sunken} $b] \ -background $c -highlightthickness 0] \ -row $row -column $col bind ${w}.r${row}c${col} \ "[namespace current]::set_color $w $c" incr q } } } proc init_hsv {w} { variable colorhsv set colorhsv($w:h) 0 set colorhsv($w:s) 255 set colorhsv($w:v) 255 grid [canvas ${w}.hue -width 130 -height 15 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 0 grid [canvas ${w}.sat -width 130 -height 14 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 1 grid [canvas ${w}.val -width 130 -height 14 -borderwidth 1 \ -relief sunken -highlightthickness 0] -column 0 -row 2 grid [canvas ${w}.test -width 46 -height 46 -borderwidth 1 \ -relief sunken -highlightthickness 0 -background red] \ -column 1 -row 0 -rowspan 3 variable mh variable ms variable mv set mh($w) 0; set ms($w) 0; set mv($w) 0; set sh "[namespace current]::hsv_set $w h \[expr {%x*360.0/130.0}\]" set ss "[namespace current]::hsv_set $w s \[expr {%x*255.0/130.0}\]" set sv "[namespace current]::hsv_set $w v \[expr {%x*255.0/130.0}\]" bind ${w}.hue "set [namespace current]::mh($w) 1; $sh" bind ${w}.sat "set [namespace current]::ms($w) 1; $ss" bind ${w}.val "set [namespace current]::mv($w) 1; $sv" bind ${w}.hue "set [namespace current]::mh($w) 0" bind ${w}.sat "set [namespace current]::ms($w) 0" bind ${w}.val "set [namespace current]::mv($w) 0" bind ${w}.hue "if {\$[namespace current]::mh($w)} {$sh}" bind ${w}.sat "if {\$[namespace current]::ms($w)} {$ss}" bind ${w}.val "if {\$[namespace current]::mv($w)} {$sv}" for {set x 0} {$x < 130} {incr x 3} { set c [mkColor [hsvToRgb [expr {$x*360.0/130.0}] 255 255]] ${w}.hue create rectangle $x 0 [expr {4+$x}] 16 -fill $c -outline {} } hsv_regen $w $colorhsv($w:h) } proc hsv_regen {w hue} { ${w}.sat delete all ${w}.val delete all for {set x 0} {$x < 130} {incr x 3} { set x1 [expr {$x*255.0/130.0}] set c1 [mkColor [hsvToRgb $hue $x1 255]] set c2 [mkColor [hsvToRgb $hue 255 $x1]] ${w}.sat create rectangle $x 0 [expr {4+$x}] 16 \ -fill $c1 -outline {} ${w}.val create rectangle $x 0 [expr {4+$x}] 16 \ -fill $c2 -outline {} } } proc hsv_set {w what val} { variable colorhsv if {$what != {h} && $what != {s} && $what != {v}} {return} set colorhsv($w:$what) $val if {$colorhsv($w:$what) < 0.0} {set colorhsv($w:$what) 0} if {$what == {h}} { if {$colorhsv($w:$what) >= 360.0} {set colorhsv($w:$what) 0} hsv_regen $w $colorhsv($w:$what) } else { if {$colorhsv($w:$what) > 255.0} {set colorhsv($w:$what) 255} } set c [mkColor [hsvToRgb \ $colorhsv($w:h) $colorhsv($w:s) $colorhsv($w:v)]] ${w}.test configure -background $c set_color $w $c } } ====== <>Category Widget|Category GUI