FF colorpicker
Summary
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 gridding 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.
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} <ButtonPress-1> \
"[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 <ButtonPress-1> "set [namespace current]::mh($w) 1; $sh"
bind ${w}.sat <ButtonPress-1> "set [namespace current]::ms($w) 1; $ss"
bind ${w}.val <ButtonPress-1> "set [namespace current]::mv($w) 1; $sv"
bind ${w}.hue <ButtonRelease-1> "set [namespace current]::mh($w) 0"
bind ${w}.sat <ButtonRelease-1> "set [namespace current]::ms($w) 0"
bind ${w}.val <ButtonRelease-1> "set [namespace current]::mv($w) 0"
bind ${w}.hue <Motion> "if {\$[namespace current]::mh($w)} {$sh}"
bind ${w}.sat <Motion> "if {\$[namespace current]::ms($w)} {$ss}"
bind ${w}.val <Motion> "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
}
}Here's the usage above reworked a bit to let you use 'stand alone' (assuming the above code is in a file named colorpicker.tcl along side)
if {[catch {package require colorpicker}]} {
source [file join [file dirname [info script]] "colorpicker.tcl"]
package require colorpicker
}
namespace import ::colorpicker::colorpicker
colorpicker .picker1 switches -command {.picker2 set}
grid .picker1 -row 1 -column 1
colorpicker .picker2 hsv -textvar ::color2
grid .picker2 -row 2 -column 1
button .btn -text "Get Color" -command {
.txt delete 0.0 end
.txt insert end "[.picker2 get]"
}
grid .btn -row 1 -column 2
text .txt -width 22 -height 3
grid .txt -row 2 -column 2