[FF] 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 2008-06-29: Full scroll/visibility support 2008-06-28: Added more color keys, added partial scroll support older: The big mess ---- Usage 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 [http://www.freemove.it/main/fileadmin/trackerwidget2.png] ---- #!/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} { #variable method_prefix if {$method != {method}} { return -code error "must be: static method " } #uplevel [list proc ${method_prefix}${name} $arglist $body] uplevel [list proc ${name} $arglist $body] } proc constructor {arglist body} { uplevel [list method tracker $arglist $body] } proc method {name arglist body} { set gl {tracker_struct} variable $gl variable method_prefix # preprocess method body: #set sssub "\\1${gl}(\$w:\\2)" #set pbody [regsub -all {([^\\w]| |\$)self$(.*)$} $body $sssub] set pbody [regsub -all {self\(} $body ${gl}(\$w:] if {"::$name" != [namespace current]} {set name "${method_prefix}${name}"} uplevel [list proc $name [linsert $arglist 0 w] "variable $gl; $pbody"] #puts [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 "::unknown $method_name $args" } eval "$m [uplevel {set w}] $args" } 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" } } 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 [list proc $w args "return \[eval [method_spec callback] $w \$args\]"] if [init] { return $c } else { return -code error -errorinfo \ "tracker($w): init failed" } } method callback {command {args {}}} { # dispatch command, if it exists return [eval [method_spec $command] $w $args] } method xview {args} { eval "$self(canvas) xview $args" } method yview {args} { eval "$self(canvas) yview $args" } 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) "[method_spec keypress] $w %K %s" bind $self(window) "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 "[method_spec moveabs] $w $col $row" $self(canvas) bind $tag "[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 $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] ]]