aboutsummaryrefslogtreecommitdiff
path: root/colorpicker.tcl
diff options
context:
space:
mode:
authormescalinum <mescalinum@users.sourceforge.net>2011-10-02 16:42:06 +0000
committermescalinum <mescalinum@users.sourceforge.net>2011-10-02 16:42:06 +0000
commit44f29524444a96d9e40a76f48750f17e2fdc2974 (patch)
tree179e086e72dd64cd130ee493e78d8535a74a76ec /colorpicker.tcl
parent5a38f01421e93db2cf5b5c05afe84fb73eb89425 (diff)
reorganize tree following template structure
svn path=/trunk/externals/loaders/tclpd/; revision=15443
Diffstat (limited to 'colorpicker.tcl')
-rw-r--r--colorpicker.tcl281
1 files changed, 0 insertions, 281 deletions
diff --git a/colorpicker.tcl b/colorpicker.tcl
deleted file mode 100644
index 0c433cb..0000000
--- a/colorpicker.tcl
+++ /dev/null
@@ -1,281 +0,0 @@
-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
- }
-}