Version 4 of TrackerWidget
Updated 2008-06-28 12:59:38 by FFFF 2007-05-26 - This widget has various uses. Basically it's a grid/spreadsheet like widget.
Usage example:
pack [tracker .t \
-rows 32 -cols 24 \
-colchars {8 1 1 1 2 4 1 4 1 2 3 2 1} \
-hl1 4 -hl2 16]
# fill with ranom data
set dgts {0 1 2 3 4 5 6 7 8 9 a b c d e f}
set dgtsl [llength $dgts]
for {set y 0} {$y < 32} {incr y} {
for {set x 0} {$x < 24} {incr x} {
set d {}
for {set z 0} {$z < 8} {incr z} {
append d [lindex $dgts [expr {int(rand()*$dgtsl)}]]
}
tracker_setdata .t $y $x $d
}
}
tracker_move .t 5 8
tracker_setsel .t 2 2 5 5
#!/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.
#
#######################################################################
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:-hspacing) 8
set tracker_struct($w:-vspacing) 4
set tracker_struct($w:-hl1) -1
set tracker_struct($w:-hl2) -1
set tracker_struct($w:-background) "#000000"
set tracker_struct($w:-backgroundHl1) "#222222"
set tracker_struct($w:-backgroundHl2) "#444444"
set tracker_struct($w:-foreground) "#0011fc"
set tracker_struct($w:-foregroundHl1) "#0065db"
set tracker_struct($w:-foregroundHl2) "#0092e9"
set tracker_struct($w:-backgroundsel) "#18e02b"
set tracker_struct($w:-backgroundselHl1) "#79e383"
set tracker_struct($w:-backgroundselHl2) "#aaedb0"
set tracker_struct($w:-foregroundsel) "#000000"
set tracker_struct($w:-foregroundselHl1) "#404980"
set tracker_struct($w:-foregroundselHl2) "#354cd9"
set tracker_struct($w:-backgroundcur) "#ff0505"
set tracker_struct($w:-backgroundcurHl1) "#e75b5b"
set tracker_struct($w:-backgroundcurHl2) "#e88b8b"
set tracker_struct($w:-foregroundcur) "white"
set tracker_struct($w:-foregroundcurHl1) "black"
set tracker_struct($w:-foregroundcurHl2) "black"
# parse options
set valid_opts {
-rows -cols -colchars -hl1 -hl2
-hspacing -vspacing
-background -backgroundHl1 -backgroundHl2
-foreground -foregroundHl1 -foregroundHl2
-backgroundsel -backgroundselHl1 -backgroundselHl2
-foregroundsel -foregroundselHl1 -foregroundselHl2
-backgroundcur -backgroundcurHl1 -backgroundcurHl2
-foregroundcur -foregroundcurHl1 -foregroundcurHl2
}
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:-hspacing)+$tracker_struct($w:-charwidth))}]
set tracker_struct($w:-height) [expr {$tracker_struct($w:-rows)*\
($tracker_struct($w:-vspacing)+$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}]\
-background $tracker_struct($w:-background)\
-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_get_row_color {w colorkey nrow} {
global tracker_struct
set colors {background foreground backgroundsel foregroundsel backgroundcur foregroundcur}
if {[lsearch -exact $colors $colorkey] == -1} {
return -code error -errorinfo "tracker($w): wrong color-key: $colorkey"
}
set suffix {}
if {[expr {$nrow%$tracker_struct($w:-hl1)}]==0 && $tracker_struct($w:-hl1)>1} {set suffix Hl1}
if {[expr {$nrow%$tracker_struct($w:-hl2)}]==0 && $tracker_struct($w:-hl2)>1} {set suffix Hl2}
set colorkey2 $colorkey$suffix
if {$tracker_struct($w:-$colorkey2) == {}} {
return $tracker_struct($w:-$colorkey)
} else {
return $tracker_struct($w:-$colorkey2)
}
}
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 0
for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} {
$tracker_struct($w:canvas) create rectangle \
$rx $ry [expr {$rx+$rw+$tracker_struct($w:-hspacing)}] [expr {$ry+$rh}] \
-fill [tracker_get_row_color $w background $y] \
-outline {} \
-tags [list bg bg_row_$y [tracker_xy $x $y]]
tracker_bindcell $w $y $x [tracker_xy $x $y]
incr ry [expr {$rh+$tracker_struct($w:-vspacing)}]
}
incr rx [expr {$rw+$tracker_struct($w:-hspacing)}]
}
bind $tracker_struct($w:window) <KeyPress> "tracker_keypress $w %K %s"
bind $tracker_struct($w:window) <ButtonPress-1> "focus $w"
tracker_setsel $w -1 -1 -1 -1
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 {}
set old_x $tracker_struct($w:cursor:x)
set old_y $tracker_struct($w:cursor:y)
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 tracker_struct($w:internal:subcol) 0
tracker_deselect $w
}
proc tracker_update_cell_color {w x y} {
puts [info level 0]
global tracker_struct
if {$x == $tracker_struct($w:cursor:x) && $y == $tracker_struct($w:cursor:x)} {
set fgcolkey foregroundcur
set bgcolkey backgroundcur
} elseif {$x >= $tracker_struct($w:sel:start:x) && $x <= $tracker_struct($w:sel:stop:x) &&
$y >= $tracker_struct($w:sel:start:y) && $y <= $tracker_struct($w:sel:stop:y) &&
$tracker_struct($w:sel:start:x) != $tracker_struct($w:sel:stop:x) &&
$tracker_struct($w:sel:start:y) != $tracker_struct($w:sel:stop:y)} {
set fgcolkey foregroundsel
set bgcolkey backgroundsel
} else {
set fgcolkey foreground
set bgcolkey background
}
$tracker_struct($w:canvas) itemconfigure [tracker_xy $x $y] -fill [tracker_get_row_color $w $bgcolkey $y]
$tracker_struct($w:canvas) itemconfigure [tracker_xy $x $y xytxt] -fill [tracker_get_row_color $w $fgcolkey $y]
}
proc tracker_resetcolors {w} {
global tracker_struct
$tracker_struct($w:canvas) itemconfigure bg -fill {}
$tracker_struct($w:canvas) itemconfigure txt -fill {}
for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} {
$tracker_struct($w:canvas) itemconfigure bg_row_$y -fill [tracker_get_row_color $w background $y]
$tracker_struct($w:canvas) itemconfigure txt_row_$y -fill [tracker_get_row_color $w foreground $y]
}
tracker_updatecursor $w
}
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]+1}]
set y [expr {[lindex $coords 1]+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_get_row_color $w foregroundcur $row]
} else {
set fill [tracker_get_row_color $w foreground $row]
}
$tracker_struct($w:canvas) create text $x $y -tags [list $tag txt txt_row_$row] \
-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 old_x $tracker_struct($w:cursor:x)
set old_y $tracker_struct($w:cursor:y)
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)} {
set colchars [lindex $tracker_struct($w:-colchars) $curcol]
set colwidth [expr {$colchars*$tracker_struct($w:-charwidth)+$tracker_struct($w:-hspacing)}]
incr xlim $colwidth
if {$x <= $xlim} {return $curcol}
incr curcol
}
return -1
}
proc tracker_row_from_y {w y} {
global tracker_struct
set currow 0
set ylim 0
set lineheight [expr {$tracker_struct($w:-charheight)+$tracker_struct($w:-vspacing)}]
while {$currow < $tracker_struct($w:-rows)} {
incr ylim $lineheight
if {$y <= $ylim} {return $currow}
incr 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:-hspacing)}]
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:-vspacing))}]
}
proc tracker_extendsel {w _x _y} {
# extend selection to specified position (from event)
global tracker_struct
tracker_clip_x_y $w _x _y
set mx [tracker_col_from_x $w $_x]
set my [tracker_row_from_y $w $_y]
if {$mx < $tracker_struct($w:sel:start:x)} {set mx $tracker_struct($w:sel:start:x)}
if {$my < $tracker_struct($w:sel:start:y)} {set my $tracker_struct($w:sel:start:y)}
set tracker_struct($w:sel:stop:x) $mx
set tracker_struct($w:sel:stop:y) $my
tracker_updatesel $w
}
proc tracker_setsel {w startrow startcol stoprow stopcol} {
global tracker_struct
set tracker_struct($w:sel:start:y) $startrow
set tracker_struct($w:sel:start:x) $startcol
set tracker_struct($w:sel:stop:y) $stoprow
set tracker_struct($w:sel:stop:x) $stopcol
tracker_updatesel $w
}
proc tracker_updatesel {w} {
global tracker_struct
$tracker_struct($w:canvas) dtag sel
tracker_resetcolors $w
for {set ty $tracker_struct($w:sel:start:y)} {$ty <= $tracker_struct($w:sel:stop:y)} {incr ty} {
set bgcol [tracker_get_row_color $w backgroundsel $ty]
set fgcol [tracker_get_row_color $w foregroundsel $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 [tracker_xy $tx $ty] -fill $bgcol
$tracker_struct($w:canvas) itemconfigure [tracker_xy $tx $ty xytxt] -fill $fgcol
}
}
tracker_updatecursor $w
}
proc tracker_updatecursor {w} {
global tracker_struct
$tracker_struct($w:canvas) itemconfigure \
[tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y)] \
-fill [tracker_get_row_color $w backgroundcur $tracker_struct($w:cursor:y)]
$tracker_struct($w:canvas) itemconfigure \
[tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y) xytxt] \
-fill [tracker_get_row_color $w foregroundcur $tracker_struct($w:cursor:y)]
}
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)
tracker_resetcolors $w
return 1
}
proc tracker_focus {w} {
# take focus (by a click, from event)
focus $w
}
proc tracker_clip_x_y {w varw varh} {
global tracker_struct
set width [tracker_col_to_x $w $tracker_struct($w:-cols)]
set height [tracker_row_to_y $w $tracker_struct($w:-rows)]
upvar $varw _varw
upvar $varh _varh
if {$_varw < 0} {set _varw 0}
if {$_varw >= $width} {set _varw [expr {$width-1}]}
if {$_varh < 0} {set _varh 0}
if {$_varh >= $height} {set _varh [expr {$height-1}]}
}[ Category Widget ]