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 random 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
AMG: This example doesn't work, since the -colchars option doesn't exist.It's interesting that you made your own object system, but have you considered rewriting this in terms of [namespace ensemble], TclOO, or (heh) [sproc]? It could also be turned into a snidget.
#!/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
package provide tracker 1.0
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
-selectionmethod
-selectionnotify -setdatanotify -cursornotify
-state
}
variable public_method_prefix @
variable private_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 public tracker $arglist $body]
}
proc method {qualifier name arglist body} {
set valid_qualifiers {public private}
if {[lsearch -exact $valid_qualifiers $qualifier] < 0} {
return -code error "qualifier must be one of: $valid_qualifiers"
}
variable ${qualifier}_method_prefix
variable _
set m_prefix [set ${qualifier}_method_prefix]
# preprocess method body:
set pbody [regsub -all {self\(} $body _(\$w:]
if {"::$name" != [namespace current]} {set name "${m_prefix}${name}"}
uplevel 1 [list proc $name [linsert $arglist 0 w] "variable _; $pbody"]
}
proc public {method name arglist body} {
uplevel 1 [list method public $name $arglist $body]
}
proc private {method name arglist body} {
uplevel 1 [list method private $name $arglist $body]
}
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 {private 1}} {
variable public_method_prefix
variable private_method_prefix
set ns [namespace current]
if [llength [info procs ${ns}::${public_method_prefix}${method_name}]] {
return ${ns}::${public_method_prefix}${method_name}
} elseif {$private && [llength [info procs ${ns}::${private_method_prefix}${method_name}]]} {
return ${ns}::${private_method_prefix}${method_name}
} else {
return -code error "no such method: $method_name"
}
}
proc method_call_spec {method_name {args_l {}}} {
# always call public methods only
return [linsert $args_l 0 [method_spec $method_name 0] [uplevel 1 {set w}]]
}
namespace unknown {method_call_unknown}
namespace export -clear tracker
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(-selectionmethod) "rect"
set self(-state) "normal"
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
}
}
foreach k {-selectionnotify -setdatanotify -cursornotify} {
catch [concat configure $k {$self($k); unset self($k)}]
}
# 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 [uplevel #1 [list 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:col) 0
set self(cursor:row) 0
set self(internal:subcol) 0
set self(sel:start:col) 0
set self(sel:start:row) 0
set self(sel:stop:col) 0
set self(sel:stop:row) 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\]\]"]
# this also calls initialization (@init)
configure -rows $self(-rows) -cols $self(-cols)
}
public method callback {command {args {}}} {
# dispatch command, if it exists
return [uplevel 1 [method_call_spec $command $args]]
}
public method xview {args} {
return [uplevel #1 [linsert $args 0 $self(canvas) xview]]
}
public method yview {args} {
return [uplevel #1 [linsert $args 0 $self(canvas) yview]]
}
private 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 {$self(-hl1)>1 && [expr {$nrow%$self(-hl1)}]==0} {set suffix Hl1}
if {$self(-hl2)>1 && [expr {$nrow%$self(-hl2)}]==0} {set suffix Hl2}
set colorkey2 $colorkey$suffix
if {$self(-$colorkey2) == {}} {
return $self(-$colorkey)
} else {
return $self(-$colorkey2)
}
}
static method item_rc_tag {row col {prefix xy}} {
# make an xy tag index
return "${prefix}_${row}_${col}"
}
private method init {} {
# initialize tracker, canvas items
$self(canvas) delete bg txt playhead
for {set x 0} {$x < $self(-cols)} {incr x} {
set xpp [expr {$x+1}]
for {set y 0} {$y < $self(-rows)} {incr y} {
set ypp [expr {$y+1}]
set tagid_bg [item_rc_tag $y $x]
set tagid_txt [item_rc_tag $y $x xytxt]
set rx [col_to_x $x]
set ry [row_to_y $y]
$self(canvas) create rectangle \
$rx $ry [col_to_x $xpp] [row_to_y $ypp] \
-fill [get_row_color background $y] -outline {} \
-tags [list bg bg_row_$y $tagid_bg]
$self(canvas) create text \
[expr {$rx+1}] [expr {$ry+1}] \
-fill {} -text {} -font $self(font) -anchor nw \
-tags [list txt txt_row_$y $tagid_txt]
bindcell $y $x $tagid_bg
bindcell $y $x $tagid_txt
updatecelltext $y $x
updatecellcolor $y $x
}
}
$self(canvas) create rectangle -1 -1 -1 -1 -fill yellow -outline {} -tags playhead
$self(canvas) raise playhead
$self(canvas) raise txt
set self(regionw) [col_to_x $self(-cols)]
set self(regionh) [row_to_y $self(-rows)]
set lh [expr {$self(-vspacing)+$self(-charheight)}]
set cw [expr {$self(-hspacing)+$self(-charwidth)}]
$self(canvas) configure \
-xscrollincrement $cw -yscrollincrement $lh \
-scrollregion [list 0 0 $self(regionw) $self(regionh)]
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"
bind $self(window) <Button-4> "%W yview scroll -1 units"
bind $self(window) <Button-5> "%W yview scroll 1 units"
setsel -1 -1 -1 -1
moveby 0 0
}
public 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\""
}
public 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
}
-selectionmethod {
set valid_methods {rect text}
if {[lsearch -exact $valid_methods $value] >= 0} {
set self($key) $value
} else {
return -code error "$key <method> must be one of: $valid_methods"
}
}
-selectionnotify {
set self(-notify:selection) $value
}
-setdatanotify {
set self(-notify:setdata) $value
}
-cursornotify {
set self(-notify:cursor) $value
}
-state {
set valid_states {normal readonly}
if {[lsearch -exact $valid_states $value] >= 0} {
set self($key) $value
} else {
return -code error "$key <method> must be one of: $valid_states"
}
}
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}
}
public 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}
}
private method callnotify {type args} {
if ![info exists self(-notify:$type)] {return}
switch -- $type {
cursor - selection - setdata {
uplevel 1 [concat $self(-notify:$type) $args]
}
}
}
public method moveby {drow dcol} {
# move cursor by relative amount dx dy, wrap if needed
set old_row $self(cursor:row)
set old_col $self(cursor:col)
incr self(cursor:row) $drow
incr self(cursor:col) $dcol
while {$self(cursor:row) < 0} {incr self(cursor:row) $self(-rows)}
while {$self(cursor:col) < 0} {incr self(cursor:col) $self(-cols)}
set self(cursor:row) [expr {$self(cursor:row)%$self(-rows)}]
set self(cursor:col) [expr {$self(cursor:col)%$self(-cols)}]
set self(internal:subcol) 0
# do the scrolling if cell is not visible:
while {[cursor_scroll_proc] > 0} {}
if {$old_col == $self(cursor:col) && $old_row == $self(cursor:row)} {
return
}
callnotify cursor $self(cursor:row) $self(cursor:col)
if ![deselect] {
updatecellcolor $old_row $old_col
updatecellcolor $self(cursor:row) $self(cursor:col)
}
}
public method moveabs {row col} {
# move cursor to absolute position
set old_row $self(cursor:row)
set old_col $self(cursor:col)
set self(cursor:row) $row
set self(cursor:col) $col
moveby 0 0
if {$self(cursor:row) != $old_row || $self(cursor:col) != $old_col} {
updatecellcolor $old_row $old_col
updatecellcolor $self(cursor:row) $self(cursor:col)
callnotify cursor $self(cursor:row) $self(cursor:col)
}
if ![deselect] {
updatecellcolor $old_row $old_col
updatecellcolor $self(cursor:row) $self(cursor:col)
}
}
public method moveabs_mousewrap {row col} {
if {[cget -state] == {readonly}} {return}
return [moveabs $row $col]
}
public method moveplayhead {row} {
if {$row < 0} {
$self(canvas) coords playhead -1 -1 -1 -1
} else {
$self(canvas) coords playhead 0 [row_to_y $row] [col_to_x $self(-cols)] [row_to_y [incr row]]
}
}
private method cursor_scroll_proc {} {
set fx1 [col_to_x $self(cursor:col)]
set fx2 [col_to_x [expr {$self(cursor:col)+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:row)]
set fy2 [row_to_y [expr {$self(cursor:row)+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
}
private method updatecellcolor {row col} {
if {$col == $self(cursor:col) && $row == $self(cursor:row)} {
set fgcolkey foregroundcur
set bgcolkey backgroundcur
} elseif {[isselected $row $col]} {
set fgcolkey foregroundsel
set bgcolkey backgroundsel
} else {
set fgcolkey foreground
set bgcolkey background
}
$self(canvas) itemconfigure [item_rc_tag $row $col] -fill [get_row_color $bgcolkey $row]
$self(canvas) itemconfigure [item_rc_tag $row $col xytxt] -fill [get_row_color $fgcolkey $row]
}
private method updatecelltext {row col} {
# call the proper displayXXX method to render the cell's text:
set vis_data [uplevel 0 [list display[columnconfigure $col -displaymethod] $row $col]]
$self(canvas) itemconfigure [item_rc_tag $row $col xytxt] -text $vis_data
}
private method updatecolor {row_start col_start {row_end -1} {col_end -1}} {
if {$col_end == {end}} {
set col_end [expr {$self(-cols)-1}]
} elseif {$col_end == -1} {
set col_end $col_start
}
if {$row_end == {end}} {
set row_end [expr {$self(-rows)-1}]
} elseif {$row_end == -1} {
set row_end $row_start
}
for {set col $col_start} {$col <= $col_end} {incr col} {
for {set row $row_start} {$row <= $row_end} {incr row} {
if {$col == $self(cursor:col) && $row == $self(cursor:row)} {
set fgcolkey foregroundcur
set bgcolkey backgroundcur
} elseif {[isselected $row $col]} {
set fgcolkey foregroundsel
set bgcolkey backgroundsel
} else {
set fgcolkey foreground
set bgcolkey background
}
$self(canvas) itemconfigure [item_rc_tag $row $col] -fill [get_row_color $bgcolkey $row]
$self(canvas) itemconfigure [item_rc_tag $row $col xytxt] -fill [get_row_color $fgcolkey $row]
}
}
}
private method updatetext {row_start col_start {row_end -1} {col_end -1}} {
if {$col_end == {end}} {
set col_end [expr {$self(-cols)-1}]
} elseif {$col_end == -1} {
set col_end $col_start
}
if {$row_end == {end}} {
set row_end [expr {$self(-rows)-1}]
} elseif {$row_end == -1} {
set row_end $row_start
}
for {set col $col_start} {$col <= $col_end} {incr col} {
set display_method display[columnconfigure $col -displaymethod]
for {set row $row_start} {$row <= $row_end} {incr row} {
$self(canvas) itemconfigure [item_rc_tag $row $col xytxt] \
-text [uplevel 0 [list $display_method $row $col]]
}
}
}
private method updatecolumn {col} {
if {$col == {default}} {
set colstart 0
set colend end
} else {
set colstart $col
set colend $colstart
}
updatetext 0 $colstart end $colend
updatecolor 0 $colstart end $colend
}
private method displaynumber {row col} {
set d [getdata $row $col]
set width [columnconfigure $col -width]
if {$d == {}} {return [string repeat . $width]}
set d [expr {$d%10**$width}]
return [format %${width}.lld $d]
}
private method displaynumberhex {row col} {
set d [getdata $row $col]
set width [columnconfigure $col -width]
if {$d == {}} {return [string repeat . $width]}
set d [expr {$d%16**$width}]
return [format %.0${width}llx $d]
}
private method displaynote {row col} {
set d [getdata $row $col]
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}"
}
private method displaysymbol {row col} {
#TODO:
return [string repeat ? [columnconfigure $col -width]]
}
private method displaybyte {row col} {
set d [getdata $row $col]
if {$d == {}} {return {}}
return [format %c $d]
}
private method resetcolors {} {
$self(canvas) itemconfigure bg -fill {}
$self(canvas) itemconfigure txt -fill {}
for {set row 0} {$row < $self(-rows)} {incr row} {
$self(canvas) itemconfigure bg_row_$row -fill [get_row_color background $row]
$self(canvas) itemconfigure txt_row_$row -fill [get_row_color foreground $row]
}
updatecursor
}
public method setdata {row col d} {
# change data at specified position
# d is an integer
setdata_noupdate $row $col $d
updatecelltext $row $col
updatecellcolor $row $col
}
private method setdata_noupdate {row col d} {
if {$d == {}} {
catch {unset self(data:$col,$row)}
} else {
if [catch {set d [expr {entier($d)}]}] {set d 0}
set self(data:$col,$row) $d
callnotify setdata $row $col $self(data:$col,$row)
}
}
public method getdata {row col {d {}}} {
# get data at specified position
set r $d
catch {set r [expr {entier($self(data:$col,$row))}]}
return $r
}
public method resetdata {} {
array unset _ $w:data:*
}
public method setdata_from_array {arrayname {prefix {}}} {
set data [uplevel 1 [list array get $arrayname "${prefix}*"]]
set default_prefix "$w:data:"
if {$prefix == {}} {set prefix $default_prefix}
if {$prefix != $default_prefix} {
set data2 {}
foreach {k v} $data {
lappend data2 [regsub "^$prefix" $k $default_prefix] $v
}
set data $data2 ; unset data2
# TODO: implement setdata notify
}
array unset _ "${default_prefix}*"
array set _ $data
updatetext 0 0 end end
}
public method getdata_to_array {arrayname {prefix {}}} {
set default_prefix "$w:data:"
set data [array get _ "${default_prefix}*"]
if {$prefix == {}} {set prefix $default_prefix}
if {$prefix != $default_prefix} {
set data2 {}
foreach {k v} $data {
lappend data2 [regsub "^$default_prefix" $k $prefix] $v
}
set data $data2 ; unset data2
}
uplevel 1 [list array unset $arrayname "${prefix}*"]
uplevel 1 [list array set $arrayname $data]
}
public method copy {} {
# perform a copy of selected area
array unset _ $w:copybuf:*
set idx 0
iterateselection row col {
set self(copybuf:$idx) [getdata $row $col]
incr idx
}
set self(copybuf:start:col) $self(sel:start:col)
set self(copybuf:start:row) $self(sel:start:row)
set self(copybuf:stop:col) $self(sel:stop:col)
set self(copybuf:stop:row) $self(sel:stop:row)
}
public method delete {} {
# delete selected area
iterateselection row col {
setdata $row $col {}
}
}
public method cut {} {
# perform a cut (that is: copy & delete)
copy
delete
}
public method paste {} {
# paste data from copybuf to current position
# if selection is empty, use the copybuf dimensions
set sel_flag 0
if {![sel]} {
set sel_flag 1
setsel $self(cursor:row) $self(cursor:col) \
[expr {$self(cursor:row)+$self(copybuf:stop:row)-$self(copybuf:start:row)}] \
[expr {$self(cursor:col)+$self(copybuf:stop:col)-$self(copybuf:start:col)}]
}
set idx 0
iterateselection row col {
catch {setdata $row $col $self(copybuf:$idx)}
incr idx
}
if {$sel_flag} {
deselect
}
moveby 0 0
}
public method randomize {} {
# randomize area in selected area. usefull when testing & debugging
iterateselection row col {
set width [columnconfigure $col -width]
# TODO: use proper charset depending on column type
set charset [split {0123456789} {}]
set d {}
while {$width > 0} {
incr width -1
append d [lindex $charset [expr {int(rand()*[llength $charset])}]]
}
setdata $row $col $d
}
}
private method bindcell {row col tag} {
# re-bind events to specific cell
$self(canvas) bind $tag <ButtonPress-1> "[method_call_spec moveabs_mousewrap] $row $col"
$self(canvas) bind $tag <B1-Motion> "[method_call_spec extendsel] %x %y"
}
public method select_all {} {
setsel 0 0 [expr {$self(-rows)-1}] [expr {$self(-cols)-1}]
}
public method select_none {} {
setsel $self(cursor:row) $self(cursor:col) $self(cursor:row) $self(cursor:col)
}
public method select_row {} {
setsel $self(cursor:row) 0 $self(cursor:row) [expr {$self(-cols)-1}]
}
public method select_column {} {
setsel 0 $self(cursor:col) [expr {$self(-rows)-1}] $self(cursor:col)
}
public method keypress {ks st} {
if {[cget -state] == {readonly}} {return}
# 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 $shift { switch -- $ks {
Left {extendsel_rel 0 -1; return}
Right {extendsel_rel 0 1; return}
Up {extendsel_rel -1 0; return}
Down {extendsel_rel 1 0; return}
Home {moveabs $self(cursor:row) 0; return}
End {moveabs $self(cursor:row) -1; return}
} }
if $control { switch -- $ks {
c {copy; return}
x {cut; return}
v {paste; return}
r {randomize; return}
a {select_all; return}
u {select_none; return}
l {if $shift {select_row} else {select_column}}
} }
switch -- $ks {
Left {moveby 0 -1; return}
Right {moveby 0 1; return}
Up {moveby -1 0; return}
Down {moveby 1 0; return}
BackSpace {delete; return}
Home {moveabs 0 $self(cursor:col); return}
End {moveabs -1 $self(cursor:col); return}
Next {moveby [expr {max(4,$self(-hl2))}] 0; return}
Prior {moveby [expr {-max(4,$self(-hl2))}] 0; return}
}
uplevel 0 [list input[columnconfigure $self(cursor:col) -inputmethod] $self(cursor:row) $self(cursor:col) $ks $st]
}
private method inputnumber {row col 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} {
moveby 1 0
}
}
private method inputnumberhex {row col keysym state} {
if {![regexp -nocase -- {^[0123456789abcdef]$} $keysym]} {
return
}
set keysym "0x$keysym"
set d [getdata $row $col 0]
set width [columnconfigure $col -width]
if {$self(internal:subcol) == 0} {
set d $keysym
} else {
set d [expr {($d*16+$keysym)%(16**$width)}]
}
setdata $row $col $d
incr self(internal:subcol)
if {$self(internal:subcol) >= $width} {
moveby 1 0
}
}
private method inputnote {row col 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}]
moveby 1 0
}
private method inputsymbol {row col keysym state} {
moveby 1 0
}
private method col_from_x {x} {
# get col# from x position
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
}
private method row_from_y {y} {
# get row# from y position
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
}
private method col_to_x {col} {
# get the x position of given 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
}
private method row_to_y {row} {
# get the y position of given row#
return [expr {$row*($self(-charheight)+$self(-vspacing))}]
}
public method extendsel {_x _y} {
if {[cget -state] == {readonly}} {return}
# extend selection to specified (pixel) position (from event)
set oldsel [selstring]
clip_x_y _x _y
set self(sel:stop:col) [col_from_x $_x]
set self(sel:stop:row) [row_from_y $_y]
clipsel
set newsel [selstring]
if {$oldsel != $newsel} {uplevel 1 [notifysel]}
updatesel
}
private method extendsel_rel {drow dcol} {
set oldsel [selstring]
incr self(sel:stop:col) $dcol
incr self(sel:stop:row) $drow
clipsel
set newsel [selstring]
if {$oldsel != $newsel} {uplevel 1 [notifysel]}
updatesel
}
public method setsel {startrow startcol stoprow stopcol} {
set oldsel [selstring]
if {$stoprow == {end}} {set stoprow [expr {[cget -rows]-1}]}
if {$stopcol == {end}} {set stopcol [expr {[cget -cols]-1}]}
set self(sel:start:row) $startrow
set self(sel:start:col) $startcol
set self(sel:stop:row) $stoprow
set self(sel:stop:col) $stopcol
clipsel
set newsel [selstring]
if {$oldsel != $newsel} {uplevel 1 [notifysel]}
updatesel
}
private method notifysel {} {
callnotify selection \
$self(sel:start:row) $self(sel:start:col) \
$self(sel:stop:row) $self(sel:stop:col)
}
private method selstring {} {
return [join [list \
$self(sel:start:row) $self(sel:start:col) \
$self(sel:stop:row) $self(sel:stop:col)] ,]
}
private method clipsel {} {
# clip selection bounds based upon the current selection method
if {$self(sel:start:col) < 0} {set self(sel:start:col) 0}
if {$self(sel:start:row) < 0} {set self(sel:start:row) 0}
switch -- [cget -selectionmethod] {
rect {
if {$self(sel:stop:col) < $self(sel:start:col)} {set self(sel:stop:col) $self(sel:start:col)}
if {$self(sel:stop:row) < $self(sel:start:row)} {set self(sel:stop:row) $self(sel:start:row)}
}
text {
if {$self(sel:stop:row) < $self(sel:start:row)} {set self(sel:stop:row) $self(sel:start:row)}
if {$self(sel:stop:row) == $self(sel:start:row)} {
if {$self(sel:stop:col) < $self(sel:start:col)} {set self(sel:stop:col) $self(sel:start:col)}
}
}
}
}
private method updatesel {} {
$self(canvas) dtag sel
resetcolors
set old_row {}
iterateselection row col {
if {$row != $old_row} {
set bgcol [get_row_color backgroundsel $row]
set fgcol [get_row_color foregroundsel $row]
set old_row $row
}
$self(canvas) addtag sel withtag [item_rc_tag $row $col]
$self(canvas) itemconfigure [item_rc_tag $row $col] -fill $bgcol
$self(canvas) itemconfigure [item_rc_tag $row $col xytxt] -fill $fgcol
}
updatecursor
}
private method iterateselection {row_var_name col_var_name body} {
upvar 1 $row_var_name row
upvar 1 $col_var_name col
switch -- [cget -selectionmethod] {
rect {
for {set row $self(sel:start:row)} {$row <= $self(sel:stop:row)} {incr row} {
for {set col $self(sel:start:col)} {$col <= $self(sel:stop:col)} {incr col} {
uplevel 1 $body
}
}
}
text {
if {$self(sel:start:row) == $self(sel:stop:row)} {
set row $self(sel:start:row)
for {set col $self(sel:start:col)} {$col <= $self(sel:stop:col)} {incr col} {
uplevel 1 $body
}
} else {
set row $self(sel:start:row)
for {set col $self(sel:start:col)} {$col < $self(-cols)} {incr col} {
uplevel 1 $body
}
for {set row [expr {$self(sel:start:row)+1}]} {$row < $self(sel:stop:row)} {incr row} {
for {set col 0} {$col < $self(-cols)} {incr col} {
uplevel 1 $body
}
}
set row $self(sel:stop:row)
for {set col 0} {$col <= $self(sel:stop:col)} {incr col} {
uplevel 1 $body
}
}
}
}
}
private method isselected {row col} {
switch -- [cget -selectionmethod] {
rect {
if {$col < $self(sel:start:col) || $col > $self(sel:stop:col)} {return 0}
if {$row < $self(sel:start:row) || $row > $self(sel:stop:row)} {return 0}
return 1
}
text {
if {$row == $self(sel:start:row) && $row == $self(sel:stop:row)} {
return 0
if {$col >= $self(sel:start:col) && $col <= $self(sel:stop:col)} {
return 1
} else {
return 0
}
}
if {$row == $self(sel:start:row) && $col >= $self(sel:start:col)} {return 1}
if {$row == $self(sel:stop:row) && $col <= $self(sel:stop:col)} {return 1}
if {$row > $self(sel:start:row) && $row < $self(sel:stop:row)} {return 1}
return 0
}
default {
# trigger an error, eventually
configure -selectionmethod [cget -selectionmethod]
}
}
}
public method sel {} {
# return whether selection is set or not
if {$self(sel:start:col) != $self(sel:stop:col)} {return 1}
if {$self(sel:start:row) != $self(sel:stop:row)} {return 1}
return 0
}
public method deselect {} {
# clears current selection
set retval 0
if {$self(sel:start:col)<$self(sel:stop:col) || $self(sel:start:row)<$self(sel:stop:row)} {
set retval 1
}
set self(sel:start:col) $self(cursor:col)
set self(sel:start:row) $self(cursor:row)
set self(sel:stop:col) $self(sel:start:col)
set self(sel:stop:row) $self(sel:start:row)
uplevel 1 [notifysel]
if $retval resetcolors
return $retval
}
private method updatecolors {} {
resetcolors
updatesel
}
private method updatecursor {} {
$self(canvas) itemconfigure \
[item_rc_tag $self(cursor:row) $self(cursor:col)] \
-fill [get_row_color backgroundcur $self(cursor:row)]
$self(canvas) itemconfigure \
[item_rc_tag $self(cursor:row) $self(cursor:col) xytxt] \
-fill [get_row_color foregroundcur $self(cursor:row)]
}
public method focus {} {
# take focus (by a click, from event)
focus $w
}
private 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}]}
}
}
namespace import tracker::tracker