From f5c3dd4535befd4ac26cdf2406563eed94f27cc2 Mon Sep 17 00:00:00 2001
From: mescalinum <mescalinum@users.sourceforge.net>
Date: Wed, 16 Sep 2009 08:23:36 +0000
Subject: property panel stuff

svn path=/trunk/externals/tclpd/; revision=12363
---
 colorpicker.tcl | 281 +++++++++++++++++++++++++++++++++++++
 properties.tcl  | 423 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 704 insertions(+)
 create mode 100644 colorpicker.tcl
 create mode 100644 properties.tcl

diff --git a/colorpicker.tcl b/colorpicker.tcl
new file mode 100644
index 0000000..0c433cb
--- /dev/null
+++ b/colorpicker.tcl
@@ -0,0 +1,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
+    }
+}
diff --git a/properties.tcl b/properties.tcl
new file mode 100644
index 0000000..addb624
--- /dev/null
+++ b/properties.tcl
@@ -0,0 +1,423 @@
+if {[catch {package require colorpicker}]} {
+    source [file join [file dirname [info script]] colorpicker.tcl]
+    package require colorpicker
+}
+namespace import ::colorpicker::colorpicker
+
+proc propertieswindow {gfxstub_id {options {}} {title {}}} {
+    set win $gfxstub_id
+    set ::id($win.p) $gfxstub_id
+    set ::optkeys($win.p) [list]
+    foreach {k v} $options {
+        set ::config($win.p:$k) $v
+        lappend ::optkeys($win.p) $k
+    }
+    toplevel $win
+    pack [propertiespanel $win.p]
+    wm resizable $win 0 0
+    wm title $win $title
+    set win
+}
+
+proc has_key {w key} {
+    expr {[lsearch -exact $::optkeys($w) $key] != -1}
+}
+
+proc propertiespanel {w} {
+    set pad [propertiespanel_padding $w]
+    incr pad $pad
+    frame $w -borderwidth 0 -relief raised -padx $pad -pady $pad
+    set subpanels {dimensions output behavior connective label colors}
+    foreach subpanel $subpanels {
+        set x [propertiespanel_$subpanel $w]
+        if {$x != {}} {grid $x -sticky ew -in $w}
+    }
+    set x [propertiespanel_buttons $w]
+    grid $x -in $w
+    grid columnconfigure . 0 -weight 1
+    set w
+}
+
+proc propertiespanel_padding {w} {
+    return 3
+}
+
+proc propertiespanel_dimensions {w} {
+    set x ${w}.dimensions
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Dimensions:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0; set col 0
+    if {[has_key $w -width]} {
+        grid [label ${x}.wl -text "Width (px):" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.w -textvar ::config($w:-width) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -height]} {
+        grid [label ${x}.hl -text "Height (px):" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.h -textvar ::config($w:-height) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -uwidth]} {
+        grid [label ${x}.uwl -text "Width (cells):" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.uw -textvar ::config($w:-uwidth) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -uheight]} {
+        grid [label ${x}.uhl -text "Height (cells):" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.uh -textvar ::config($w:-uheight) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -cellsize]} {
+        grid [label ${x}.csl -text "Cell size (pixels):" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.cs -textvar ::config($w:-cellsize) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -cellwidth]} {
+        grid [label ${x}.uwl -text "Cell width:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.uw -textvar ::config($w:-cellwidth) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -cellheight]} {
+        grid [label ${x}.uhl -text "Cell height:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.uh -textvar ::config($w:-cellheight) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {$count == 0} {return {}}
+    set x
+}
+
+proc propertiespanel_output {w} {
+    set x ${w}.output
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Output range:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0; set col 0
+    if {[has_key $w -rangebottom]} {
+        grid [label ${x}.rbl -text "Bottom:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rb -textvar ::config($w:-rangebottom) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -rangetop]} {
+        grid [label ${x}.rtl -text "Top:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rt -textvar ::config($w:-rangetop) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -rangeleft]} {
+        grid [label ${x}.rll -text "Left:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rl -textvar ::config($w:-rangeleft) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -rangeright]} {
+        grid [label ${x}.rrl -text "Right:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rr -textvar ::config($w:-rangeright) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -rangemin]} {
+        grid [label ${x}.rml -text "Min:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rm -textvar ::config($w:-rangemin) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -rangemax]} {
+        grid [label ${x}.rMl -text "Max:" -anchor e] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        grid [entry ${x}.rM -textvar ::config($w:-rangemax) -width 5] \
+            -row $row -column $col -sticky ew -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {[has_key $w -logarithmic]} {
+        incr col
+        grid [checkbutton ${x}.rL -variable ::config($w:-logarithmic) \
+            -text "Logarithmic"] \
+            -row $row -column $col -columnspan 3 -sticky w -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {$count == 0} {return {}}
+    set x
+}
+
+proc propertiespanel_behavior {w} {
+    set x ${w}.behavior
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Widget behavior:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0; set col 0
+    if {[has_key $w -jumponclick]} {
+        grid [checkbutton ${x}.joc -variable ::config($w:-jumponclick) \
+            -text "Jump on click"] \
+            -row $row -column $col -sticky w -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    if {[has_key $w -init]} {
+        grid [checkbutton ${x}.init -variable ::config($w:-init) \
+            -text "Output init value"] \
+            -row $row -column $col -sticky w -padx $pad -pady $pad
+        incr col
+        incr count
+    }
+    incr row; set col 0
+    if {$count == 0} {return {}}
+    set x
+}
+
+proc propertiespanel_label {w} {
+    set x ${w}.label
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Label:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0
+    if {[has_key $w -label]} {
+        grid [label ${x}.ll -text "Text:" -anchor e] \
+            -row $row -column 0 -sticky ew -padx $pad -pady $pad
+        grid [entry ${x}.l -textvar ::config($w:-label)] \
+            -row $row -column 1 -sticky ew -padx $pad -pady $pad
+        incr row
+        incr count
+    }
+    if {[has_key $w -labelpos]} {
+        grid [label ${x}.lpl -text "Position:" -anchor e] \
+            -row $row -column 0 -sticky ew -padx $pad -pady $pad
+        frame ${x}.f
+        if {![info exists ::config($w:-labelpos)]} {
+            set ::config($w:-labelpos) top
+        }
+        grid [radiobutton ${x}.f.lp1 -variable ::config($w:-labelpos) \
+            -value top -text Top] \
+            -row 1 -column 1 -sticky w -padx $pad -pady $pad -in ${x}.f
+        grid [radiobutton ${x}.f.lp2 -variable ::config($w:-labelpos) \
+            -value bottom -text Bottom] \
+            -row 1 -column 2 -sticky w -padx $pad -pady $pad -in ${x}.f
+        grid [radiobutton ${x}.f.lp3 -variable ::config($w:-labelpos) \
+            -value left -text Left] \
+            -row 2 -column 1 -sticky w -padx $pad -pady $pad -in ${x}.f
+        grid [radiobutton ${x}.f.lp4 -variable ::config($w:-labelpos) \
+            -value right -text Right] \
+            -row 2 -column 2 -sticky w -padx $pad -pady $pad -in ${x}.f
+        grid ${x}.f -sticky w -row $row -column 1
+        incr row
+        incr count
+    }
+    if {$count == 0} {return {}}
+    set x
+}
+
+proc propertiespanel_connective {w} {
+    set x ${w}.connective
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Messages:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0
+    if {[has_key $w -sendsymbol]} {
+        grid [label ${x}.ssl -text "Send symbol:" -anchor e] \
+            -row $row -column 0 -sticky ew -padx $pad -pady $pad
+        grid [entry ${x}.ss -textvar ::config($w:-sendsymbol) -width 15] \
+            -row $row -column 1 -sticky ew -padx $pad -pady $pad
+        incr row
+        incr count
+    }
+    if {[has_key $w -receivesymbol]} {
+        grid [label ${x}.rsl -text "Receive symbol:" -anchor e] \
+            -row $row -column 0 -sticky ew -padx $pad -pady $pad
+        grid [entry ${x}.rs -textvar ::config($w:-receivesymbol) -width 15] \
+            -row $row -column 1 -sticky ew -padx $pad -pady $pad
+        incr row
+        incr count
+    }
+    if {$count == 0} {return {}}
+    set x
+}
+
+proc propertiespanel_colors {w} {
+    set colors {-bgcolor Background -fgcolor Foreground -lblcolor Label}
+    set x ${w}.colors
+    set pad [propertiespanel_padding $w]
+    labelframe $x -text "Colors:" -borderwidth 1 -relief raised
+    set count 0
+    set row 0
+    foreach {optkey color} $colors {
+        if {![has_key $w $optkey]} {continue}
+        grid [label ${x}.l$color -text "${color}:" -anchor e] \
+            -row $row -column 0 -sticky ew -padx $pad -pady $pad
+        grid [entry ${x}.t$color -textvar ::config($w:$optkey) -width 8] \
+            -row $row -column 1 -sticky ew -padx $pad -pady $pad
+        grid [frame ${x}.p$color -width 20 -height 20 \
+            -borderwidth 1 -relief sunken] \
+            -row $row -column 2 -sticky ew -padx $pad -pady $pad
+        grid [button ${x}.b$color -text "Pick..." -overrelief {} \
+            -command {} \
+            ] -row $row -column 3 -sticky ew -padx $pad -pady $pad
+        bind ${x}.b$color <Enter> {break}
+        bind ${x}.b$color <Leave> {break}
+        bind ${x}.b$color <ButtonPress-1> [list \
+            propertiespanel_colors_pick \
+            $w $x $colors ${x}.b$color ${x}.p$color ${x}.t$color]
+        trace add variable ::config($w:$optkey) write [list \
+            propertiespanel_colors_set_wrap $w $x ${x}.p$color $optkey]
+        incr row
+        incr count
+    }
+    if {![info exists ::cpt($w)]} {set ::cpt($w) switches}
+    foreach {optkey color} $colors {
+        if {![has_key $w $optkey]} {continue}
+        # trigger the variable trace:
+        if {[info exists ::config($w:$optkey)]} {
+            set ::config($w:$optkey) $::config($w:$optkey)
+        }
+    }
+    if {$count == 0} {return {}}
+    frame ${x}.f
+    grid [radiobutton ${x}.f.cpt1 -variable ::cpt($w) -justify right \
+        -value switches -text Switches] \
+        -row 0 -column 0 -sticky ew -padx $pad -pady $pad
+    grid [radiobutton ${x}.f.cpt2 -variable ::cpt($w) -justify right \
+        -value hsv -text HSV] \
+        -row 1 -column 0 -sticky ew -padx $pad -pady $pad
+    grid ${x}.f -row $row -column 0
+    grid [colorpicker ${x}.cp2 hsv] \
+        -row $row -column 1 -columnspan 3 -sticky ew -padx $pad -pady $pad
+    grid [colorpicker ${x}.cp1 switches -command [list ${x}.cp2 set]] \
+        -row $row -column 1 -columnspan 3 -sticky ew -padx $pad -pady $pad
+    raise ${x}.cp1
+    trace add variable ::cpt($w) write \
+        [list propertiespanel_colors_switchpicker $w $x $row]
+    set x
+}
+
+proc propertiespanel_colors_set_wrap {w x wp optkey config_ idx op} {
+    propertiespanel_colors_set $w $x $wp {} -1 $::config($w:$optkey)
+}
+
+proc propertiespanel_colors_switchpicker {w x row cpt idx op} {
+    raise ${x}.cp[expr {1+($::cpt($w) == {hsv})}]
+}
+
+proc propertiespanel_colors_pick {w x colors wb wp wt} {
+    foreach {k color} $colors {
+        ${x}.b$color configure -relief raised -state normal
+    }
+    set r [$wb cget -relief]
+    if {$r == {sunken}} {
+        $wb configure -relief raised
+        ${x}.cp1 configure -command {}
+        ${x}.cp2 configure -command {}
+    } else {
+        $wb configure -relief sunken
+        ${x}.cp1 configure -command \
+            [list propertiespanel_colors_set $w $x $wp $wt 1]
+        ${x}.cp2 configure -command \
+            [list propertiespanel_colors_set $w $x $wp $wt 2]
+    }
+}
+
+proc propertiespanel_colors_set {w x wp wt from color} {
+    if {$wt != {}} {$wt delete 0 end ; $wt insert 0 $color}
+    $wp configure -background $color
+    if {$::cpt($w) == {switches} && $from == 1} {
+        ${x}.cp2 set $color
+    }
+}
+
+proc propertiespanel_buttons {w} {
+    set x ${w}.buttons
+    set pad [propertiespanel_padding $w]
+    frame $x -padx $pad -pady $pad
+    set col 0
+    foreach action {Cancel Apply Ok} {
+        grid [button ${x}.btn$action \
+            -command [list propertiespanel_buttons_action $w $action] \
+            -text $action] \
+            -row 0 -column $col -padx $pad -pady $pad
+        incr col
+    }
+    set x
+}
+
+proc propertiespanel_buttons_action {w action} {
+    switch -- $action {
+        Cancel {
+            propertiespanel_close $w
+        }
+        Apply {
+            propertiespanel_apply $w
+        }
+        Ok {
+            propertiespanel_apply $w
+            propertiespanel_close $w
+        }
+    }
+}
+
+proc propertiespanel_apply {w} {
+    set newconf [list]
+    foreach key $::optkeys($w) {
+        set v $::config($w:$key)
+        if {$v == ""} {set v "empty"}
+        lappend newconf $key $v
+    }
+    set newconf [string map {$ \\$} $newconf]
+    pd [concat $::id($w) config {*}$newconf \;]
+}
+
+proc propertiespanel_close {w} {
+    pd [concat $::id($w) cancel \;]
+}
-- 
cgit v1.2.1