aboutsummaryrefslogtreecommitdiff
path: root/colorpicker.tcl
blob: 0c433cb7d4940570aef52d3d64bb47e91bb44287 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
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
    }
}