Version 9 of TrackerWidget
Updated 2008-06-29 21:29:47 by FFFF 2007-05-26 - This widget has various uses. Basically it's a grid/spreadsheet like widget.
ChangeLog
2008-06-30: after counting how many tracker_* and tracker_struct was repeated
in the source, I created a tiny object system :))
you can see the benefit loking at the diff
thanks to DGP for helping me in removing all those ugly eval's
2008-06-29: Full scroll/visibility support
2008-06-28: Added more color keys, added partial scroll support
older: The big messUsage example:
pack [tracker::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)}]]
}
.t setdata $y $x $d
}
}
.t move 5 8
.t setsel 2 2 5 5
#!/usr/bin/env wish
#######################################################################
#
# TrackerWidget
# written by Federico Ferri - 2007-2008
#
#######################################################################
#
# 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
namespace eval tracker {
variable valid_options {
-rows -cols -colchars -hl1 -hl2
-hspacing -vspacing
-xscrollcommand -yscrollcommand
-background -backgroundHl1 -backgroundHl2
-foreground -foregroundHl1 -foregroundHl2
-backgroundsel -backgroundselHl1 -backgroundselHl2
-foregroundsel -foregroundselHl1 -foregroundselHl2
-backgroundcur -backgroundcurHl1 -backgroundcurHl2
-foregroundcur -foregroundcurHl1 -foregroundcurHl2
}
variable method_prefix @
proc static {method name arglist body} {
# just eye candy wrapper for proc => static method
if {$method != {method}} {
return -code error "must be: static method <name> <arglist> <body>"
}
uplevel 1 [list proc ${name} $arglist $body]
}
proc constructor {arglist body} {
uplevel 1 [list method tracker $arglist $body]
}
proc method {name arglist body} {
set gl {tracker_struct}
variable $gl
variable method_prefix
# preprocess method body:
set pbody [regsub -all {self\(} $body ${gl}(\$w:]
if {"::$name" != [namespace current]} {set name "${method_prefix}${name}"}
uplevel 1 [list proc $name [linsert $arglist 0 w] "variable $gl; $pbody"]
}
proc method_call_unknown {method_name args} {
if [catch {set m [method_spec $method_name]}] {
uplevel 1 [list ::unknown $method_name $args]
}
upvar 1 w w
uplevel 1 [linsert $args 0 $m $w]
}
proc method_spec {method_name} {
variable method_prefix
if [llength [info procs [namespace current]::${method_prefix}${method_name}]] {
return [namespace current]::${method_prefix}${method_name}
} else {
return -code error "no such method: $method_name"
}
}
proc method_call_spec {method_name args_l} {
return [linsert $args_l 0 [method_spec $method_name] [uplevel 1 {set w}]]
}
namespace unknown {method_call_unknown}
constructor {args} {
# set default options
set self(-rows) 16
set self(-cols) 6
set self(-colchars) [list]
set self(-hspacing) 8
set self(-vspacing) 4
set self(-hl1) -1
set self(-hl2) -1
set self(-background) "#000000"
set self(-backgroundHl1) "#222222"
set self(-backgroundHl2) "#444444"
set self(-foreground) "#0011fc"
set self(-foregroundHl1) "#0065db"
set self(-foregroundHl2) "#0092e9"
set self(-backgroundsel) "#18e02b"
set self(-backgroundselHl1) "#79e383"
set self(-backgroundselHl2) "#aaedb0"
set self(-foregroundsel) "#000000"
set self(-foregroundselHl1) "#404980"
set self(-foregroundselHl2) "#354cd9"
set self(-backgroundcur) "#ff0505"
set self(-backgroundcurHl1) "#e75b5b"
set self(-backgroundcurHl2) "#e88b8b"
set self(-foregroundcur) "white"
set self(-foregroundcurHl1) "black"
set self(-foregroundcurHl2) "black"
set self(-xscrollcommand) ""
set self(-yscrollcommand) ""
# parse options
variable valid_options
foreach {opt val} $args {
if {[lsearch -exact $valid_options $opt] == -1} {
return -code error -errorinfo \
"tracker($w): unknown option: $opt"
} else {
set self($opt) $val
}
}
# col chars other than 1?
if {[llength $self(-colchars)] == 0} {
lappend self(-colchars) 1
}
set cclen [llength $self(-colchars)]
for {set i $cclen} {$i < $self(-cols)} {incr i} {
lappend self(-colchars) \
[lindex $self(-colchars) [expr {$i%$cclen}]]
}
set self(font) \
[font create -family Courier -size 10 \
-weight bold -slant roman -underline false -overstrike false]
set self(font:-ascent) [font metrics $self(font) -ascent]
set self(font:-descent) [font metrics $self(font) -descent]
set self(font:-linespace) [font metrics $self(font) -linespace]
set self(font:-width) [font measure $self(font) m]
set self(-charwidth) $self(font:-width)
set self(-charheight) $self(font:-linespace)
set lh [expr {$self(-vspacing)+$self(-charheight)}]
set cw [expr {$self(-hspacing)+$self(-charwidth)}]
set self(-width) [expr {$self(-cols)*$cw}]
set self(-height) [expr {$self(-rows)*$lh}]
set self(regionw) [expr {[col_to_x $self(-cols)]-0}]
set self(regionh) [expr {[row_to_y $self(-rows)]-0}]
set self(lineheight) $lh
set sr [list 0 0 $self(regionw) $self(regionh)]
set c [canvas $w \
-background $self(-background)\
-xscrollcommand $self(-xscrollcommand) \
-yscrollcommand $self(-yscrollcommand) \
-xscrollincrement $cw -yscrollincrement $lh \
-scrollregion $sr -takefocus 1]
rename $c ${w}_canvas
set self(canvas) ${w}_canvas
set self(window) $w
set self(cursor:x) 0
set self(cursor:y) 0
set self(sel:start:x) 0
set self(sel:start:y) 0
set self(sel:stop:x) 0
set self(sel:stop:y) 0
set self(internal:subcol) 0
# setup callback proc
uplevel 1 [list proc $w args \
"return \[uplevel 1 \[linsert \$args 0 [method_spec callback] $w\]\]"]
if [init] {
return $c
} else {
return -code error -errorinfo \
"tracker($w): init failed"
}
}
method callback {command {args {}}} {
# dispatch command, if it exists
return [uplevel 1 [method_call_spec $command $args]]
}
method xview {args} {
return [uplevel #1 [linsert $args 0 $self(canvas) xview]]
}
method yview {args} {
return [uplevel #1 [linsert $args 0 $self(canvas) yview]]
}
method get_row_color {colorkey nrow} {
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%$self(-hl1)}]==0 && $self(-hl1)>1} {set suffix Hl1}
if {[expr {$nrow%$self(-hl2)}]==0 && $self(-hl2)>1} {set suffix Hl2}
set colorkey2 $colorkey$suffix
if {$self(-$colorkey2) == {}} {
return $self(-$colorkey)
} else {
return $self(-$colorkey2)
}
}
static method xy_tag {x y {prefix xy}} {
# make an xy tag index
return "${prefix}_${x}_${y}"
}
method init {} {
# initialize tracker, canvas items
set rh $self(-charheight)
set rx 1
for {set x 0} {$x < $self(-cols)} {incr x} {
set rw [expr {$self(-charwidth)*[lindex $self(-colchars) $x]}]
set ry 0
for {set y 0} {$y < $self(-rows)} {incr y} {
$self(canvas) create rectangle \
$rx $ry [expr {$rx+$rw+$self(-hspacing)}] [expr {$ry+$rh}] \
-fill [get_row_color background $y] \
-outline {} \
-tags [list bg bg_row_$y [xy_tag $x $y]]
bindcell $y $x [xy_tag $x $y]
incr ry [expr {$rh+$self(-vspacing)}]
}
incr rx [expr {$rw+$self(-hspacing)}]
}
bind $self(window) <KeyPress> "[method_spec keypress] $w %K %s"
bind $self(window) <ButtonPress-1> "focus $w"
setsel -1 -1 -1 -1
move 0 0
return 1
}
method move {dx dy} {
# move cursor by relative amount dx dy, wrap if needed
$self(canvas) itemconfigure bg -fill {}
set old_x $self(cursor:x)
set old_y $self(cursor:y)
incr self(cursor:x) $dx
incr self(cursor:y) $dy
if {$self(cursor:x) < 0} {
incr self(cursor:x) $self(-cols)
}
if {$self(cursor:y) < 0} {
incr self(cursor:y) $self(-rows)
}
set self(cursor:x) \
[expr {$self(cursor:x)%$self(-cols)}]
set self(cursor:y) \
[expr {$self(cursor:y)%$self(-rows)}]
set self(internal:subcol) 0
# do the scrolling if cell is not visible:
while {[cursor_scroll_proc] > 0} {}
deselect
}
method cursor_scroll_proc {} {
set fx1 [col_to_x $self(cursor:x)]
set fx2 [col_to_x [expr {$self(cursor:x)+1}]]
foreach {rx1 rx2} [$self(canvas) xview] {break}
set rx1 [expr {$rx1*$self(regionw)}]
set rx2 [expr {$rx2*$self(regionw)}]
set fy1 [row_to_y $self(cursor:y)]
set fy2 [row_to_y [expr {$self(cursor:y)+1}]]
foreach {ry1 ry2} [$self(canvas) yview] {break}
set ry1 [expr {$ry1*$self(regionh)}]
set ry2 [expr {$ry2*$self(regionh)}]
if {$rx1 != $rx2} {
if {$fx1 < $rx1 || $fx2 < $rx1} {
$self(canvas) xview scroll -1 units
return 1
}
if {$fx1 > $rx2 || $fx2 > $rx2} {
$self(canvas) xview scroll 1 units
return 1
}
}
if {$ry1 != $ry2} {
if {$fy1 < $ry1 || $fy2 < $ry1} {
$self(canvas) yview scroll -1 units
return 1
}
if {$fy1 > $ry2 || $fy2 > $ry2} {
$self(canvas) yview scroll 1 units
return 1
}
}
return 0
}
method update_cell_color {x y} {
puts [info level 0]
if {$x == $self(cursor:x) && $y == $self(cursor:x)} {
set fgcolkey foregroundcur
set bgcolkey backgroundcur
} elseif {$x >= $self(sel:start:x) && $x <= $self(sel:stop:x) &&
$y >= $self(sel:start:y) && $y <= $self(sel:stop:y) &&
$self(sel:start:x) != $self(sel:stop:x) &&
$self(sel:start:y) != $self(sel:stop:y)} {
set fgcolkey foregroundsel
set bgcolkey backgroundsel
} else {
set fgcolkey foreground
set bgcolkey background
}
$self(canvas) itemconfigure [xy_tag $x $y] -fill [get_row_color $bgcolkey $y]
$self(canvas) itemconfigure [xy_tag $x $y xytxt] -fill [get_row_color $fgcolkey $y]
}
method resetcolors {} {
$self(canvas) itemconfigure bg -fill {}
$self(canvas) itemconfigure txt -fill {}
for {set y 0} {$y < $self(-rows)} {incr y} {
$self(canvas) itemconfigure bg_row_$y -fill [get_row_color background $y]
$self(canvas) itemconfigure txt_row_$y -fill [get_row_color foreground $y]
}
updatecursor
}
method setdata {row col d} {
# change data at specified position
set coords [$self(canvas) coords [xy_tag $col $row]]
set tag [xy_tag $col $row xytxt]
$self(canvas) delete $tag
set x [expr {[lindex $coords 0]+1}]
set y [expr {[lindex $coords 1]+1}]
set self(data:$col,$row) \
[string range $d 0 [expr {[lindex $self(-colchars) $col]-1}]]
if {$row == $self(cursor:y) && $col == $self(cursor:x)} {
set fill [get_row_color foregroundcur $row]
} else {
set fill [get_row_color foreground $row]
}
$self(canvas) create text $x $y -tags [list $tag txt txt_row_$row] \
-text $self(data:$col,$row) -font $self(font) \
-fill $fill -anchor nw
bindcell $row $col $tag
}
method getdata {row col {d {}}} {
# get data at specified position
set r $d
catch {set r $self(data:$col,$row)}
return $r
}
method copy {} {
# perform a copy of selected area
for {set ty $self(sel:start:y); set by 0} \
{$ty <= $self(sel:stop:y)} {incr ty; incr by} {
for {set tx $self(sel:start:x); set bx 0} \
{$tx <= $self(sel:stop:x)} {incr tx; incr bx} {
catch {
set self(copybuf:$bx,$by) \
$self(data:$tx,$ty)
}
}
}
set self(copybuf:w) $bx
set self(copybuf:h) $by
}
method delete {} {
# delete selected area
for {set ty $self(sel:start:y)} \
{$ty <= $self(sel:stop:y)} {incr ty} {
for {set tx $self(sel:start:x)} \
{$tx <= $self(sel:stop:x)} {incr tx} {
$self(canvas) delete [xy_tag $tx $ty xytxt]
unset self(data:$tx,$ty)
}
}
}
method cut {} {
# perform a cut (that is: copy & delete)
copy
delete
}
method paste {} {
# paste data from copybuf to current position
set py $self(cursor:y)
for {set by 0} {$by < $self(copybuf:h)} {incr by; incr py} {
set px $self(cursor:x)
for {set bx 0} {$bx < $self(copybuf:w)} {incr bx; incr px} {
catch {
setdata $py $px $self(copybuf:$bx,$by)
}
}
}
move 0 0
}
method bindcell {row col tag} {
# re-bind events to specific cell
$self(canvas) bind $tag <ButtonPress-1> "[method_spec moveabs] $w $col $row"
$self(canvas) bind $tag <B1-Motion> "[method_spec extendsel] $w %x %y"
}
method keypress {ks st} {
# handle global (canvas) keypress (from event)
switch $ks {
Left {move -1 0; return}
Right {move 1 0; return}
Up {move 0 -1; return}
Down {move 0 1; return}
}
if {[expr {$st&0x4}] > 0} {
switch $ks {
c {copy; return}
x {cut; return}
v {paste; return}
}
}
if {[regexp -nocase -- {^[0123456789abcdef]$} $ks]} {
set ret [inputdata $self(cursor:x) $self(cursor:y) $ks $st]
return $ret
}
}
method inputdata {col row keysym state} {
# keypresses relate to data input are sent here (from method keypress)
# here is handled multi-digit cell input
# you can override with your own input method
set colch [lindex $self(-colchars) $col]
set subcol $self(internal:subcol)
set default [string repeat 0 $colch]
set nd [lreplace [lrange \
[split [getdata $row $col $default] {}] \
0 [expr {$colch-1}]\
] $subcol $subcol $keysym]
set nd [join $nd {}]
setdata $row $col $nd
incr self(internal:subcol)
if {$self(internal:subcol) >= $colch} {
move 0 1
}
}
method moveabs {mx my} {
# move cursor to absolute position
set old_x $self(cursor:x)
set old_y $self(cursor:y)
set self(cursor:x) $mx
set self(cursor:y) $my
move 0 0
set self(sel:start:x) $mx
set self(sel:start:y) $my
set self(sel:stop:x) $mx
set self(sel:stop:y) $my
deselect
}
method col_from_x {x} {
set curcol 0
set xlim 0
while {$curcol < $self(-cols)} {
set colchars [lindex $self(-colchars) $curcol]
set colwidth [expr {$colchars*$self(-charwidth)+$self(-hspacing)}]
incr xlim $colwidth
if {$x <= $xlim} {return $curcol}
incr curcol
}
return -1
}
method row_from_y {y} {
set currow 0
set ylim 0
set lineheight [expr {$self(-charheight)+$self(-vspacing)}]
while {$currow < $self(-rows)} {
incr ylim $lineheight
if {$y <= $ylim} {return $currow}
incr currow
}
return -1
}
method col_to_x {col} {
set x 0
set li 0
while {$col > 0} {
incr x [expr {($self(-charwidth)*\
[lindex $self(-colchars) $li])+\
$self(-hspacing)}]
incr li
if {$li >= [llength $self(-colchars)]} {
return $x
}
incr col -1
}
return $x
}
method row_to_y {row} {
return [expr {$row*($self(-charheight)+$self(-vspacing))}]
}
method extendsel {_x _y} {
# extend selection to specified position (from event)
clip_x_y _x _y
set mx [col_from_x $_x]
set my [row_from_y $_y]
if {$mx < $self(sel:start:x)} {set mx $self(sel:start:x)}
if {$my < $self(sel:start:y)} {set my $self(sel:start:y)}
set self(sel:stop:x) $mx
set self(sel:stop:y) $my
updatesel
}
method setsel {startrow startcol stoprow stopcol} {
set self(sel:start:y) $startrow
set self(sel:start:x) $startcol
set self(sel:stop:y) $stoprow
set self(sel:stop:x) $stopcol
updatesel
}
method updatesel {} {
$self(canvas) dtag sel
resetcolors
for {set ty $self(sel:start:y)} {$ty <= $self(sel:stop:y)} {incr ty} {
set bgcol [get_row_color backgroundsel $ty]
set fgcol [get_row_color foregroundsel $ty]
for {set tx $self(sel:start:x)} {$tx <= $self(sel:stop:x)} {incr tx} {
$self(canvas) addtag sel withtag [xy_tag $tx $ty]
$self(canvas) itemconfigure [xy_tag $tx $ty] -fill $bgcol
$self(canvas) itemconfigure [xy_tag $tx $ty xytxt] -fill $fgcol
}
}
updatecursor
}
method updatecursor {} {
$self(canvas) itemconfigure \
[xy_tag $self(cursor:x) $self(cursor:y)] \
-fill [get_row_color backgroundcur $self(cursor:y)]
$self(canvas) itemconfigure \
[xy_tag $self(cursor:x) $self(cursor:y) xytxt] \
-fill [get_row_color foregroundcur $self(cursor:y)]
}
method deselect {} {
# clears current selection
set self(sel:stop:x) $self(sel:start:x)
set self(sel:stop:y) $self(sel:start:y)
resetcolors
return 1
}
method focus {} {
# take focus (by a click, from event)
focus $w
}
method clip_x_y {varw varh} {
set width [col_to_x $self(-cols)]
set height [row_to_y $self(-rows)]
upvar 1 $varw _varw
upvar 1 $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 ]