diff options
Diffstat (limited to 'blt/demos/scripts/xcolors.tcl')
| -rwxr-xr-x | blt/demos/scripts/xcolors.tcl | 271 |
1 files changed, 271 insertions, 0 deletions
diff --git a/blt/demos/scripts/xcolors.tcl b/blt/demos/scripts/xcolors.tcl new file mode 100755 index 00000000000..40241c737f8 --- /dev/null +++ b/blt/demos/scripts/xcolors.tcl @@ -0,0 +1,271 @@ +#!../bltwish +# +# Tk version of xcolors +# + +package require BLT +# -------------------------------------------------------------------------- +# Starting with Tcl 8.x, the BLT commands are stored in their own +# namespace called "blt". The idea is to prevent name clashes with +# Tcl commands and variables from other packages, such as a "table" +# command in two different packages. +# +# You can access the BLT commands in a couple of ways. You can prefix +# all the BLT commands with the namespace qualifier "blt::" +# +# blt::graph .g +# blt::table . .g -resize both +# +# or you can import all the command into the global namespace. +# +# namespace import blt::* +# graph .g +# table . .g -resize both +# +# -------------------------------------------------------------------------- +if { $tcl_version >= 8.0 } { + namespace import blt::* + namespace import -force blt::tile::* +} +source scripts/demo.tcl +set numCols 0 +set numRows 0 +set maxCols 15 +set cellWidth 40 +set cellHeight 20 +set numCells 0 +set lastCount 0 +set beginInput(0) 0 +set map 0 +set entryCount 0 +set lastTagId {} + +scrollbar .xscroll -command { .canvas xview } -orient horizontal +scrollbar .yscroll -command { .canvas yview } + +label .sample \ + -font -*-new*century*schoolbook*-bold-r-*-*-24-*-*-*-*-*-*-* \ + -text {"Bisque is Beautiful".} + +button .name -font -*-helvetica-medium-r-*-*-18-*-*-*-*-*-*-* \ + -command "AddSelection name" +button .rgb -font -*-courier-medium-r-*-*-18-*-*-*-*-*-*-* \ + -command "AddSelection rgb" + +canvas .canvas \ + -confine 1 \ + -yscrollcommand { .yscroll set } \ + -width [expr 16*$cellWidth] -height 400 \ + -scrollregion [list 0 0 [expr 16*$cellWidth] 800] + +frame .border -bd 2 -relief raised + +label .status \ + -anchor w \ + -font -*-helvetica-medium-r-*-*-14-*-*-*-*-*-*-* + +button .quit -text "Quit" -command "exit" +button .next -text "Next" -command "DisplayColors next" +button .prev -text "Previous" -command "DisplayColors last" + +selection handle .name GetColor +selection handle .rgb GetValue + +bind .name <Enter> { + .status config -text \ + "Press button to write color name into primary selection" +} + +bind .rgb <Enter> { + .status config -text \ + "Press button to write RGB value into primary selection" +} +bind .name <Leave> { + .status config -text "" +} + +bind .rgb <Leave> { + .status config -text "" +} + +bind .canvas <Enter> { + .status config -text \ + "Press button 1 to change background; Button 2 changes foreground" +} + + +table . \ + .sample 0,0 -cspan 2 -fill both -reqheight 1i \ + .name 1,0 -fill both -anchor w \ + .rgb 1,1 -fill both -anchor w \ + .canvas 2,0 -cspan 2 -fill both \ + .yscroll 2,2 -fill y \ + .border 3,0 -cspan 2 -fill x -reqheight 8 \ + .status 4,0 -cspan 2 -fill both \ + .quit 4,1 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4 \ + .prev 5,0 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4 \ + .next 5,1 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4 + +proc AddSelection { what } { + selection own .$what + if {$what == "name" } { + set mesg "Color name written into primary selection" + } else { + set mesg "RGB value written into primary selection" + } + .status config -text $mesg +} + +proc GetColor { args } { + return [lindex [.name config -text] 4] +} + +proc GetValue { args } { + return [lindex [.rgb config -text] 4] +} + +proc ShowInfo { tagId what info } { + global lastTagId + + if { $lastTagId != {} } { + .canvas itemconfig $lastTagId -width 1 + } + .canvas itemconfig $tagId -width 3 + set lastTagId $tagId + + set name [lindex $info 3] + .name config -text $name + set value [format "#%0.2x%0.2x%0.2x" \ + [lindex $info 0] [lindex $info 1] [lindex $info 2]] + .rgb config -text $value + .sample config $what $name + .status config -bg $name +} + + +proc MakeCell { info } { + global numCols numRows maxCols cellWidth cellHeight numCells + + set x [expr $numCols*$cellWidth] + set y [expr $numRows*$cellHeight] + set color [lindex $info 3] + + if [catch {winfo rgb . $color}] { + return "ok" + } +# if { [tk colormodel .] != "color" } { +# bind . <Leave> { +# .status config -text "Color table full after $numCells entries." +# } +# .status config -text "Color table full after $numCells entries." +# return "out of colors" +# } + set id [.canvas create rectangle \ + $x $y [expr $x+$cellWidth] [expr $y+$cellHeight] \ + -fill $color -outline black] + if { $color == "white" } { + global whiteTagId + set whiteTagId $id + } + + .canvas bind $id <1> [list ShowInfo $id -bg $info] + .canvas bind $id <2> [list ShowInfo $id -fg $info] + + incr numCols + if { $numCols > $maxCols } { + set numCols 0 + incr numRows + } + return "ok" +} + +proc DisplayColors { how } { + global lastCount numCells cellHeight numRows numCols rgbText + global map beginInput + +# tk colormodel . color + set initialized no + + if { $how == "last" } { + if { $map == 0 } { + return + } + set map [expr $map-1] + } else { + incr map + if ![info exists beginInput($map)] { + set beginInput($map) $lastCount + } + } + + set start $beginInput($map) + + if { $numCells > 0 } { + .canvas delete all + set numRows 0 + set numCols 0 + set initialized yes + } + + set input [lrange $rgbText $start end] + set lineCount $start + set entryCount 0 + foreach i $input { + incr lineCount + if { [llength $i] == 4 } { + if { [MakeCell $i] == "out of colors" } { + break + } + incr entryCount + } + } + if { $entryCount == 0 } { + bind . <Leave> { + .status config -text "No more entries in RGB database" + } + .status config -text "No more entries in RGB database" + } + set lastCount $lineCount + proc tkerror {args} { + #dummy procedure + } + + if { $initialized == "no" } { + global cellWidth + + set height [expr $cellHeight*($numRows+1)] + .canvas config -scrollregion [list 0 0 [expr 16*$cellWidth] $height] + if { $height < 800 } { + .canvas config -height $height + } + global whiteTagId + if [info exists whiteTagId] { + ShowInfo $whiteTagId -bg {255 255 255 white} + } + } + update idletasks + update + rename tkerror {} +} + +wm min . 0 0 + +foreach location { + /usr/X11R6 + /util/X11R6 + /usr/openwin + /usr/dt +} { + set file [file join $location lib X11 rgb.txt] + if { [file exists $file] } { + break + } +} +set in [open $file "r"] +set rgbText [read $in] +close $in +set rgbText [split $rgbText \n] +DisplayColors next +wm min . 0 0 + + |