util/X86LINUX64/lib/blt2.5/demos/scripts/xcolors.tcl

   1 #!../bltwish
   2 #
   3 #  Tk version of xcolors
   4 #
   5
   6 package require BLT
   7 # --------------------------------------------------------------------------
   8 # Starting with Tcl 8.x, the BLT commands are stored in their own
   9 # namespace called "blt".  The idea is to prevent name clashes with
  10 # Tcl commands and variables from other packages, such as a "table"
  11 # command in two different packages.
  12 #
  13 # You can access the BLT commands in a couple of ways.  You can prefix
  14 # all the BLT commands with the namespace qualifier "blt::"
  15 #
  16 #    blt::graph .g
  17 #    blt::table . .g -resize both
  18 #
  19 # or you can import all the command into the global namespace.
  20 #
  21 #    namespace import blt::*
  22 #    graph .g
  23 #    table . .g -resize both
  24 #
  25 # --------------------------------------------------------------------------
  26 if { $tcl_version >= 8.0 } {
  27     namespace import blt::*
  28     namespace import -force blt::tile::*
  29 }
  30 source scripts/demo.tcl
  31 set numCols 0
  32 set numRows 0
  33 set maxCols 15
  34 set cellWidth 40
  35 set cellHeight 20
  36 set numCells 0
  37 set lastCount 0
  38 set beginInput(0) 0
  39 set map 0
  40 set entryCount 0
  41 set lastTagId {}
  42
  43 scrollbar .xscroll -command { .canvas xview } -orient horizontal
  44 scrollbar .yscroll -command { .canvas yview }
  45
  46 label .sample \
  47     -font -*-new*century*schoolbook*-bold-r-*-*-24-*-*-*-*-*-*-* \
  48     -text {"Bisque is Beautiful".}
  49
  50 button .name -font -*-helvetica-medium-r-*-*-18-*-*-*-*-*-*-* \
  51     -command "AddSelection name"
  52 button .rgb -font -*-courier-medium-r-*-*-18-*-*-*-*-*-*-* \
  53     -command "AddSelection rgb"
  54
  55 canvas .canvas \
  56     -confine 1 \
  57     -yscrollcommand { .yscroll set } \
  58     -width [expr 16*$cellWidth] -height 400  \
  59     -scrollregion [list 0 0 [expr 16*$cellWidth] 800]
  60
  61 frame .border -bd 2 -relief raised
  62
  63 label .status \
  64     -anchor w \
  65     -font -*-helvetica-medium-r-*-*-14-*-*-*-*-*-*-*
  66
  67 button .quit -text "Quit" -command "exit"
  68 button .next -text "Next" -command "DisplayColors next"
  69 button .prev -text "Previous" -command "DisplayColors last"
  70
  71 selection handle .name GetColor
  72 selection handle .rgb GetValue
  73
  74 bind .name <Enter> {
  75     .status config -text \
  76         "Press button to write color name into primary selection"
  77 }
  78
  79 bind .rgb <Enter> {
  80     .status config -text \
  81         "Press button to write RGB value into primary selection"
  82 }
  83 bind .name <Leave> {
  84     .status config -text ""
  85 }
  86
  87 bind .rgb <Leave> {
  88     .status config -text ""
  89 }
  90
  91 bind .canvas <Enter> {
  92     .status config -text \
  93         "Press button 1 to change background; Button 2 changes foreground"
  94 }
  95
  96
  97 table . \
  98     .sample 0,0 -cspan 2 -fill both -reqheight 1i \
  99     .name 1,0 -fill both -anchor w \
 100     .rgb 1,1 -fill both -anchor w \
 101     .canvas 2,0 -cspan 2 -fill both \
 102     .yscroll 2,2 -fill y \
 103     .border 3,0 -cspan 2 -fill x -reqheight 8 \
 104     .status 4,0 -cspan 2 -fill both  \
 105     .quit 4,1 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4 \
 106     .prev 5,0 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4 \
 107     .next 5,1 -anchor e -reqwidth 1i -fill y -padx 10 -pady 4
 108
 109 proc AddSelection { what } {
 110     selection own .$what
 111     if {$what == "name" } {
 112         set mesg "Color name written into primary selection"
 113     } else {
 114         set mesg "RGB value written into primary selection"
 115     }
 116     .status config -text $mesg
 117 }
 118
 119 proc GetColor { args } {
 120     return [lindex [.name config -text] 4]
 121 }
 122
 123 proc GetValue { args } {
 124     return [lindex [.rgb config -text] 4]
 125 }
 126
 127 proc ShowInfo { tagId what info } {
 128     global lastTagId
 129
 130     if { $lastTagId != {} } {
 131         .canvas itemconfig $lastTagId -width 1
 132     }
 133     .canvas itemconfig $tagId -width 3
 134     set lastTagId $tagId
 135
 136     set name [lindex $info 3]
 137     .name config -text $name
 138     set value [format "#%0.2x%0.2x%0.2x" \
 139                [lindex $info 0] [lindex $info 1] [lindex $info 2]]
 140     .rgb config -text $value
 141     .sample config $what $name
 142     .status config -bg $name
 143 }
 144
 145
 146 proc MakeCell { info } {
 147     global numCols numRows maxCols cellWidth cellHeight numCells
 148
 149     set x [expr $numCols*$cellWidth]
 150     set y [expr $numRows*$cellHeight]
 151     set color [lindex $info 3]
 152
 153     if [catch {winfo rgb . $color}] {
 154         return "ok"
 155     }
 156 #    if { [tk colormodel .] != "color" } {
 157 #       bind . <Leave> {
 158 #           .status config -text "Color table full after $numCells entries."
 159 #       }
 160 #       .status config -text "Color table full after $numCells entries."
 161 #       return "out of colors"
 162 #    }
 163     set id [.canvas create rectangle \
 164             $x $y [expr $x+$cellWidth] [expr $y+$cellHeight] \
 165                 -fill $color -outline black]
 166     if { $color == "white" } {
 167         global whiteTagId
 168         set whiteTagId $id
 169     }
 170
 171     .canvas bind $id <1> [list ShowInfo $id -bg $info]
 172     .canvas bind $id <2> [list ShowInfo $id -fg $info]
 173
 174     incr numCols
 175     if { $numCols > $maxCols } {
 176         set numCols 0
 177         incr numRows
 178     }
 179     return "ok"
 180 }
 181
 182 proc DisplayColors { how } {
 183     global lastCount numCells cellHeight numRows numCols rgbText
 184     global map beginInput
 185
 186 #    tk colormodel . color
 187     set initialized no
 188
 189     if { $how == "last" } {
 190         if { $map == 0 } {
 191             return
 192         }
 193         set map [expr $map-1]
 194     } else {
 195         incr map
 196         if ![info exists beginInput($map)] {
 197             set beginInput($map) $lastCount
 198         }
 199     }
 200
 201     set start $beginInput($map)
 202
 203     if { $numCells > 0 } {
 204         .canvas delete all
 205         set numRows 0
 206         set numCols 0
 207         set initialized yes
 208     }
 209
 210     set input [lrange $rgbText $start end]
 211     set lineCount $start
 212     set entryCount 0
 213     foreach i $input {
 214         incr lineCount
 215         if { [llength $i] == 4 } {
 216             if { [MakeCell $i] == "out of colors"  } {
 217                 break
 218             }
 219             incr entryCount
 220         }
 221     }
 222     if { $entryCount == 0 } {
 223         bind . <Leave> {
 224             .status config -text "No more entries in RGB database"
 225         }
 226         .status config -text "No more entries in RGB database"
 227     }
 228     set lastCount $lineCount
 229     proc tkerror {args} {
 230         #dummy procedure
 231     }
 232
 233     if { $initialized == "no" } {
 234         global cellWidth
 235
 236         set height [expr $cellHeight*($numRows+1)]
 237         .canvas config -scrollregion [list 0 0 [expr 16*$cellWidth] $height]
 238         if { $height < 800 } {
 239             .canvas config -height $height
 240         }
 241         global whiteTagId
 242         if [info exists whiteTagId] {
 243             ShowInfo $whiteTagId -bg {255 255 255 white}
 244         }
 245     }
 246     update idletasks
 247     update
 248     rename tkerror {}
 249 }
 250
 251 wm min . 0 0
 252
 253 foreach location {
 254         /usr/X11R6
 255         /util/X11R6
 256         /usr/openwin
 257         /usr/dt
 258 } {
 259     set file [file join $location lib X11 rgb.txt]
 260     if { [file exists $file] } {
 261        break
 262     }
 263 }
 264 set in [open $file "r"]
 265 set rgbText [read $in]
 266 close $in
 267 set rgbText [split $rgbText \n]
 268 DisplayColors next
 269 wm min . 0 0
 270
 271