[FF] 2007-05-26 - This widget has various uses. Basically it's a grid/spreadsheet like widget. -- [WJP] 2008-06-29 - A little bit more of an explanation of what this is for and how to use it would be very helpful. [FF] Spreadsheed/data-grid. Basically viewing and editing a grid of data (not necessarily numbers... try '''[.t columnconfigure 0 -type note]''' for example ;p [HexEdit - an hexadecimal editor] is another example, although incomplete, and doesn't feature almost any cool feature of [TrackerWidget]... more to come...) ''ChangeLog'' 2008-07-01: [FF] - added configure command, columnconfigure command, improved keyboard support this is coming up really nice, although it needs a bit more optimization :] 2008-06-30: [FF] - 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: [FF] - Full scroll/visibility support 2008-06-28: [FF] - Added more color keys, added partial scroll support older: [FF] - 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 -hl1 -hl2 -width -height -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 " } uplevel 1 [list proc ${name} $arglist $body] } proc constructor {arglist body} { uplevel 1 [list method tracker $arglist $body] } proc method {name arglist body} { variable method_prefix variable _ # preprocess method body: set pbody [regsub -all {self\(} $body _(\$w:] if {"::$name" != [namespace current]} {set name "${method_prefix}${name}"} uplevel 1 [list proc $name [linsert $arglist 0 w] "variable _; $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(-width) 0 set self(-height) 0 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) "" set self(-col:default:-type) "number" set self(-col:default:-inputmethod) "number" set self(-col:default:-displaymethod) "number" set self(-col:default:-width) 3 # 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 } } # font stuff: 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 c [canvas $w \ -background $self(-background) \ -xscrollcommand $self(-xscrollcommand) \ -yscrollcommand $self(-yscrollcommand) \ -width $self(-width) -height $self(-height) \ -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(internal:subcol) 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(copybuf:w) 0 set self(copybuf:h) 0 # setup callback proc uplevel 1 [list proc $w args \ "if {\[llength \$args\] < 1} { return -code error \"wrong # args: should be \\\"$w option ?arg arg ...?\\\"\" } return \[uplevel 1 \[linsert \$args 0 [method_spec callback] $w\]\]"] configure -rows $self(-rows) -cols $self(-cols) } 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 {} { $self(canvas) delete bg txt # 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)*[columnconfigure $x -width]}] 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]] incr ry [expr {$rh+$self(-vspacing)}] #set data [getdata $y $x] #if {$data == {}} { # bindcell $y $x [xy_tag $x $y] #} else { # setdata $y $x $data #} updatecelltext $x $y updatecellcolor $x $y } incr rx [expr {$rw+$self(-hspacing)}] } set self(regionw) [expr {[col_to_x $self(-cols)]-0}] set self(regionh) [expr {[row_to_y $self(-rows)]-0}] set lh [expr {$self(-vspacing)+$self(-charheight)}] set cw [expr {$self(-hspacing)+$self(-charwidth)}] $self(canvas) configure -xscrollincrement $cw -yscrollincrement $lh set self(-width) [expr {$self(-cols)*$cw}] set self(-height) [expr {$self(-rows)*$lh}] bind $self(window) "[method_call_spec keypress] %K %s" bind $self(window) "focus %W" bind $self(window) "%W yview scroll \[expr {-(%D)}\] units" setsel -1 -1 -1 -1 move 0 0 } method cget {key} { variable valid_options if {[lsearch -exact $valid_options $key] >= 0} { return $self($key) } else { switch -- $key { -takefocus {return 1} -state {return {normal}} } } return -code error "unknown option \"$key\"" } method configure {args} { variable valid_options set re_init 0 set update_colors 0 foreach {key value} $args { switch -- $key { -background - -foreground - -backgroundHl1 - -backgroundHl2 - -foregroundHl1 - -foregroundHl2 - -backgroundsel - -backgroundselHl1 - -backgroundselHl2 - -foregroundsel - -foregroundselHl1 - -foregroundselHl2 - -backgroundcur - -backgroundcurHl1 - -backgroundcurHl2 - -foregroundcur - -foregroundcurHl1 - -foregroundcurHl2 - -hl1 - -hl2 { # stuff which only requires @updatecolors: if {$key == {-background}} {$self(canvas) configure -background $value} set self($key) $value set update_colors 1 } -hspacing - -vspacing { set self($key) $value set self(regionw) [col_to_x $self(-cols)] set self(regionh) [row_to_y $self(-rows)] $self(canvas) configure -scrollregion \ [list 0 0 $self(regionw) $self(regionh)] set re_init 1 } -rows - -cols { set self($key) $value set self(regionw) [col_to_x $self(-cols)] set self(regionh) [row_to_y $self(-rows)] $self(canvas) configure -scrollregion \ [list 0 0 $self(regionw) $self(regionh)] set re_init 1 } -xscrollcommand - -yscrollcommand - -width - -height { set self($key) $value $self(canvas) configure $key $value } default { if {[lsearch -exact $valid_options $key] >= 0} { return -code error "unsupported option for configure \"$key\"" } else { return -code error "unknown option \"$key\"" } } } } if {$re_init} {init} if {$update_colors} {updatecolors} } method columnconfigure {col args} { if {$col != {default} && ($col < 0 || $col >= $self(-cols))} { return -code error "column index $col out fo range" } if {[llength $args] == 1} { set key [lindex $args 0] if [info exists self(-col:$col:$key)] { return $self(-col:$col:$key) } if [info exists self(-col:default:$key)] { return $self(-col:default:$key) } return -code error "invalid column option \"$key\"" } set re_init 0 set update_col 0 foreach {key value} $args { switch -- $key { -type { # sets both input and display methods set valid_types {number numberhex note symbol} if {[lsearch -exact $valid_types $value] >= 0} { set self(-col:$col:$key) $value columnconfigure $col -inputmethod $value columnconfigure $col -displaymethod $value } else { return -code error "invalid value for $key: \"$value\". must be one of [join $valid_types {, }]" } } -width { set self(-col:$col:$key) [expr {int($value)}] set re_init 1 } -inputmethod { # this triggers an error in case of missing method: method_spec input$value set self(-col:$col:$key) $value } -displaymethod { # this triggers an error in case of missing method: method_spec display$value set self(-col:$col:$key) $value set update_col 1 } } } if {$re_init} {init} if {$update_col} {updatecolumn $col} } method move {dx dy} { # move cursor by relative amount dx dy, wrap if needed set old_x $self(cursor:x) set old_y $self(cursor:y) incr self(cursor:x) $dx incr self(cursor:y) $dy while {$self(cursor:x) < 0} {incr self(cursor:x) $self(-cols)} while {$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} {} if {$old_x == $self(cursor:x) && $old_y == $self(cursor:y)} { return } if ![deselect] { updatecellcolor $old_x $old_y updatecellcolor $self(cursor:x) $self(cursor:y) } } 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 if {$self(cursor:x) != $old_x || $self(cursor:y) != $old_y} { updatecellcolor $old_x $old_y updatecellcolor $self(cursor:x) $self(cursor:y) } if ![deselect] { updatecellcolor $old_x $old_y updatecellcolor $self(cursor:x) $self(cursor:y) } } 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 updatecellcolor {x y} { if {$x == $self(cursor:x) && $y == $self(cursor:y)} { 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 updatecelltext {x y} { set vis_data [uplevel 0 [list display[columnconfigure $x -displaymethod] $x $y]] set coords [$self(canvas) coords [xy_tag $x $y]] set xytag [xy_tag $x $y xytxt] set tags [list $xytag txt txt_row_$y] $self(canvas) delete $xytag set px [expr {[lindex $coords 0]+1}] set py [expr {[lindex $coords 1]+1}] $self(canvas) create text $px $py -tags $tags \ -fill [] \ -text $vis_data -font $self(font) -anchor nw bindcell $y $x $xytag } method updatecolumn {col} { if {$col == {default}} { set colstart 0 set colend $self(-cols) } else { set colstart $col set colend [expr {$col+1}] } for {set c $colstart} {$c < $colend} {incr c} { for {set row 0} {$row < $self(-rows)} {incr row} { updatecelltext $c $row updatecellcolor $c $row } } } method displaynumber {x y} { set d [getdata $y $x] set width [columnconfigure $x -width] if {$d == {}} {return [string repeat . $width]} set d [expr {$d%10**$width}] return [format %${width}.d $d] } method displaynumberhex {x y} { set d [getdata $y $x] set width [columnconfigure $x -width] if {$d == {}} {return [string repeat . $width]} set d [expr {$d%16**$width}] return [format %${width}.x $d] } method displaynote {x y} { set d [getdata $y $x] if {$d == {}} {return {...}} set note [expr {$d%12}] set oct [expr {($d-$note)/12}] if {$oct >= 10} {set oct 9} if {$oct < 0} {set oct 0} return "[lindex {C- C# D- D# E- F- F# G- G# A- A# B-} $note]${oct}" } method displaysymbol {x y} { #TODO: return [string repeat ? [columnconfigure $x -width]] } 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 # d is an integer setdata_noupdate $row $col $d updatecelltext $col $row updatecellcolor $col $row } method setdata_noupdate {row col d} { if {$d == {}} { catch {unset self(data:$col,$row)} } else { if [catch {set d [expr {int($d)}]}] {set d 0} set self(data:$col,$row) $d } } method getdata {row col {d {}}} { # get data at specified position set r $d catch {set r [expr {int($self(data:$col,$row))}]} return $r } method resetdata {} { array unset _ $w:data:* } 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] #catch {unset self(data:$tx,$ty)} setdata $ty $tx {} } } } 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_call_spec moveabs] $col $row" $self(canvas) bind $tag "[method_call_spec extendsel] %x %y" } method select_all {} { setsel 0 0 [expr {$self(-rows)-1}] [expr {$self(-cols)-1}] } method select_none {} { setsel $self(cursor:y) $self(cursor:x) $self(cursor:y) $self(cursor:x) } method select_row {} { setsel $self(cursor:y) 0 $self(cursor:y) [expr {$self(-cols)-1}] } method select_column {} { setsel 0 $self(cursor:x) [expr {$self(-rows)-1}] $self(cursor:x) } method keypress {ks st} { # handle global (canvas) keypress (from event) set shift [expr {($st&0x0001)>0}] set caps [expr {($st&0x0002)>0}] set control [expr {($st&0x0004)>0}] set alt [expr {($st&0x0008)>0}] set super [expr {($st&0x0040)>0}] if 0 {puts "$ks shift=$shift caps=$caps control=$control alt=$alt super=$super"} if $shift { switch -- $ks { Left {extendsel_rel -1 0; return} Right {extendsel_rel 1 0; return} Up {extendsel_rel 0 -1; return} Down {extendsel_rel 0 1; return} Home {moveabs 0 $self(cursor:y); return} End {moveabs -1 $self(cursor:y); return} } } if $control { switch -- $ks { c {copy; return} x {cut; return} v {paste; return} a {select_all; return} u {select_none; return} l {if $shift {select_row} else {select_column}} } } switch -- $ks { Left {move -1 0; return} Right {move 1 0; return} Up {move 0 -1; return} Down {move 0 1; return} BackSpace {delete; return} Home {moveabs $self(cursor:x) 0; return} End {moveabs $self(cursor:x) -1; return} Next {move 0 [expr {max(4,$self(-hl2))}]; return} Prior {move 0 [expr {-max(4,$self(-hl2))}]; return} } uplevel 0 [list input[columnconfigure $self(cursor:x) -inputmethod] $self(cursor:x) $self(cursor:y) $ks $st] } method inputnumber {col row keysym state} { # keypresses are sent here from method keypress, based on -inputmethod (-type) if {![regexp -nocase -- {^[0123456789]$} $keysym]} { return } set d [getdata $row $col 0] set colch [columnconfigure $col -width] if {$self(internal:subcol) == 0} { set d $keysym } else { set d [expr {($d*10+$keysym)%(10**$colch)}] } setdata $row $col $d incr self(internal:subcol) if {$self(internal:subcol) >= $colch} { move 0 1 } } method inputnumberhex {col row keysym state} { if {![regexp -nocase -- {^[0123456789abcdef]$} $keysym]} { return } set keysym "0x$keysym" set d [getdata $row $col 0] set colch [columnconfigure $col -width] if {$self(internal:subcol) == 0} { set d $keysym } else { set d [expr {($d*16+$keysym)%(16**$colch)}] } setdata $row $col $d incr self(internal:subcol) if {$self(internal:subcol) >= $colch} { move 0 1 } } method inputnote {col row keysym state} { set map {z 0 s 1 x 2 d 3 c 4 v 5 g 6 b 7 h 8 n 9 j 10 m 11} set d [getdata $row $col 0] set note [expr {$d%12}] set oct [expr {($d-$note)/12}] switch -- $keysym { z - s - x - d - c - v - g - b - h - n - j - m { set note [string map -nocase $map $keysym] } 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { set oct $keysym } default { return } } setdata $row $col [expr {$oct*12+$note}] move 0 1 } method inputsymbol {col row keysym state} { move 0 1 } method col_from_x {x} { set curcol 0 set xlim 0 while {$curcol < $self(-cols)} { set colwidth [expr {[columnconfigure $curcol -width]*$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)*\ [columnconfigure $li -width])+\ $self(-hspacing)}] incr li if {$li >= $self(-cols)} { 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 self(sel:stop:x) [col_from_x $_x] set self(sel:stop:y) [row_from_y $_y] if {$self(sel:stop:x) < $self(sel:start:x)} {set self(sel:stop:x) $self(sel:start:x)} if {$self(sel:stop:y) < $self(sel:start:y)} {set self(sel:stop:y) $self(sel:start:y)} updatesel } method extendsel_rel {dx dy} { incr self(sel:stop:x) $dx incr self(sel:stop:y) $dy if {$self(sel:stop:x) < $self(sel:start:x)} {set self(sel:stop:x) $self(sel:start:x)} if {$self(sel:stop:y) < $self(sel:start:y)} {set self(sel:stop:y) $self(sel:start:y)} 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 updatecolors {} { resetcolors updatesel } 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 retval 0 if {$self(sel:start:x)<$self(sel:stop:x) || $self(sel:start:y)<$self(sel:stop:y)} { set retval 1 } set self(sel:start:x) $self(cursor:x) set self(sel:start:y) $self(cursor:y) set self(sel:stop:x) $self(sel:start:x) set self(sel:stop:y) $self(sel:start:y) if $retval resetcolors return $retval } 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] ]]