Version 12 of TrackerWidget
Updated 2008-07-01 19:59:59 by FFFF 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 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 -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 <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} {
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) <KeyPress> "[method_call_spec keypress] %K %s"
bind $self(window) <ButtonPress-1> "focus %W"
bind $self(window) <MouseWheel> "%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 <ButtonPress-1> "[method_call_spec moveabs] $col $row"
$self(canvas) bind $tag <B1-Motion> "[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 <col> -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 ]