#!/usr/bin/env wish
proc tracker {w args} {
global tracker_struct
# set default options
set tracker_struct($w:-width) 500
set tracker_struct($w:-height) 300
set tracker_struct($w:-rows) 16
set tracker_struct($w:-cols) 6
set tracker_struct($w:-spacing) 3
# parse options
set valid_opts {-width -height -rows -cols}
foreach {opt val} $args {
if {[lsearch -exact $valid_opts $opt] == -1} {
return -code error -errorinfo \
"tracker($w): unknown option: $opt"
} else {
set tracker_struct($w:$opt) $val
}
}
set c [canvas $w \
-width $tracker_struct($w:-width) \
-height $tracker_struct($w:-height) \
-takefocus 1]
rename $c ${w}_canvas
set tracker_struct($w:canvas) ${w}_canvas
set tracker_struct($w:window) $w
set tracker_struct($w:font) [font create -family Courier -size 10 -weight bold \
-slant roman -underline false -overstrike false]
set tracker_struct($w:font:-ascent) [font metrics $tracker_struct($w:font) -ascent]
set tracker_struct($w:font:-descent) [font metrics $tracker_struct($w:font) -descent]
set tracker_struct($w:font:-linespace) [font metrics $tracker_struct($w:font) -linespace]
set tracker_struct($w:font:-width) [font measure $tracker_struct($w:font) m]
set tracker_struct($w:-charwidth) $tracker_struct($w:font:-width)
set tracker_struct($w:-charheight) $tracker_struct($w:font:-linespace)
set tracker_struct($w:cursor:x) 0
set tracker_struct($w:cursor:y) 0
# setup callback proc
proc $w args "return \[eval tracker_callback $w \$args\]"
if [tracker_init $w] {
return $c
} else {
return -code error -errorinfo \
"tracker($w): init failed"
}
}
proc tracker_callback {w command {args {}}} {
global tracker_struct
if {[llength [info procs tracker_$command]] > 0} {
return [eval tracker_$command $w $args]
} else {
return -code error -errorinfo \
"tracker($w): no such command: $command"
}
}
proc tracker_init {w} {
global tracker_struct
for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} {
for {set x 0} {$x < $tracker_struct($w:-cols)} {incr x} {
set rw $tracker_struct($w:-charwidth)
set rh $tracker_struct($w:-charheight)
set rx [expr 1+$x*($rw+$tracker_struct($w:-spacing))]
set ry [expr 1+$y*($rh+$tracker_struct($w:-spacing))]
$tracker_struct($w:canvas) create rectangle \
$rx $ry [expr $rx+$rw] [expr $ry+$rh] \
-fill {} -outline black \
-tags [list bg xy$x$y]
}
}
bind $tracker_struct($w:window) <KeyPress> "tracker_keypress $w %K"
bind $tracker_struct($w:window) <ButtonPress-1> "focus $w"
tracker_move $w 0 0
return 1
}
proc tracker_move {w dx dy} {
global tracker_struct
$tracker_struct($w:canvas) itemconfigure bg -fill {}
incr tracker_struct($w:cursor:x) $dx
incr tracker_struct($w:cursor:y) $dy
if {$tracker_struct($w:cursor:x) < 0} {
incr tracker_struct($w:cursor:x) $tracker_struct($w:-cols)
}
if {$tracker_struct($w:cursor:y) < 0} {
incr tracker_struct($w:cursor:y) $tracker_struct($w:-rows)
}
set tracker_struct($w:cursor:x) [expr $tracker_struct($w:cursor:x) \
%$tracker_struct($w:-cols)]
set tracker_struct($w:cursor:y) [expr $tracker_struct($w:cursor:y) \
%$tracker_struct($w:-rows)]
set xy $tracker_struct($w:cursor:x)$tracker_struct($w:cursor:y)
$tracker_struct($w:canvas) itemconfigure xy$xy -fill black
}
proc tracker_keypress {w ks} {
#puts "[lindex [info level 0] 0]: $w $ks"
switch $ks {
Left {tracker_move $w -1 0}
Right {tracker_move $w 1 0}
Up {tracker_move $w 0 -1}
Down {tracker_move $w 0 1}
}
}
pack [tracker .t -width 400 -height 400][ Category Widget ]