#!../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