blt-demo 2.4z-7ubuntu2 / usr / share / blt2.4 / demos / scripts / xcolors.tcl

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