Version 3 of TrackerWidget
Updated 2008-05-14 15:42:37 by FFFF 2007-05-26 - This widget has various uses. Check the Widget Hiding as opposed to Widget Overloading page for an overview.
Usage example:
pack [tracker .t -rows 4 -cols 4 -colchars {8 1 1 1} -spacing 2 \
-background black -foreground green \
-backgroundsel blue \
-backgroundcur red -foregroundcur white]
#!/usr/bin/env wish
#######################################################################
#
# TrackerWidget
# written by Federico Ferri - 2007
#
#######################################################################
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
#######################################################################
#
# Developer documntation - widget procs:
#
# tracker {w args}
# widget constructor, calls tracker_init
# tracker_callback {w command {args {}}}
# callback proc for dispatching commands
# tracker_xy {x y {prefix xy}}
# generate tag index for individual cells by column/row
# $prefix default to xy (but text has xytxt prefix)
# tracker_init {w}
# init: creates rectangles on the canvas
# tracker_move {w dx dy}
# move cursor relative to current position, by $dx,$dy
# tracker_setdata {w row col d}
# set data to cell specified by $row,$col
# data is kept in $tracker_struct($w:data:$col,$row)
# tracker_getdata {w row col {d {}}}
# read data
# returns $d if data doesn0t exists
# tracker_copy {w}
# copy selected area to clipboard
# tracker_delete {w}
# delete selected area
# tracker_cut {w}
# combination of copy & delete
# tracker_paste {w}
# paste data from clipboard, starting at current cursor position
# tracker_bindcell {w row col tag}
# this gets called internally, when a text is added to canvas
# tracker_keypress {w ks st}
# very first keypress handler; it calls tracker_inputdata
# tracker_inputdata {w col row keysym state}
# this handles multi-character input for one cell
# you can hook up your favorite input method instead of this proc
# tracker_moveabs {w mx my}
# move cursor to absolute position specified by $mx,$my
# tracker_col_from_x {w x}
# map x coordinate to column number
# tracker_row_from_y {w y}
# map y coordinate to row number
# tracker_col_to_x {w col}
# map column number to x coordinate
# tracker_row_to_y {w row}
# map row number to y coordinate
# tracker_extendsel {w _x _y}
# called while dragging mouse for selecting areas
# tracker_deselect {w}
# (visually) clear selection
# tracker_focus {w}
# take keyboard focus
#
#######################################################################
package require Tk
proc tracker {w args} {
global tracker_struct
# set default options
set tracker_struct($w:-rows) 16
set tracker_struct($w:-cols) 6
set tracker_struct($w:-colchars) [list]
set tracker_struct($w:-spacing) 4
set tracker_struct($w:-background) ""
set tracker_struct($w:-foreground) "black"
set tracker_struct($w:-backgroundsel) "yellow"
set tracker_struct($w:-foregroundcur) "white"
set tracker_struct($w:-backgroundcur) "black"
# parse options
set valid_opts {-spacing -rows -cols -background -foreground
-backgroundsel -backgroundcur -foregroundcur -colchars}
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
}
}
# col chars other than 1?
if {[llength $tracker_struct($w:-colchars)] == 0} {
lappend tracker_struct($w:-colchars) 1
}
set cclen [llength $tracker_struct($w:-colchars)]
for {set i $cclen} {$i < $tracker_struct($w:-cols)} {incr i} {
lappend tracker_struct($w:-colchars) \
[lindex $tracker_struct($w:-colchars) [expr {$i%$cclen}]]
}
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:-width) [expr {$tracker_struct($w:-cols)*\
($tracker_struct($w:-spacing)+$tracker_struct($w:-charwidth))}]
set tracker_struct($w:-height) [expr {$tracker_struct($w:-rows)*\
($tracker_struct($w:-spacing)+$tracker_struct($w:-charheight))}]
set c [canvas $w \
-width [expr {[tracker_col_to_x $w $tracker_struct($w:-cols)]-1}]\
-height [expr {[tracker_row_to_y $w $tracker_struct($w:-rows)]-1}]\
-takefocus 1]
rename $c ${w}_canvas
set tracker_struct($w:canvas) ${w}_canvas
set tracker_struct($w:window) $w
set tracker_struct($w:cursor:x) 0
set tracker_struct($w:cursor:y) 0
set tracker_struct($w:sel:start:x) 0
set tracker_struct($w:sel:start:y) 0
set tracker_struct($w:sel:stop:x) 0
set tracker_struct($w:sel:stop:y) 0
set tracker_struct($w:internal:subcol) 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 {}}} {
# dispatch command, if it exists
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_xy {x y {prefix xy}} {
# make an xy tag index
return "${prefix}_${x}_${y}"
}
proc tracker_init {w} {
# initialize tracker, canvas items
global tracker_struct
set rh $tracker_struct($w:-charheight)
set rx 1
for {set x 0} {$x < $tracker_struct($w:-cols)} {incr x} {
set rw [expr {$tracker_struct($w:-charwidth)*[lindex $tracker_struct($w:-colchars) $x]}]
set ry 1
for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} {
$tracker_struct($w:canvas) create rectangle \
$rx $ry [expr {$rx+$rw}] [expr {$ry+$rh}] \
-fill $tracker_struct($w:-background) \
-outline {} \
-tags [list bg [tracker_xy $x $y]]
tracker_bindcell $w $y $x [tracker_xy $x $y]
incr ry [expr {$rh+$tracker_struct($w:-spacing)}]
}
incr rx [expr {$rw+$tracker_struct($w:-spacing)}]
}
bind $tracker_struct($w:window) <KeyPress> "tracker_keypress $w %K %s"
bind $tracker_struct($w:window) <ButtonPress-1> "focus $w"
tracker_move $w 0 0
return 1
}
proc tracker_move {w dx dy} {
# move cursor by relative amount dx dy, wrap if needed
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)}]
$tracker_struct($w:canvas) itemconfigure bg -fill $tracker_struct($w:-background)
$tracker_struct($w:canvas) itemconfigure txt -fill $tracker_struct($w:-foreground)
$tracker_struct($w:canvas) itemconfigure \
[tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y)] \
-fill $tracker_struct($w:-backgroundcur)
$tracker_struct($w:canvas) itemconfigure \
[tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y) xytxt] \
-fill $tracker_struct($w:-foregroundcur)
tracker_deselect $w
set tracker_struct($w:internal:subcol) 0
}
proc tracker_setdata {w row col d} {
# change data at specified position
global tracker_struct
set coords [$tracker_struct($w:canvas) coords [tracker_xy $col $row]]
set tag [tracker_xy $col $row xytxt]
$tracker_struct($w:canvas) delete $tag
set x [expr {[lindex $coords 0]}]
set y [expr {[lindex $coords 1]}]
set tracker_struct($w:data:$col,$row) \
[string range $d 0 [expr {[lindex $tracker_struct($w:-colchars) $col]-1}]]
if {$row == $tracker_struct($w:cursor:y) && $col == $tracker_struct($w:cursor:x)} {
set fill $tracker_struct($w:-foregroundcur)
} else {
set fill $tracker_struct($w:-foreground)
}
$tracker_struct($w:canvas) create text $x $y -tags [list $tag txt] \
-text $tracker_struct($w:data:$col,$row) -font $tracker_struct($w:font) \
-fill $fill -anchor nw
tracker_bindcell $w $row $col $tag
}
proc tracker_getdata {w row col {d {}}} {
# get data at specified position
global tracker_struct
set r $d
catch {set r $tracker_struct($w:data:$col,$row)}
return $r
}
proc tracker_copy {w} {
# perform a copy of selected area
global tracker_struct
for {set ty $tracker_struct($w:sel:start:y); set by 0} \
{$ty < $tracker_struct($w:sel:stop:y)} {incr ty; incr by} {
for {set tx $tracker_struct($w:sel:start:x); set bx 0} \
{$tx < $tracker_struct($w:sel:stop:x)} {incr tx; incr bx} {
catch {
set tracker_struct($w:copybuf:$bx,$by) \
$tracker_struct($w:data:$tx,$ty)
}
}
}
set tracker_struct($w:copybuf:w) $bx
set tracker_struct($w:copybuf:h) $by
}
proc tracker_delete {w} {
# delete selected area
global tracker_struct
for {set ty $tracker_struct($w:sel:start:y)} \
{$ty < $tracker_struct($w:sel:stop:y)} {incr ty} {
for {set tx $tracker_struct($w:sel:start:x)} \
{$tx < $tracker_struct($w:sel:stop:x)} {incr tx} {
$tracker_struct($w:canvas) delete [tracker_xy $tx $ty xytxt]
unset tracker_struct($w:data:$tx,$ty)
}
}
}
proc tracker_cut {w} {
# perform a cut (that is: copy & delete)
tracker_copy $w
tracker_delete $w
}
proc tracker_paste {w} {
# paste data from copybuf to current position
global tracker_struct
set py $tracker_struct($w:cursor:y)
for {set by 0} {$by < $tracker_struct($w:copybuf:h)} {incr by; incr py} {
set px $tracker_struct($w:cursor:x)
for {set bx 0} {$bx < $tracker_struct($w:copybuf:w)} {incr bx; incr px} {
catch {
tracker_setdata $w $py $px $tracker_struct($w:copybuf:$bx,$by)
}
}
}
tracker_move $w 0 0
}
proc tracker_bindcell {w row col tag} {
# re-bind events to specific cell
global tracker_struct
$tracker_struct($w:canvas) bind $tag <ButtonPress-1> "tracker_moveabs $w $col $row"
$tracker_struct($w:canvas) bind $tag <B1-Motion> "tracker_extendsel $w %x %y"
}
proc tracker_keypress {w ks st} {
# handle global (canvas) keypress (from event)
global tracker_struct
switch $ks {
Left {tracker_move $w -1 0; return}
Right {tracker_move $w 1 0; return}
Up {tracker_move $w 0 -1; return}
Down {tracker_move $w 0 1; return}
}
if {[expr {$st&0x4}] > 0} {
switch $ks {
c {tracker_copy $w; return}
x {tracker_cut $w; return}
v {tracker_paste $w; return}
}
}
if {[regexp -nocase -- {^[0123456789abcdef]$} $ks]} {
set ret [tracker_inputdata $w \
$tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y) $ks $st]
return $ret
}
}
proc tracker_inputdata {w col row keysym state} {
# keypresses relate to data input are sent here (from tracker_keypress)
# here is handled multi-digit cell input
# you can override with your own input method
global tracker_struct
set colch [lindex $tracker_struct($w:-colchars) $col]
set subcol $tracker_struct($w:internal:subcol)
set default [string repeat 0 $colch]
set nd [lreplace [lrange \
[split [tracker_getdata $w $row $col $default] {}] \
0 [expr {$colch-1}]\
] $subcol $subcol $keysym]
set nd [join $nd {}]
tracker_setdata $w $row $col $nd
incr tracker_struct($w:internal:subcol)
if {$tracker_struct($w:internal:subcol) >= $colch} {
tracker_move $w 0 1
}
}
proc tracker_moveabs {w mx my} {
# move cursor to absolute position
global tracker_struct
set tracker_struct($w:cursor:x) $mx
set tracker_struct($w:cursor:y) $my
tracker_move $w 0 0
set tracker_struct($w:sel:start:x) $mx
set tracker_struct($w:sel:start:y) $my
set tracker_struct($w:sel:stop:x) $mx
set tracker_struct($w:sel:stop:y) $my
tracker_deselect $w
}
proc tracker_col_from_x {w x} {
global tracker_struct
set curcol 0
set xlim 0
while {$curcol < $tracker_struct($w:-cols)} {
incr xlim [expr {($tracker_struct($w:-charwidth)+$tracker_struct($w:-spacing))*\
[lindex $tracker_struct($w:-colchars) $curcol]}]
incr curcol
if {[expr {$x-$tracker_struct($w:-charwidth)/2}] < $xlim} {return $curcol}
}
return -1
}
proc tracker_row_from_y {w y} {
global tracker_struct
set currow 0
set ylim 0
while {$currow < $tracker_struct($w:-rows)} {
incr ylim [expr {($tracker_struct($w:-charheight)+$tracker_struct($w:-spacing))}]
incr currow
if {[expr {$y-$tracker_struct($w:-charheight)/2}] < $ylim} {return $currow}
}
return -1
}
proc tracker_col_to_x {w col} {
global tracker_struct
set x 0
set li 0
while {$col >= 0} {
incr x [expr {($tracker_struct($w:-charwidth)*\
[lindex $tracker_struct($w:-colchars) $li])+\
$tracker_struct($w:-spacing)}]
incr li
if {$li >= [llength $tracker_struct($w:-colchars)]} {
return $x
}
}
return $x
}
proc tracker_row_to_y {w row} {
global tracker_struct
return [expr {$row*($tracker_struct($w:-charheight)+$tracker_struct($w:-spacing))}]
}
proc tracker_extendsel {w _x _y} {
# extend selection to specified position (from event)
global tracker_struct
set mx [tracker_col_from_x $w $_x]
set my [tracker_row_from_y $w $_y]
set tracker_struct($w:sel:stop:x) $mx
set tracker_struct($w:sel:stop:y) $my
$tracker_struct($w:canvas) dtag sel
for {set ty $tracker_struct($w:sel:start:y)} {$ty < $tracker_struct($w:sel:stop:y)} {incr ty} {
for {set tx $tracker_struct($w:sel:start:x)} {$tx < $tracker_struct($w:sel:stop:x)} {incr tx} {
$tracker_struct($w:canvas) addtag sel withtag [tracker_xy $tx $ty]
}
}
$tracker_struct($w:canvas) itemconfigure bg -fill $tracker_struct($w:-background)
$tracker_struct($w:canvas) itemconfigure sel -fill $tracker_struct($w:-backgroundsel)
$tracker_struct($w:canvas) itemconfigure \
[tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y)] \
-fill $tracker_struct($w:-backgroundcur)
}
proc tracker_deselect {w} {
# clears current selection
global tracker_struct
set tracker_struct($w:sel:stop:x) $tracker_struct($w:sel:start:x)
set tracker_struct($w:sel:stop:y) $tracker_struct($w:sel:start:y)
}
proc tracker_focus {w} {
# take focus (by a click, from event)
focus $w
}[ Category Widget ]