arcadia 0.1.1 → 0.1.2

data/tcl/BWidget-1.8.0/color.tcl

@@ -0,0 +1,493 @@
+namespace eval SelectColor {
+    Widget::define SelectColor color Dialog
+
+    Widget::declare SelectColor {
+        {-title     String     "Select a color" 0}
+        {-parent    String     ""               0}
+        {-color     TkResource ""               0 {label -background}}
+	{-type      Enum       "dialog"         1 {dialog popup}}
+	{-placement String     "center"         1}
+    }
+
+    variable _baseColors {
+        \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00
+        \#000099 \#009900 \#009999 \#990000 \#990099 \#999900
+        \#000000 \#333333 \#666666 \#999999 \#cccccc \#ffffff
+    }
+
+    variable _userColors {
+        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
+        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
+    }
+
+    if {[string equal $::tcl_platform(platform) "unix"]} {
+        set useTkDialogue 0
+    } else {
+        set useTkDialogue 1
+    }
+
+    variable _selectype
+    variable _selection
+    variable _wcolor
+    variable _image
+    variable _hsv
+}
+
+proc SelectColor::create { path args } {
+    Widget::init SelectColor $path $args
+
+    set type [Widget::cget $path -type]
+
+    switch -- [Widget::cget $path -type] {
+	"dialog" {
+	    return [eval [list SelectColor::dialog $path] $args]
+	}
+
+	"popup" {
+	    set list      [list at center left right above below]
+	    set placement [Widget::cget $path -placement]
+	    set where     [lindex $placement 0]
+
+	    if {[lsearch $list $where] < 0} {
+		return -code error \
+		    [BWidget::badOptionString placement $placement $list]
+	    }
+
+	    ## If they specified a parent and didn't pass a second argument
+	    ## in the placement, set the placement relative to the parent.
+	    set parent [Widget::cget $path -parent]
+	    if {[string length $parent]} {
+		if {[llength $placement] == 1} { lappend placement $parent }
+	    }
+	    return [eval [list SelectColor::menu $path $placement] $args]
+	}
+    }
+}
+
+proc SelectColor::menu {path placement args} {
+    variable _baseColors
+    variable _userColors
+    variable _wcolor
+    variable _selectype
+    variable _selection
+
+    Widget::init SelectColor $path $args
+    set top [toplevel $path]
+    set parent [winfo toplevel [winfo parent $top]]
+    wm withdraw  $top
+    wm transient $top $parent
+    wm overrideredirect $top 1
+    catch { wm attributes $top -topmost 1 }
+
+    set frame [frame $top.frame \
+                   -highlightthickness 0 \
+                   -relief raised -borderwidth 2]
+    set col    0
+    set row    0
+    set count  0
+    set colors [concat $_baseColors $_userColors]
+    foreach color $colors {
+        set f [frame $frame.c$count \
+                   -highlightthickness 2 \
+                   -highlightcolor white \
+                   -relief solid -borderwidth 1 \
+                   -width 16 -height 16 -background $color]
+        bind $f <1>     "set SelectColor::_selection $count; break"
+        bind $f <Enter> {focus %W}
+        grid $f -column $col -row $row
+        incr count
+        if {[incr col] == 6 } {
+            set  col 0
+            incr row
+        }
+    }
+    set f [label $frame.c$count \
+               -highlightthickness 2 \
+               -highlightcolor white \
+               -relief flat -borderwidth 0 \
+               -width 16 -height 16 -image [Bitmap::get palette]]
+    grid $f -column $col -row $row
+    bind $f <1>     "set SelectColor::_selection $count; break"
+    bind $f <Enter> {focus %W}
+    pack $frame
+
+    bind $top <1>      {set SelectColor::_selection -1}
+    bind $top <Escape> {set SelectColor::_selection -2}
+    bind $top <FocusOut> [subst {if {"%W" == "$top"} \
+				     {set SelectColor::_selection -2}}]
+    eval [list BWidget::place $top 0 0] $placement
+
+    wm deiconify $top
+    raise $top
+    if {$::tcl_platform(platform) == "unix"} {
+	tkwait visibility $top
+	update
+    }
+    BWidget::SetFocusGrab $top $frame.c0
+
+    vwait SelectColor::_selection
+    BWidget::RestoreFocusGrab $top $frame.c0 destroy
+    Widget::destroy $top
+    if {$_selection == $count} {
+	array set opts {
+	    -parent -parent
+	    -title  -title
+	    -color  -initialcolor
+	}
+	if {[Widget::theme]} {
+	    set native 1
+	    set nativecmd [list tk_chooseColor -parent $parent]
+	    foreach {key val} $args {
+		if {![info exists opts($key)]} {
+		    set native 0
+		    break
+		}
+		lappend nativecmd $opts($key) $val
+	    }
+	    if {$native} {
+		return [eval $nativecmd]
+	    }
+	}
+	return [eval [list dialog $path] $args]
+    } else {
+        return [lindex $colors $_selection]
+    }
+}
+
+
+proc SelectColor::dialog {path args} {
+    variable _baseColors
+    variable _userColors
+    variable _widget
+    variable _selection
+    variable _image
+    variable _hsv
+
+    Widget::init SelectColor $path:SelectColor $args
+    set top   [Dialog::create $path \
+                   -title  [Widget::cget $path:SelectColor -title]  \
+                   -parent [Widget::cget $path:SelectColor -parent] \
+                   -separator 1 -default 0 -cancel 1 -anchor e]
+    wm resizable $top 0 0
+    set dlgf  [$top getframe]
+    set fg    [frame $dlgf.fg]
+    set desc  [list \
+                   base _baseColors "Base colors" \
+                   user _userColors "User colors"]
+    set count 0
+    foreach {type varcol defTitle} $desc {
+        set col   0
+        set lin   0
+        set title [lindex [BWidget::getname "${type}Colors"] 0]
+        if {![string length $title]} {
+            set title $defTitle
+        }
+        set titf  [TitleFrame $fg.$type -text $title]
+        set subf  [$titf getframe]
+        foreach color [set $varcol] {
+            set fround [frame $fg.round$count \
+                            -highlightthickness 1 \
+                            -relief sunken -borderwidth 2]
+            set fcolor [frame $fg.color$count -width 16 -height 12 \
+                            -highlightthickness 0 \
+                            -relief flat -borderwidth 0 \
+                            -background $color]
+            pack $fcolor -in $fround
+            grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1
+
+            bind $fround <ButtonPress-1> [list SelectColor::_select_rgb $count]
+            bind $fcolor <ButtonPress-1> [list SelectColor::_select_rgb $count]
+
+	    bind $fround <Double-1> \
+	    	"SelectColor::_select_rgb [list $count]; [list $top] invoke 0"
+	    bind $fcolor <Double-1> \
+	    	"SelectColor::_select_rgb [list $count]; [list $top] invoke 0"
+
+            incr count
+            if {[incr col] == 6} {
+                incr lin
+                set  col 0
+            }
+        }
+        pack $titf -anchor w -pady 2
+    }
+    set fround [frame $fg.round \
+                    -highlightthickness 0 \
+                    -relief sunken -borderwidth 2]
+    set fcolor [frame $fg.color \
+                    -width 50 \
+                    -highlightthickness 0 \
+                    -relief flat -borderwidth 0]
+    pack $fcolor -in $fround -fill y -expand yes
+    pack $fround -anchor e -pady 2 -fill y -expand yes
+
+    set fd  [frame $dlgf.fd]
+    set f1  [frame $fd.f1 -relief sunken -borderwidth 2]
+    set f2  [frame $fd.f2 -relief sunken -borderwidth 2]
+    set c1  [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0]
+    set c2  [canvas $f2.c -width 15  -height 200 -bd 0 -highlightthickness 0]
+
+    for {set val 0} {$val < 40} {incr val} {
+        $c2 create rectangle 0 [expr {5*$val}] 15 [expr {5*$val+5}] -tags val[expr {39-$val}]
+    }
+    $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target
+
+    pack $c1 $c2
+    pack $f1 $f2 -side left -padx 10 -anchor n
+
+    pack $fg $fd -side left -anchor n -fill y
+
+    bind $c1 <ButtonPress-1> [list SelectColor::_select_hue_sat %x %y]
+    bind $c1 <B1-Motion>     [list SelectColor::_select_hue_sat %x %y]
+
+    bind $c2 <ButtonPress-1> [list SelectColor::_select_value %x %y]
+    bind $c2 <B1-Motion>     [list SelectColor::_select_value %x %y]
+
+    if {![info exists _image] || [catch {image type $_image}]} {
+        set _image [image create photo -width 200 -height 200]
+        for {set x 0} {$x < 200} {incr x 4} {
+            for {set y 0} {$y < 200} {incr y 4} {
+                $_image put \
+		    [eval [list format "\#%04x%04x%04x"] \
+			[hsvToRgb [expr {$x/196.0}] [expr {(196-$y)/196.0}] 0.85]] \
+			-to $x $y [expr {$x+4}] [expr {$y+4}]
+            }
+        }
+    }
+    $c1 create image  0 0 -anchor nw -image $_image
+    $c1 create bitmap 0 0 \
+        -bitmap @[file join $::BWIDGET::LIBRARY "images" "target.xbm"] \
+        -anchor nw -tags target
+
+    set _selection -1
+    set _widget(fcolor) $fg
+    set _widget(chs)    $c1
+    set _widget(cv)     $c2
+    set rgb             [winfo rgb $path [Widget::cget $path:SelectColor -color]]
+    set _hsv            [eval rgbToHsv $rgb]
+    _set_rgb     [eval [list format "\#%04x%04x%04x"] $rgb]
+    _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
+    _set_value   [lindex $_hsv 2]
+
+    $top add -name ok
+    $top add -name cancel
+    set res [$top draw]
+    if {$res == 0} {
+        set color [$fg.color cget -background]
+    } else {
+        set color ""
+    }
+    destroy $top
+    return $color
+}
+
+proc SelectColor::setcolor { idx color } {
+    variable _userColors
+    set _userColors [lreplace $_userColors $idx $idx $color]
+}
+
+proc SelectColor::_select_rgb {count} {
+    variable _baseColors
+    variable _userColors
+    variable _selection
+    variable _widget
+    variable _hsv
+
+    set frame $_widget(fcolor)
+    if {$_selection >= 0} {
+        $frame.round$_selection configure \
+            -relief sunken -highlightthickness 1 -borderwidth 2
+    }
+    $frame.round$count configure \
+        -relief flat -highlightthickness 2 -borderwidth 1
+    focus $frame.round$count
+    set _selection $count
+    set bg   [$frame.color$count cget -background]
+    set user [expr {$_selection-[llength $_baseColors]}]
+    if {$user >= 0 &&
+        [string equal \
+              [winfo rgb $frame.color$_selection $bg] \
+              [winfo rgb $frame.color$_selection white]]} {
+        set bg [$frame.color cget -bg]
+        $frame.color$_selection configure -background $bg
+        set _userColors [lreplace $_userColors $user $user $bg]
+    } else {
+        set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]]
+        _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1]
+        _set_value   [lindex $_hsv 2]
+        $frame.color configure -background $bg
+    }
+}
+
+
+proc SelectColor::_set_rgb {rgb} {
+    variable _selection
+    variable _baseColors
+    variable _userColors
+    variable _widget
+
+    set frame $_widget(fcolor)
+    $frame.color configure -background $rgb
+    set user [expr {$_selection-[llength $_baseColors]}]
+    if {$user >= 0} {
+        $frame.color$_selection configure -background $rgb
+        set _userColors [lreplace $_userColors $user $user $rgb]
+    }
+}
+
+
+proc SelectColor::_select_hue_sat {x y} {
+    variable _widget
+    variable _hsv
+
+    if {$x < 0} {
+        set x 0
+    } elseif {$x > 200} {
+        set x 200
+    }
+    if {$y < 0 } {
+        set y 0
+    } elseif {$y > 200} {
+        set y 200
+    }
+    set hue  [expr {$x/200.0}]
+    set sat  [expr {(200-$y)/200.0}]
+    set _hsv [lreplace $_hsv 0 1 $hue $sat]
+    $_widget(chs) coords target [expr {$x-9}] [expr {$y-9}]
+    _draw_values $hue $sat
+    _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]]
+}
+
+
+proc SelectColor::_set_hue_sat {hue sat} {
+    variable _widget
+
+    set x [expr {$hue*200-9}]
+    set y [expr {(1-$sat)*200-9}]
+    $_widget(chs) coords target $x $y
+    _draw_values $hue $sat
+}
+
+
+
+proc SelectColor::_select_value {x y} {
+    variable _widget
+    variable _hsv
+
+    if {$y < 0} {
+        set y 0
+    } elseif {$y > 200} {
+        set y 200
+    }
+    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
+    set _hsv [lreplace $_hsv 2 2 [expr {(200-$y)/200.0}]]
+    _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]]
+}
+
+
+proc SelectColor::_draw_values {hue sat} {
+    variable _widget
+
+    for {set val 0} {$val < 40} {incr val} {
+        set l   [hsvToRgb $hue $sat [expr {$val/39.0}]]
+        set col [eval [list format "\#%04x%04x%04x"] $l]
+        $_widget(cv) itemconfigure val$val -fill $col -outline $col
+    }
+}
+
+
+proc SelectColor::_set_value {value} {
+    variable _widget
+
+    set y [expr {int((1-$value)*200)}]
+    $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}]
+}
+
+
+# --
+#  Taken from tk8.0/demos/tcolor.tcl
+# --
+# The procedure below converts an HSB value to RGB.  It takes hue, saturation,
+# and value components (floating-point, 0-1.0) as arguments, and returns a
+# list containing RGB components (integers, 0-65535) as result.  The code
+# here is a copy of the code on page 616 of "Fundamentals of Interactive
+# Computer Graphics" by Foley and Van Dam.
+
+proc SelectColor::hsvToRgb {hue sat val} {
+    set v [expr {round(65535.0*$val)}]
+    if {$sat == 0} {
+	return [list $v $v $v]
+    } else {
+	set hue [expr {$hue*6.0}]
+	if {$hue >= 6.0} {
+	    set hue 0.0
+	}
+	set i [expr {int($hue)}]
+	set f [expr {$hue-$i}]
+	set p [expr {round(65535.0*$val*(1 - $sat))}]
+        set q [expr {round(65535.0*$val*(1 - ($sat*$f)))}]
+        set t [expr {round(65535.0*$val*(1 - ($sat*(1 - $f))))}]
+        switch $i {
+	    0 {return [list $v $t $p]}
+	    1 {return [list $q $v $p]}
+	    2 {return [list $p $v $t]}
+	    3 {return [list $p $q $v]}
+	    4 {return [list $t $p $v]}
+            5 {return [list $v $p $q]}
+        }
+    }
+}
+
+
+# --
+#  Taken from tk8.0/demos/tcolor.tcl
+# --
+# The procedure below converts an RGB value to HSB.  It takes red, green,
+# and blue components (0-65535) as arguments, and returns a list containing
+# HSB components (floating-point, 0-1) as result.  The code here is a copy
+# of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
+# by Foley and Van Dam.
+
+proc SelectColor::rgbToHsv {red green blue} {
+    if {$red > $green} {
+	set max $red.0
+	set min $green.0
+    } else {
+	set max $green.0
+	set min $red.0
+    }
+    if {$blue > $max} {
+	set max $blue.0
+    } else {
+	if {$blue < $min} {
+	    set min $blue.0
+	}
+    }
+    set range [expr {$max-$min}]
+    if {$max == 0} {
+	set sat 0
+    } else {
+	set sat [expr {($max-$min)/$max}]
+    }
+    if {$sat == 0} {
+	set hue 0
+    } else {
+	set rc [expr {($max - $red)/$range}]
+	set gc [expr {($max - $green)/$range}]
+	set bc [expr {($max - $blue)/$range}]
+	if {$red == $max} {
+	    set hue [expr {.166667*($bc - $gc)}]
+	} else {
+	    if {$green == $max} {
+		set hue [expr {.166667*(2 + $rc - $bc)}]
+	    } else {
+		set hue [expr {.166667*(4 + $gc - $rc)}]
+	    }
+	}
+	if {$hue < 0.0} {
+	    set hue [expr {$hue + 1.0}]
+	}
+    }
+    return [list $hue $sat [expr {$max/65535}]]
+}
+