canvas widget, examples anyone ?
MATTHEW RODERICK
Has anyone got any good examples of tcl code using the canvas widget, what I'm
trying to do a create a directory tree browsing window which returns the full
path name of the directory selected.
Cheers
Matt
--
Matthew Roderick (csh...@cov.ac.uk) .aka. WAD
Have an exrucialingly pleasant day.
Brent Welch
>Has anyone got any good examples of tcl code using the canvas widget, what I'm
>trying to do a create a directory tree browsing window which returns the full
>path name of the directory selected.
I don't know if this is good, but its something. You'll have to fiddle because I haven't touched this shar file since TK 3.2 days...
Brent Welch
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: canvas_ui size.tk printer.tk alphaBrowser.tk utils.tk
# colors.tk
# Wrapped by welch@corvina on Tue Jun 22 11:08:24 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'canvas_ui' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'canvas_ui'\"
else
echo shar: Extracting \"'canvas_ui'\" \(12985 characters\)
sed "s/^X//" >'canvas_ui' <<'END_OF_FILE'
X#!/project/tcl/bin/wish -f
X#
X# canvas_ui - a draw-like program
X#
XalphaBrowser canvas_ui
X
X# Printer support
X# until this gets into the library
Xsource /project/tcl/src/canvas_ui/printer.tk
Xsource /project/tcl/src/canvas_ui/size.tk
X
X# So the user can change window size
Xwm minsize . 64 64
X
Xset canvas_ui.news {
XThe Left button draws objects of
Xdifferent types, or erases things
Xwhen in erase mode.
X
XThe Middle button scrolls the canvas.
XShift-Middle scrolls faster.
X
XThe Right button moves objects. Click on an
Xitem to move just it, or drag out a region to
Xmove those items in the region.
X
XShift-Left tells you whats under the mouse.
XShift-Right does to, but with a wider range.
X
XControl-Left deletes strokes.
X}
X
X# Canvas and scrollbars
Xframe .f -background $backgroundColor
Xpack append . .f {top expand fill}
X
Xset canHeight 400
Xset canWidth 800
Xset can [canvas .f.can -background $backgroundColor -width 400 -height 200 \
X -scrollregion "0 0 $canWidth $canHeight" \
X -xscrollcommand ".f.xscroll set" \
X -yscrollcommand ".f.yscroll set" ]
X
Xscrollbar .f.xscroll -command "$can xview" -orient horizontal \
X -background $backgroundColor \
X -foreground $passiveColor \
X -activeforeground $activeColor
X
Xscrollbar .f.yscroll -command "$can yview" -orient vertical \
X -background $backgroundColor \
X -foreground $passiveColor \
X -activeforeground $activeColor
X
Xpack append .f .f.xscroll {bottom fillx} .f.yscroll {right filly} \
X .f.can {left expand fill}
X
X# Mode field
XlabeledEntry .feedback .mode "Mode: " 10 {right}
Xproc showMode { mode } {
X .feedback.mode.entry delete 0 end
X .feedback.mode.entry insert 0 $mode
X}
X########################################################################
X
Xproc canvasBindings { can } {
X# Keybindings to make strokes (Left button)
X bind $can <Button-1> {moveTo %W %x %y}
X bind $can <B1-Motion> {drawTo %W %x %y}
X bind $can <ButtonRelease-1> {drawEnd %W %x %y}
X
X# Keybindings to delete strokes (control-Left)
X bind $can <Control-Button-1> {delete %W %x %y}
X
X# Keybindings to scroll (Middle button, fast or slow drag via Shift)
X bind $can <Button-2> {canvasMark %W %x %y }
X bind $can <B2-Motion> {canvasDrag %W %x %y slow }
X bind $can <Shift-Button-2> {canvasMark %W %x %y }
X bind $can <Shift-B2-Motion> {canvasDrag %W %x %y fast }
X
X# Keybindings to query the canvas (Shift, left or right to determine range)
X bind $can <Shift-Button-1> { feedback [whatsThere %W %x %y 1] }
X bind $can <Shift-Button-3> { feedback [whatsThere %W %x %y 5] }
X
X# Keybindings to move items (Button 3)
X bind $can <Button-3> { itemGrab %W %x %y }
X bind $can <B3-Motion> { itemMove %W %x %y }
X bind $can <ButtonRelease-3> { itemEndGrab %W %x %y }
X}
X
X# Modal drawing support
X
Xproc setStrokeMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc strokeDraw
X set endProc strokeEnd
X showMode stroke
X $can configure -cursor pencil
X}
X
Xproc setLineMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc lineDraw
X set endProc lineEnd
X showMode stroke
X $can configure -cursor crosshair
X}
X
Xproc setBoxMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc boxDraw
X set endProc boxEnd
X showMode stroke
X $can configure -cursor cross
X}
X
Xproc setOvalMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc ovalDraw
X set endProc ovalEnd
X showMode stroke
X $can configure -cursor target
X}
X
Xproc setTextMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc textDraw
X set endProc textEnd
X showMode text
X $can configure -cursor tcross
X}
X
Xproc setEraseMode { can } {
X global drawProc endProc mode
X set mode stroke
X set drawProc eraseDraw
X set endProc eraseEnd
X showMode stroke
X $can configure -cursor dotbox
X}
X
Xproc setMode {can newMode} {
X # can is ignored, but we should have per-canvas state
X global mode drawProc endProc
X case $newMode {
X stroke {
X setStrokeMode $can
X }
X line {
X setLineMode $can
X }
X box {
X setBoxMode $can
X }
X oval {
X setOvalMode $can
X }
X text {
X setTextMode $can
X }
X erase {
X setEraseMode $can
X }
X default {
X feedback "Unsupported mode: $newMode"
X return
X }
X }
X set mode $newMode
X showMode $mode
X}
X
X# Generic drawing procedures
X
Xproc moveTo { can x y } {
X # Initailize position and segment sequence
X global Segments
X global X Y N
X set X(0) [$can canvasx $x]
X set Y(0) [$can canvasy $y]
X set N 0
X set Segments(0) {}
X}
X
Xproc drawTo { can x y {proc default} } {
X global drawProc
X global X Y N Segments
X global Move
X
X if {![info exists N] || $N < 0} {
X return
X }
X if {$proc == "default"} {
X set proc $drawProc
X }
X if {$Move(item) == "SEL"} {
X $can delete $Move(lastBox)
X }
X set x [$can canvasx $x]
X set y [$can canvasy $y]
X set item [$proc $can $x $y]
X set Segments($N) $item
X incr N
X set X($N) $x
X set Y($N) $y
X return $item
X}
X
Xset itemN 0
Xproc drawEnd { can x y {proc default} } {
X global endProc itemN N
X if {$proc == "default"} {
X set proc $endProc
X }
X set item [$proc $can $x $y]
X incr itemN
X set N -1
X return $item
X}
X
X# Erasing
X
Xproc eraseDraw { can x y } {
X global X Y N Segments itemN
X set items [$can find overlapping $X($N) $Y($N) $x $y]
X foreach item $items {
X global canBackground
X if {$item != $canBackground} {
X $can delete $item
X }
X }
X return {}
X}
X
Xproc eraseEnd { can x y } {
X drawTo $can $x $y eraseDraw
X return {}
X}
X
X# Stroke drawing
X
Xproc strokeDraw { can x y } {
X global X Y N
X return [$can create line $X($N) $Y($N) $x $y -tags {line}]
X}
X
Xproc strokeEnd { can x y } {
X global itemN
X drawTo $can $x $y
X # Replace straight-line segments with bezier curve
X global X Y N Segments
X set createCmd "$can create line"
X for {set i 0} {$i <= $N} {incr i} {
X lappend createCmd $X($i) $Y($i)
X if {$i != $N} {
X $can delete $Segments($i)
X }
X }
X lappend createCmd -joinstyle round -smooth 1 -tags stroke$itemN
X return [eval $createCmd]
X}
X
X# Straight-line drawing
X
Xproc lineDraw { can x y } {
X global X Y N Segments itemN
X if {$N > 0} {
X $can delete $Segments([expr $N-1])
X }
X return [$can create line $X(0) $Y(0) $x $y -tags line$itemN]
X}
X
Xproc lineEnd { can x y } {
X global itemN
X return [drawTo $can $x $y lineDraw]
X}
X
X# Box drawing
X
Xproc boxDraw { can x y } {
X global X Y N Segments itemN
X if {$N > 0} {
X $can delete $Segments([expr $N-1])
X }
X return [$can create rectangle $X(0) $Y(0) $x $y -tags box$itemN]
X}
X
Xproc boxEnd { can x y } {
X return [drawTo $can $x $y boxDraw]
X}
X
X# Oval drawing
X
Xproc ovalDraw { can x y } {
X global X Y N Segments itemN
X if {$N > 0} {
X $can delete $Segments([expr $N-1])
X }
X return [$can create oval $X(0) $Y(0) $x $y -tags oval$itemN]
X}
X
Xproc ovalEnd { can x y } {
X return [drawTo $can $x $y ovalDraw]
X}
X
X# Text drawing
X
Xproc textDraw { can x y } {
X global X Y N Segments itemN
X if {$N > 0} {
X $can delete $Segments([expr $N-1])
X }
X return [$can create rectangle $X(0) $Y(0) $x $y -tags textBox$itemN]
X}
X
Xset tnum 0
Xproc textEnd { can x y } {
X global Segments X Y N
X drawTo $can $x $y textDraw
X
X global tnum charWidth charHeight
X incr tnum
X text $can.text$tnum
X set width [expr {($X($N) > $X(0)) ? ($X($N) - $X(0)) : ($X(0) - $X($N))}]
X set height [expr {($Y($N) > $Y(0)) ? ($Y($N) - $Y(0)) : ($Y(0) - $Y($N))}]
X return [$can create window $X(0) $Y(0) -window $can.text$tnum \
X -width $width -height $height -anchor nw]
X}
X
X# Scrolling support for the canvas (direct speed)
X
Xproc canvasMark { can x y } {
X global canMarkX
X set canMarkX $x
X $can scan mark $x $y
X}
Xproc canvasDrag { can x y speed } {
X global canMarkX
X if {$speed == "slow"} {
X set x [expr $canMarkX+($x-$canMarkX)/10]
X }
X $can scan dragto $x $y
X}
X
X#
X# itemGrab selects an item for movement
X#
Xset Move(item) {}
Xproc itemGrab { can x y } {
X global Move canBackground
X case $Move(item) {
X default {
X # Normal case, click to select or initiate area select
X startGrab $can $x $y
X }
X SEL {
X if {(($Move(X0) < $Move(X1)) && \
X (($x < $Move(X0)) || ($x > $Move(X1)))) || \
X (($Move(X0) > $Move(X1)) && \
X (($x < $Move(X1)) || ($x > $Move(X0)))) || \
X (($Move(Y0) < $Move(Y1)) && \
X (($y < $Move(Y0)) || ($y > $Move(Y1)))) || \
X (($Move(Y0) > $Move(Y1)) && \
X (($y < $Move(Y1)) || ($y > $Move(Y0))))} {
X $can delete $Move(lastBox)
X startGrab $can $x $y
X } else {
X set Move(X) $x
X set Move(Y) $y
X }
X }
X }
X}
X
Xproc startGrab { can x y } {
X global Move canBackground
X set halo 5
X $can dtag SEL
X set item [$can find closest $x $y $halo]
X if {$item != {} && $item != $canBackground} {
X feedback "Selected item $item [$can gettags $item]"
X set Move(item) $item
X set Move(X) $x
X set Move(Y) $y
X } else {
X feedback "Selecting a region"
X set Move(X0) $x
X set Move(Y0) $y
X set Move(item) DRAG
X moveTo $can $x $y
X }
X}
X
Xproc itemMove { can x y } {
X global Move
X if {$Move(item) == {}} {
X return
X }
X if {$Move(item) == "DRAG"} {
X # Dragging out a selection
X drawTo $can $x $y boxDraw
X set Move(X1) $x
X set Move(Y1) $y
X } else {
X set dx [expr $x-$Move(X)]
X set dy [expr $y-$Move(Y)]
X $can move $Move(item) $dx $dy
X incr Move(X0) $dx
X incr Move(X1) $dx
X incr Move(Y0) $dy
X incr Move(Y1) $dy
X set Move(X) $x
X set Move(Y) $y
X }
X}
X
Xproc itemEndGrab { can x y } {
X global Move
X if {![info exists Move(item)] || $Move(item) != "DRAG"} {
X return
X }
X if {$x > $Move(X0)} {
X set Move(X1) $x
X } else {
X set Move(X1) $Move(X0)
X set Move(X0) $x
X }
X if {$y > $Move(Y0)} {
X set Move(Y1) $y
X } else {
X set Move(Y1) $Move(Y0)
X set Move(Y0) $y
X }
X set Move(items) [$can find enclosed $Move(X0) $Move(Y0) $Move(X1) $Move(Y1)]
X set Move(lastBox) [drawEnd $can $x $y boxEnd]
X if {$Move(items) == {}} {
X set Move(item) {}
X $can delete $Move(lastBox)
X feedback "Nothing in selection box"
X } else {
X $can itemconfigure $Move(lastBox) -tags SEL
X $can addtag SEL enclosed $Move(X0) $Move(Y0) $Move(X1) $Move(Y1)
X set Move(item) SEL
X feedback "Move items $Move(items)"
X }
X}
X
X# Debugging procs
X
Xproc MM { } {
X PA Move
X}
Xproc Segs { } {
X global N Segments
X for {set i 0} {$i < $N} {incr i} {
X puts stdout [format "%s %s" $i $Segments($i)]
X }
X}
Xproc PA { array } {
X global $array
X puts stdout $array
X foreach name [lsort [array names $array]] {
X set ref [format "%s(%s)" $array $name]
X set item [eval "set $ref"]
X puts stdout [format "%8s %s" $name $item]
X }
X}
X#
X# whatsThere displays tags for objects under a mouse click
X#
Xproc whatsThere { can x y halo } {
X set cx [$can canvasx $x]
X set cy [$can canvasy $y]
X
X set things [$can find overlapping [expr $cx-$halo] [expr $cy-$halo] \
X [expr $cx+$halo] [expr $cy+$halo]]
X
X set lasttag {}
X set answer "${things}:"
X foreach item $things {
X set tags [$can gettags $item]
X foreach tag $tags {
X if {$lasttag == $tag} {
X continue
X }
X if {($tag != "Scale") && ($tag != "current")} {
X append answer "$tag "
X }
X set lasttag $tag
X }
X }
X return $answer
X}
X#
X# delete things under a mouse click
X#
Xproc delete { can x y {halo 2} } {
X global canBackground
X
X set cx [$can canvasx $x]
X set cy [$can canvasy $y]
X
X set item [$can find closest $cx $cy $halo]
X
X if {($item != {}) && ($item != $canBackground)} {
X $can delete $item
X }
X}
X
X#
X# outline the canvas scroll region
X#
Xproc showScrollRegion { can } {
X global canWidth canHeight canBackground
X if [info exists canBackground] {
X $can delete $canBackground
X }
X set canBackground [$can create rectangle 0 0 $canWidth $canHeight \
X -fill white -outline {}]
X $can lower $canBackground
X}
X
Xproc showScrollRegionOld { can } {
X global canWidth canHeight canBackground
X set items [$can find withtag scrollBorder]
X foreach item $items {
X $can delete $item
X }
X set x1 3 ; set y1 3
X set x2 [expr $canWidth-3]
X set y2 [expr $canHeight-3]
X $can create line $x1 $y1 $x2 $y1 -stipple gray50 -tags {scrollBorder}
X $can create line $x2 $y1 $x2 $y2 -stipple gray50 -tags {scrollBorder}
X $can create line $x2 $y2 $x1 $y2 -stipple gray50 -tags {scrollBorder}
X $can create line $x1 $y2 $x1 $y1 -stipple gray50 -tags {scrollBorder}
X}
X
XcanvasBindings $can
XsetStrokeMode $can
X
XpackedButton .buttons .print "Print" "printDialog $can"
XpackedButton .buttons .size "Size" "sizeDialog $can"
X
XpackedButton .buttons .erase "Erase" "setMode $can erase" right
XpackedButton .buttons .stroke "Stroke" "setMode $can stroke" right
XpackedButton .buttons .line "Line" "setMode $can line" right
XpackedButton .buttons .box "Box" "setMode $can box" right
XpackedButton .buttons .oval "Oval" "setMode $can oval" right
XpackedButton .buttons .text "Text" "setMode $can text" right
X
XshowScrollRegion $can
X
END_OF_FILE
if test 12985 -ne `wc -c <'canvas_ui'`; then
echo shar: \"'canvas_ui'\" unpacked with wrong size!
fi
chmod +x 'canvas_ui'
# end of 'canvas_ui'
fi
if test -f 'size.tk' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'size.tk'\"
else
echo shar: Extracting \"'size.tk'\" \(1848 characters\)
sed "s/^X//" >'size.tk' <<'END_OF_FILE'
X#
X# size.tk - diaglog box for canvas sizing
X#
Xproc sizeDialog { can } {
X global backgroundColor
X if [catch {toplevel .sizeDialog}] {
X destroy .sizeDialog
X } else {
X wm minsize .sizeDialog 100 40
X frame .sizeDialog.info -background $backgroundColor
X pack append .sizeDialog .sizeDialog.info {top expand fill}
X label .sizeDialog.info.label -text "Choose a size for the drawing area"
X pack append .sizeDialog.info .sizeDialog.info.label {top expand fill}
X set bf [buttonFrame .sizeDialog .buttons]
X packedButton $bf .quit "Dismiss" {destroy .sizeDialog}
X packedButton $bf .full "FullScreen" "sizeCanvas $can fullscreen" right
X packedButton $bf .letter "8.5 x 11" "sizeCanvas $can letter" right
X packedButton $bf .other "Specified" "sizeCanvas $can" right
X frame .sizeDialog.fields -background $backgroundColor
X pack append .sizeDialog .sizeDialog.fields {top expand fill}
X labeledEntryWithDefault .sizeDialog.fields .x "X Pixels: " 10 400 {left expand fill}
X labeledEntryWithDefault .sizeDialog.fields .y "Y Pixels: " 10 400 {left expand fill}
X }
X}
X
Xproc sizeCanvas { can {size fromfields} } {
X case $size {
X fullscreen {
X set extraX [expr [winfo width .]-[winfo width $can]]
X set extraY [expr [winfo height .]-[winfo height $can]]
X set x [expr [winfo screenwidth .]-$extraX]
X set y [expr [winfo screenheight .]-$extraY]
X }
X letter {
X set x 8.5i
X set y 11i
X }
X fromfields {
X set x [.sizeDialog.fields.x.entry get]
X set y [.sizeDialog.fields.y.entry get]
X }
X default {
X feedback "Bad size argument to sizeCanvas: $size"
X return
X }
X }
X if [catch {$can configure -scrollregion "0 0 $x $y"} msg] {
X feedback "Could not set size: $msg"
X } else {
X feedback "Scroll region set to $x by $y"
X global canWidth canHeight
X set canWidth $x
X set canHeight $y
X showScrollRegion $can
X }
X return
X}
END_OF_FILE
if test 1848 -ne `wc -c <'size.tk'`; then
echo shar: \"'size.tk'\" unpacked with wrong size!
fi
# end of 'size.tk'
fi
if test -f 'printer.tk' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'printer.tk'\"
else
echo shar: Extracting \"'printer.tk'\" \(1346 characters\)
sed "s/^X//" >'printer.tk' <<'END_OF_FILE'
X#
X# printer.tk - diaglog box for canvas printing
X#
Xproc printDialog { can } {
X global backgroundColor
X if [catch {toplevel .printDialog}] {
X destroy .printDialog
X } else {
X wm minsize .printDialog 100 40
X set bf [buttonFrame .printDialog .buttons]
X packedButton $bf .quit "Dismiss" {destroy .printDialog}
X packedButton $bf .print "Print" "printCanvas $can" right
X packedButton $bf .file "Postscript File" "fileCanvas $can" right
X frame .printDialog.fields -background $backgroundColor
X pack append .printDialog .printDialog.fields {top expand fill}
X labeledEntryWithDefault .printDialog.fields .printer "Printer: " 10 Snoball {left expand fill}
X labeledEntryWithDefault .printDialog.fields .file "File: " 10 /tmp/canvas.ps {left expand fill}
X }
X}
X
Xset tempFileN 0
Xproc printCanvas { can } {
X global tempFileN
X set printer [.printDialog.fields.printer.entry get]
X if {$printer == {}} {
X feedback "Please specify a printer"
X return
X }
X while {[file exists /tmp/canvasPrint.$tempFileN.ps]} {
X incr tempFileN
X }
X set file /tmp/canvasPrint.$tempFileN.ps
X $can postscript -file $file
X lpr -P$printer $file
X exec rm $file
X}
X
Xproc fileCanvas { can } {
X set file [.printDialog.fields.file.entry get]
X if {$file == {}} {
X feedback "Please specify a filename"
X return
X }
X $can postscript -file $file
X}
END_OF_FILE
if test 1346 -ne `wc -c <'printer.tk'`; then
echo shar: \"'printer.tk'\" unpacked with wrong size!
fi
# end of 'printer.tk'
fi
if test -f 'alphaBrowser.tk' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'alphaBrowser.tk'\"
else
echo shar: Extracting \"'alphaBrowser.tk'\" \(4189 characters\)
sed "s/^X//" >'alphaBrowser.tk' <<'END_OF_FILE'
X#
X# browser.tk
X# A framework for a browser with buttons, fields, and a feedback line.
X#
X
Xproc alphaBrowser { self } {
X global backgroundColor paleBackground entryFont
X
X if [string match root [exec whoami]] {
X wm title . "ROOT $self"
X } else {
X wm title . "$self"
X }
X
X if ![info exists backgroundColor] {
X setColorCube
X }
X
X set uniqID 0
X #
X # Top-level layout
X #
X frame .buttons -borderwidth 10 -background $backgroundColor
X
X frame .fields -borderwidth 6 -background $backgroundColor
X
X frame .feedback -borderwidth 6 -background $backgroundColor
X
X pack append . .buttons {top fillx}
X pack after .buttons .fields {top fillx}
X pack after .fields .feedback {top fillx}
X
X packedButton .buttons .quit "Quit" {destroy .} left red
X
X #
X # Feedback line and msg proc
X #
X entry .feedback.entry -background $paleBackground -font $entryFont \
X -relief raised
X proc msg { text } {
X .feedback.entry delete 0 end
X .feedback.entry insert 0 $text
X update
X }
X global _feedbackWidget
X set _feedbackWidget .feedback.entry
X pack append .feedback .feedback.entry {left fill expand}
X
X #
X # NEWS button and message
X #
X packedButton .buttons .news "News/Help" "news $self" left
X proc news { self } {
X global LIB
X notifier .news "News and Help about $self" [simpleNewsHelper $self]
X }
X
X msg "Welcome to $self "
X}
X
Xset EDITOR "/project/tcl/bin/mx"
X
X# Assumption about script = self.tk is a bit bogus
Xproc alphaBrowserSetup { self dir } {
X global SHELL LIB BUTTONS FIELDS backgroundColor paleBackground
X
X if [string match root [exec whoami]] {
X wm title . "ROOT $self"
X } else {
X wm title . "$self"
X }
X
X set uniqID 0
X #
X # SHELL is a directory containing supporting shell scripts
X # LIB is a directory containing supporting text files
X # BUTTONS is a directory containing button definitions
X # FIELDS is a directory containing field definitions
X #
X set SHELL $dir/shell
X set LIB $dir/lib
X set BUTTONS $dir/buttons
X set FIELDS $dir/fields
X
X #
X # Top-level layout
X #
X frame .basics -borderwidth 10 -background $backgroundColor
X
X frame .buttons -borderwidth 10 -background $backgroundColor
X
X frame .fields -borderwidth 10 -background $backgroundColor
X
X frame .feedback -borderwidth 6 -background $backgroundColor
X
X pack append . .basics {top fillx}
X pack after .basics .buttons {top fillx}
X pack after .buttons .fields {top fillx}
X pack after .fields .feedback {top fillx}
X
X packedButton .basics .quit "Quit" {destroy .} left
X
X #
X # Feedback line and msg proc
X #
X entry .feedback.entry -background $paleBackground
X proc msg { text } {
X .feedback.entry delete 0 end
X .feedback.entry insert 0 $text
X }
X pack append .feedback .feedback.entry {left fillx expand}
X
X #
X # NEWS button and message
X #
X packedButton .basics .news "News/Help" "news $self" left
X proc news { self } {
X global LIB
X notifier .news "News and Help about $self" [exec cat $LIB/news.txt]
X }
X #
X # Edit button
X #
X # packedButton .basics .edit "Edit" "alphaBrowserEdit $self" left
X
X #
X # Reset button
X #
X packedButton .basics .reset "Reset" \
X { alphaBrowserReset $HOME } left
X
X msg [concat "Welcome to $self " [wm geometry .]]
X}
X
Xproc alphaBrowserEdit { self } {
X global EDITOR HOME
X exec $EDITOR $HOME/$self.tk
X}
X
X#
X# The rest of the alpha browser is defined by things in buttonDir and fieldDir
X#
Xset fieldList ""
Xset buttonList ""
X
Xproc alphaBrowserReset { homeDir } {
X global fieldList buttonList
X
X foreach b $buttonList {
X destroy $b
X }
X foreach f $fieldList {
X destroy $f
X }
X set fieldList ""
X set buttonList ""
X
X foreach b [exec ls $homeDir/buttons] {
X if [string match Mx* $b] {
X continue
X }
X if [string match \.* $b] {
X continue
X }
X set buttonList [concat $buttonList [source $homeDir/buttons/$b]]
X }
X foreach f [exec ls $homeDir/fields] {
X if [string match Mx* $f] {
X continue
X }
X if [string match \.* $b] {
X continue
X }
X set fieldList [concat $fieldList [source $homeDir/fields/$f]]
X }
X}
X
END_OF_FILE
if test 4189 -ne `wc -c <'alphaBrowser.tk'`; then
echo shar: \"'alphaBrowser.tk'\" unpacked with wrong size!
fi
# end of 'alphaBrowser.tk'
fi
if test -f 'utils.tk' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'utils.tk'\"
else
echo shar: Extracting \"'utils.tk'\" \(19165 characters\)
sed "s/^X//" >'utils.tk' <<'END_OF_FILE'
X#
X# utils.tk
X# Utilities for tk2.3
X# These are convenience procedures that ease construction of
X# buttons, listboxes, etc. They define all the colors of the
X# widgets based on a set of complementary colors that can
X# be defined externally. (See also colors.tk.)
X#
X# Buttons
X# buttonFrame
X# simpleButton
X# packedButton
X# framedButton
X# packedCheckButton
X# packedRadioButton
X# Menu
X# basicMenu
X# packedMenuButton
X# menuAndButton
X# framedMenuButton
X# menuAndFButton
X# Scrollbar
X# basicScrollbar
X# Listbox
X# labeledListbox
X# unixCommandListbox
X# Entry
X# labeledEntry
X# commandEntry
X# labeledEntryWithDefault
X# Feedback
X# feedbackSetup
X# feedback
X# Toplevel
X# notifier
X# Message
X# unixCommandMessageButton
X# unixCommandMessage
X#
X
X#
X# to_tx - insert characters into the tx command stream. This is used to
X# feed commands to the csh running in the tx that started this program.
X#
Xproc to_tx {str} {
X puts stdout "\33insert \"$str\\n\"\n"
X}
X
X#
X# selfName - determine the name of a nested widget
X# parent is either "." or ".foo.bar"
X# name is ".zork"
X#
Xproc selfName { parent name } {
X if {[string compare $parent "."] == 0} {
X set self $name
X } else {
X set self $parent$name
X }
X return $self
X}
X
Xproc utilsInit { } {
X global buttonFont labelFont menuFont entryFont
X # Default font for buttons, labels, menus
X set buttonFont fixed
X set labelFont fixed
X set menuFont fixed
X set entryFont fixed
X
X #
X # Default colors.
X # See also colors.tk for a better setColorCube
X #
X global backgroundColor paleBackground foregroundColor
X global passiveColor activeColor
X set backgroundColor #cb02dd
X set paleBackground #ffceff
X set foregroundColor black
X set passiveColor #eeadf3
X set activeColor #f154ff
X
X}
X#
X# buttonFrame creates a frame that is designed to hold a row of buttons
X#
Xproc buttonFrame { parent {name .buttons} {border 2} } {
X global backgroundColor
X if ![info exists backgroundColor] {
X utilsInit
X }
X set self [selfName $parent $name]
X set color [format #%02x%02x%02x 240 128 0]
X frame $self -borderwidth $border -background $backgroundColor \
X -relief raised
X pack append $parent $self {top fillx}
X return $self
X}
X#
X# packedButton adds a button to a row of buttons
X#
Xproc packedButton { parent name label command {position left} {color default} } {
X global foregroundColor activeColor passiveColor
X global buttonFont
X global FontWidgets ;# Remember widgets with a font
X
X if ![info exists buttonFont] {
X utilsInit
X }
X set savedColor [getColorCube]
X if {[string compare $color "default"] != 0} {
X setColorCube $color
X }
X set self [selfName $parent $name]
X button $self -text $label -command $command \
X -font $buttonFont \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -activeforeground $passiveColor
X lappend FontWidgets $self
X pack append $parent $self $position
X setColorCube $savedColor
X return $self
X}
X#
X# framedButton - like packedButton but with more space around it
X#
Xproc framedButton {parent name label command {position left} {color default} } {
X global foregroundColor activeColor passiveColor backgroundColor
X global buttonFont FontWidgets
X
X set padwidth 4 ;# Framing width. Could be a parameter
X
X set self [selfName $parent $name]
X
X if ![info exists buttonFont] {
X utilsInit ;# Define colors and fonts for utils.tk procs
X }
X
X # Keep frame in the default background color
X frame $self -borderwidth $padwidth -background $backgroundColor
X
X # "Color cubes" are sets of colors that go together.
X # setColorCube sets the current set of colors.
X # Here we can change the color scheme of the button
X set savedColor [getColorCube]
X if {[string compare $color "default"] != 0} {
X setColorCube $color
X }
X
X button $self.b -text $label -command $command \
X -font $buttonFont \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -activeforeground $passiveColor
X lappend FontWidgets $self.b ;# Supports mxedit font changes
X pack append $parent $self $position
X pack append $self $self.b { fill }
X setColorCube $savedColor
X return $self.b
X}
X
X#
X# simpleButton makes some simplifying assumptions - similar to packedButton
X#
Xproc simpleButton { label command {position left} {color default} } {
X global foregroundColor activeColor passiveColor
X global FontWidgets ;# Remember widgets with a font
X global buttonFont
X
X if ![info exists foregroundColor] {
X utilsInit
X }
X set savedColor [getColorCube]
X if {[string compare $color "default"] != 0} {
X setColorCube $color
X }
X set self [selfName $parent $name]
X button $self -text $label -font $buttonFont -command $command \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor
X lappend FontWidgets $self
X pack append $parent $self $position
X setColorCube $savedColor
X return $self
X}
X#
X# packedCheckButton
X#
Xproc packedCheckButton { parent name label command { variable selectedButton } {position left} } {
X global passiveColor foregroundColor activeColor
X global buttonFont FontWidgets
X
X if ![info exists foregroundColor] {
X utilsInit
X }
X set self [selfName $parent $name]
X checkbutton $self -text $label -font $buttonFont -command $command \
X -variable $variable \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -selector $activeColor
X lappend FontWidgets $self
X pack append $parent $self $position
X return $self
X
X}
X
X#
X# packedRadioButton
X#
Xproc packedRadioButton { parent name label command { variable selectedButton } {position left} } {
X global passiveColor foregroundColor activeColor
X global buttonFont FontWidgets
X
X if ![info exists foregroundColor] {
X utilsInit
X }
X set self [selfName $parent $name]
X radiobutton $self -text $label -font $buttonFont -command $command \
X -variable $variable \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -selector $activeColor
X lappend FontWidgets $self
X pack append $parent $self $position
X return $self
X
X}
X
X#
X# Basic Menu
X#
Xproc basicMenu { name } {
X global foregroundColor
X global activeColor
X global backgroundColor
X global paleBackground
X global passiveColor
X
X global menuFont FontWidgets
X
X if ![info exists menuFont] {
X utilsInit
X }
X set self [menu $name -font $menuFont \
X -selector $activeColor \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activeforeground $paleBackground \
X -activebackground $activeColor]
X lappend FontWidgets $self
X
X return $self
X}
X#
X# packedMenuButton adds a menubutton to a row of buttons
X#
Xproc packedMenuButton { parent name label menu {position left} {color default} } {
X global foregroundColor activeColor passiveColor paleBackground
X global menuFont FontWidgets
X
X if ![info exists menuFont] {
X utilsInit
X }
X set savedColor [getColorCube]
X if {[string compare $color "default"] != 0} {
X setColorCube $color
X }
X set self [selfName $parent $name]
X menubutton $self -text $label -menu $menu \
X -relief raised \
X -font $menuFont \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -activeforeground $paleBackground
X lappend FontWidgets $self
X pack append $parent $self $position
X setColorCube $savedColor
X return $self
X}
X# menuAndButton
X
Xproc menuAndButton { menubar name label {where {left}} } {
X set menuPathName $menubar${name}.menu
X packedMenuButton $menubar ${name} $label $menuPathName $where
X set menu [basicMenu $menuPathName]
X return $menu
X}
X
X# framedMenuButton
X
Xproc framedMenuButton {parent name label menu {position left} {color default} } {
X global foregroundColor activeColor passiveColor backgroundColor
X global buttonFont FontWidgets
X
X set padwidth 4 ;# Framing width. Could be a parameter
X
X set self [selfName $parent $name]
X
X if ![info exists buttonFont] {
X utilsInit ;# Define colors and fonts for utils.tk procs
X }
X
X # Keep frame in the default background color
X frame $self -borderwidth $padwidth -background $backgroundColor
X
X # "Color cubes" are sets of colors that go together.
X # setColorCube sets the current set of colors.
X # Here we can change the color scheme of the button
X set savedColor [getColorCube]
X if {[string compare $color "default"] != 0} {
X setColorCube $color
X }
X
X menubutton $self.b -text $label -menu $menu \
X -relief raised \
X -font $buttonFont \
X -background $passiveColor \
X -foreground $foregroundColor \
X -activebackground $activeColor \
X -activeforeground $passiveColor
X lappend FontWidgets $self.b ;# Supports mxedit font changes
X pack append $parent $self $position
X pack append $self $self.b { fill }
X setColorCube $savedColor
X return $self.b
X}
X
X# menuAndFButton (framed button)
X#
Xproc menuAndFButton { menubar name label {where {left}} } {
X set menuPathName $menubar${name}.b.menu
X framedMenuButton $menubar ${name} $label $menuPathName $where
X set menu [basicMenu $menuPathName]
X return $menu
X}
X
X#
X# basicScrollbar
X#
Xproc basicScrollbar { parent command
X {where {left filly frame w}}
X {name .scroll} } {
X global passiveColor activeColor paleBackground backgroundColor
X if ![info exists backgroundColor] {
X utilsInit
X }
X set self [scrollbar $parent$name -command "$command" \
X -relief raised \
X -background $backgroundColor \
X -foreground $passiveColor \
X -activeforeground $activeColor]
X pack append $parent $self $where
X}
X#
X# labeledListbox creates a listbox that has a label above it
X#
Xproc labeledListbox { parent name
X {text "Label"} {geometry 10x5} {position left} } {
X global passiveColor activeColor paleBackground
X global labelFont FontWidgets
X if ![info exists labelFont] {
X utilsInit
X }
X set self [selfName $parent $name]
X frame $self -background $passiveColor
X label $self.label -text $text -font $labelFont -background $passiveColor
X lappend FontWidgets $self.label $self.list
X scrollbar $self.scroll -command "$self.list yview" -background $paleBackground -foreground $passiveColor -activeforeground $activeColor
X listbox $self.list -geometry $geometry -yscroll "$self.scroll set" -background $paleBackground -selectbackground $activeColor -font $labelFont
X pack append $parent $self "$position"
X pack append $self $self.label {top} $self.scroll {right filly} $self.list {left expand fill}
X return $self
X}
X#
X# labeledListbox2 creates a listbox that has a label above it and 2 scrollbars
X#
Xproc labeledListbox2 { parent name
X {text "Label"} {geometry 10x5} {position left} } {
X global passiveColor activeColor paleBackground
X global labelFont FontWidgets
X if ![info exists labelFont] {
X utilsInit
X }
X set self [selfName $parent $name]
X frame $self -background $passiveColor
X label $self.label -text $text -font $labelFont -background $passiveColor
X lappend FontWidgets $self.label $self.list
X scrollbar $self.yscroll -command "$self.list yview" -orient vertical \
X -background $paleBackground -foreground $passiveColor \
X -activeforeground $activeColor
X scrollbar $self.xscroll -command "$self.list xview" -orient horizontal \
X -background $paleBackground -foreground $passiveColor \
X -activeforeground $activeColor
X listbox $self.list -geometry $geometry -yscroll "$self.yscroll set" \
X -xscroll "$self.xscroll set" -font $labelFont \
X -background $paleBackground -selectbackground $activeColor
X pack append $parent $self $position
X pack append $self $self.label {top} $self.yscroll {right filly} $self.xscroll {bottom fillx} $self.list {left expand fill}
X return $self
X}
X#
X# labeledEntry creates an entry that has a label to its left
X#
Xproc labeledEntry { parent name {label "Entry:"} {width 20} {where {left} }} {
X global foregroundColor backgroundColor paleBackground
X global passiveColor activeColor
X global labelFont entryFont FontWidgets
X if ![info exists backgroundColor] {
X utilsInit
X }
X set self [selfName $parent $name]
X # Geometry and Packing
X frame $self -borderwidth 2 -background $backgroundColor -relief raised
X label $self.label -text $label -background $paleBackground \
X -relief flat -font $labelFont -borderwidth 0
X entry $self.entry -width $width -font $entryFont \
X -relief flat -borderwidth 0 \
X -background $paleBackground \
X -foreground $foregroundColor \
X -selectforeground $passiveColor \
X -selectbackground $activeColor
X lappend FontWidgets $self.label $self.entry
X pack append $parent $self $where
X pack append $self $self.label {left} \
X $self.entry {right fillx expand}
X
X $self.entry icursor 0
X
X return $self
X}
X
X# commandEntry --
X# An entry widget for entering commands
Xproc commandEntry { parent { width 20 } { where {bottom fillx expand} } } {
X set self [labeledEntry $parent .command "Command:" $width $where]
X bind $self.entry <Return> "eval \[$self.entry get\]"
X return $self
X}
X
X#
X# Entry with default value remembered in /tmp/file
X#
Xproc defaultGeneric { parent name default } {
X if [file exists /tmp/$parent/$name] {
X return [exec cat /tmp/$parent/$name]
X } else {
X if {! [file isdirectory /tmp/$parent]} {
X exec mkdir /tmp/$parent
X }
X }
X exec echo $default > /tmp/$parent/$name
X return [exec cat /tmp/$parent/$name]
X
X}
Xproc labeledEntryWithDefault { parent name label width default {where {bottom} } } {
X set widget [labeledEntry $parent $name $label $width $where]
X proc default$name { } "return \[defaultGeneric $parent $name \{$default\}\]"
X proc get$name { } "return \[lindex \[$widget.entry get\] 0\]"
X $widget.entry insert 0 [default$name]
X bind $widget.entry <Return> "
X set fileID \[open /tmp/$parent/$name w\]
X puts \$fileID \[get$name\]
X close \$fileID
X# puts stdout \$parent: Remembering $name \[get$name\]\"
X "
X return $widget
X}
X
X
X#
X# feedback
X# Create a frame to hold messages, and define a procedure to display them.
X# The feedback procedure will be named
X# feedback$parent (e.g., feedback.foo)
X#
X
Xproc feedbackSetup { parent name {width 58} {border 6} } {
X global backgroundColor paleBackground
X global entryFont FontWidgets
X global _feedbackWidget
X if ![info exists backgroundColor] {
X utilsInit
X }
X set self [selfName $parent $name]
X
X frame $self -borderwidth 2 -background $backgroundColor -relief raised
X
X entry $self.entry -width $width -background $paleBackground -font $entryFont
X lappend FontWidgets $self.entry
X pack append $self $self.entry {left fillx expand}
X pack append $parent $self {left fillx expand}
X
X # Define a per-call procedure to allow for multiple feedback widgets
X proc feedback$parent { text } "
X $self.entry delete 0 end ;
X $self.entry insert 0 \$text ;
X "
X
X # Save the name of the feedback entry for simple clients
X set _feedbackWidget $self.entry
X
X return $self
X}
Xproc feedback { text } {
X global _feedbackWidget
X if ![info exists _feedbackWidget] {
X puts stderr $text
X } else {
X $_feedbackWidget delete 0 end
X $_feedbackWidget insert 0 $text
X }
X}
X
X#
X# notifier
X#
Xproc notifier {name title text {font _default_font_ } } {
X global paleBackground $name backgroundColor
X global entryFont FontWidgets
X
X if {$font == "_default_font_"} {
X set font $entryFont
X }
X
X if {[info exists $name] && [expr {[string compare [set $name] 1] == 0}] } {
X destroy $name
X set $name 0
X return ""
X } else {
X
X toplevel $name
X set $name 1
X if ![info exists backgroundColor] {
X utilsInit
X }
X
X wm title $name $title
X
X buttonFrame $name
X
X packedButton $name.buttons .quit "Dismiss" "destroy $name ; global $name ; set $name 0" left
X
X message $name.msg -aspect 300 -text $text -background $paleBackground -font $entryFont
X lappend FontWidgets $name.msg
X pack append $name $name.msg {top expand}
X return $name
X }
X}
X
X#
X# unixCommandMessageButton -
X# A button that runs a UNIX command and puts it output in a message widget
X#
Xproc unixCommandMessageButton { parent name label title args} {
X set self [selfName $parent $name]
X set cmd "unixCommandMessage $name \"$title\" "
X foreach a $args {
X set cmd [concat $cmd $a]
X }
X packedButton $parent $name $label $cmd
X return $self
X}
X#
X# unixCommandMessage -
X# Exec a UNIX command and put the output in a message widget
X#
Xproc unixCommandMessage {name title args} {
X toplevel $name
X
X wm title $name $title
X
X frame $name.buttons -borderwidth 10 -background \
X [format "#%02x%02x%02x" 128 128 200]
X pack append $name $name.buttons {top fillx}
X
X packedButton $name.buttons .quit "Quit" "destroy $name" left
X
X message $name.msg -aspect 300 -font fixed -text [eval exec $args]
X pack append $name $name.msg {top expand}
X return $name
X}
X#
X# unixCommandListbox -
X# Exec a UNIX command and put the output in a labeledListbox
X#
Xproc unixCommandListbox {name title label args} {
X toplevel $name
X
X wm title $name $title
X
X buttonFrame $name
X
X packedButton $name.buttons .quit "Quit" "destroy $name" left
X
X labeledListbox $name .dir $label 20x15 left
X foreach i [eval exec $args] {
X $name.dir.list insert end $i
X }
X return $name
X}
X
X#####################################################################
X# These are additions to the entry widget bindings that rightfully
X# belong in tk.tcl, but I don't want folks to have to modify that.
X# These add mxedit-like bindings to entry widgets.
X
X# The procedure below is invoked to delete the character to the right
X# of the cursor in an entry widget.
X
Xproc tk_entryDelRight w {
X set x [$w index insert]
X if {$x != -1} {$w delete $x}
X}
X
X# proc to move the cursor in an entry back one character
X
Xproc tk_entryBack1char w {
X set x [$w index insert]
X $w icursor [incr x -1]
X}
X
X# proc to move the cursor in an entry forward one character
X
Xproc tk_entryForw1char w {
X set x [$w index insert]
X $w icursor [incr x +1]
X}
X
X# proc to move the cursor in an entry to the end of the line
X
Xproc tk_entryEndOfLine w {
X $w icursor end
X}
X
X# The procedure below is invoked to backspace over one character
X# in an entry widget. The name of the widget is passed as argument.
X
Xproc tk_entryBackspace w {
X set x [expr {[$w index insert] - 1}]
X if {$x != -1} {$w delete $x}
X}
X
X# The procedure below is invoked to backspace over one word in an
X# entry widget. The name of the widget is passed as argument.
X
Xproc tk_entryBackword w {
X set string [$w get]
X set curs [expr [$w index insert]-1]
X if {$curs < 0} return
X for {set x $curs} {$x > 0} {incr x -1} {
X if {([string first [string index $string $x] " \t"] < 0)
X && ([string first [string index $string [expr $x-1]] " \t"]
X >= 0)} {
X# puts stdout "x is $x, string is \"$string\""
X break
X }
X }
X $w delete $x $curs
X}
X
X
X#
X# traceprint
X#
Xproc traceprint { name op oldValue newValue } {
X puts stdout [concat $name " " $op " " $oldValue " " $newValue "\n"]
X return $newValue
X}
END_OF_FILE
if test 19165 -ne `wc -c <'utils.tk'`; then
echo shar: \"'utils.tk'\" unpacked with wrong size!
fi
# end of 'utils.tk'
fi
if test -f 'colors.tk' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'colors.tk'\"
else
echo shar: Extracting \"'colors.tk'\" \(6445 characters\)
sed "s/^X//" >'colors.tk' <<'END_OF_FILE'
X#
X# colors.tk --
X# setColorCube is used to pick a set of 4 complementary colors
X#
X
X# random, unused colors
X#set chocolate #ae7359
X#set maroon #b03060
X#set lightblue2 #b2dfee
X#set lightpink1 #ffaeb9
X
X
X# Default color values
X# A suite of 4 (possibly 5) colors is defined together:
X# backgroundColor: Used for frame backgrounds, darkish
X# paleBackground: Used for label, entry, message, scroll_bg
X# passiveColor: listbox_bg, scroll_fg, buttons
X# activeColor: buttons, scroll_sel, listbox_select
X
Xproc colorsInit { } {
X global currentCube
X global screenDepth
X
X set currentCube blue
X set screenDepth unknown
X}
X
Xproc setTestCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #ffcbcb ;# Light Red
X set paleBackground #ffecec ;# Lightest Red
X set foregroundColor black
X set passiveColor #ffa0a0 ;# Mellow Red
X set activeColor #cd6368 ;# Bright Red
X}
X
Xproc setLBlueCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #d6e9ff ;# Light Blue
X set paleBackground #e8f3ff ;# Lightest Blue
X set foregroundColor black
X set passiveColor #badeff ;# Mellow Blue
X set activeColor #71b4ff ;# Bright Blue
X}
X
Xproc setLBlue2Cube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #c9d3ff ;# Light Blue
X set paleBackground #e8edff ;# Lightest Blue
X set foregroundColor black
X set passiveColor #acbbff ;# Mellow Blue
X set activeColor #718bff ;# Bright Blue
X}
X
Xproc setBlueCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor [format "#%02x%02x%02x" 128 128 200]
X set paleBackground #e4f4fe
X set foregroundColor black
X set passiveColor #acd6f1
X set activeColor #61acde
X}
X
Xproc setRedCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #ffcbcb ;# Light Red
X set paleBackground #ffecec ;# Lightest Red
X set foregroundColor black
X set passiveColor #ffa0a0 ;# Mellow Red
X set activeColor #cd6368 ;# Bright Red
X}
X
Xproc setRed2Cube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #cd8e91
X set paleBackground #fddede
X set foregroundColor black
X set passiveColor #ffb5b9
X set activeColor #cd6368
X}
X
Xproc setGreenCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #b9e9db ;# Light Green
X set paleBackground #eafffa ;# Lightest Green
X set foregroundColor black
X set passiveColor #99d1c0 ;# Mellow Green
X set activeColor #00af5f ;# Bright Green
X}
X
Xproc setGreen2Cube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #32cd83
X set paleBackground #d9ffe6
X set foregroundColor black
X set passiveColor #b2f6ab
X set activeColor #13cd00
X}
X
Xproc setPurpleCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #cb02dd
X set paleBackground #ffceff
X set foregroundColor black
X set passiveColor #eeadf3
X set activeColor #f154ff
X}
X
Xproc setBisqueCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X # These are the TK defaults from default.h
X set bisque1 #ffe4c4
X set bisque2 #eed5b7
X set bisque3 #cdb79e
X
X set backgroundColor $bisque3
X set paleBackground $bisque1
X set foregroundColor black
X set activeColor $bisque2
X set passiveColor $bisque1
X}
X
Xproc setBrownCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X # These are the TK defaults from default.h
X set bisque1 #ffe4c4
X set bisque2 #eed5b7
X set bisque3 #cdb79e
X set chocolate #ae7359
X
X set backgroundColor $chocolate
X set paleBackground $bisque1
X set foregroundColor black
X set activeColor $bisque3
X set passiveColor $bisque2
X}
X
Xproc setGrayCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X set backgroundColor #dddddd ;# Lightish Grey
X set paleBackground #f0f0f0 ;# Light Grey
X set foregroundColor black
X set passiveColor #c5c5c5 ;# Grey
X set activeColor #ababab ;# Darker Grey
X}
X
X
X# For 4-bits of grey - a la Tadpole screen. Cannot get X server to work yet.
Xproc setGray4Cube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X global currentCube
X
X set backgroundColor [format "#%02x%02x%02x" 128 128 200]
X set paleBackground #e4f4fe
X set foregroundColor black
X set passiveColor #acd6f1
X set activeColor #61acde
X
X set currentCube Gray4
X}
X
X#
Xproc setBWCube { } {
X global backgroundColor paleBackground foregroundColor passiveColor activeColor
X global currentCube
X
X set backgroundColor white
X set paleBackground white
X set foregroundColor black
X set passiveColor white
X set activeColor black
X
X set currentCube BW
X}
X
Xproc setColorCube { { cube "lblue" } } {
X global backgroundColor paleBackground foregroundColor \
X passiveColor activeColor currentCube
X
X case [screendepth] in {
X 8 {
X case $cube in {
X {$currentCube} { }
X {default "blue"} { setBlueCube }
X "lblue" { setLBlueCube }
X "red" { setRedCube }
X "red2" { setRed2Cube }
X "green" { setGreenCube }
X "green2" { setGreen2Cube }
X "purple" { setPurpleCube }
X "bisque" { setBisqueCube }
X "brown" { setBrownCube }
X {grey gray} {setGrayCube}
X "test" {setTestCube}
X }
X }
X 4 {
X setGray4Cube
X }
X 1 {
X setBWCube
X }
X default {
X puts stderr "setColorCube unknown screendepth [screendepth]"
X setBWCube
X }
X }
X set currentCube $cube
X return $currentCube
X}
X
Xproc getColorCube { } {
X global currentCube
X if ![info exists currentCube] {
X colorsInit
X }
X return $currentCube
X}
X
Xproc screendepth {} {
X global screenDepth
X if ![info exists screenDepth] {
X set screenDepth unknown
X }
X if {$screenDepth == "unknown"} {
X if [catch {winfo screendepth .} screenDepth] {
X set _d [exec xwininfo -root | egrep Depth:]
X set screenDepth [lindex $_d [expr [llength $_d]-1]]
X }
X }
X return $screenDepth
X}
X
XsetColorCube
END_OF_FILE
if test 6445 -ne `wc -c <'colors.tk'`; then
echo shar: \"'colors.tk'\" unpacked with wrong size!
fi
# end of 'colors.tk'
fi
echo shar: End of shell archive.
exit 0
--
----------------------------------
Brent Welch Xerox-PARC