[FF] 2007-05-26 - This widget has various uses. Check the [Widget Hiding as opposed to Widget Overloading] page for an overview.
----
 #!/usr/bin/env wish

 #######################################################################
 #
 # TrackerWidget
 # written by Federico Ferri - 2007
 #
 #######################################################################
 #
 # 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.
 #
 #######################################################################
 #
 # Developer documntation - widget procs:
 #
 # tracker {w args}
 #     widget constructor, calls tracker_init
 # tracker_callback {w command {args {}}}
 #     callback proc for dispatching commands
 # tracker_xy {x y {prefix xy}}
 #     generate tag index for individual cells by column/row
 #     $prefix default to xy (but text has xytxt prefix)
 # tracker_init {w}
 #     init: creates rectangles on the canvas
 # tracker_move {w dx dy}
 #     move cursor relative to current position, by $dx,$dy
 # tracker_setdata {w row col d}
 #     set data to cell specified by $row,$col
 #     data is kept in $tracker_struct($w:data:$col,$row)
 # tracker_getdata {w row col {d {}}}
 #     read data
 #     returns $d if data doesn0t exists
 # tracker_copy {w}
 #     copy selected area to clipboard
 # tracker_delete {w}
 #     delete selected area
 # tracker_cut {w}
 #     combination of copy & delete
 # tracker_paste {w}
 #     paste data from clipboard, starting at current cursor position
 # tracker_bindcell {w row col tag}
 #     this gets called internally, when a text is added to canvas
 # tracker_keypress {w ks st}
 #     very first keypress handler; it calls tracker_inputdata
 # tracker_inputdata {w col row keysym state}
 #     this handles multi-character input for one cell
 #     you can hook up your favorite input method instead of this proc
 # tracker_moveabs {w mx my}
 #     move cursor to absolute position specified by $mx,$my
 # tracker_col_from_x {w x}
 #     map x coordinate to column number
 # tracker_row_from_y {w y}
 #     map y coordinate to row number
 # tracker_col_to_x {w col}
 #     map column number to x coordinate
 # tracker_row_to_y {w row}
 #     map row number to y coordinate
 # tracker_extendsel {w _x _y}
 #     called while dragging mouse for selecting areas
 # tracker_deselect {w}
 #     (visually) clear selection
 # tracker_focus {w}
 #     take keyboard focus
 #
 #######################################################################

 proc tracker {w args} {
	global tracker_struct

	# set default options
	set tracker_struct($w:-rows) 16
	set tracker_struct($w:-cols) 6
	set tracker_struct($w:-colchars) [list]
	set tracker_struct($w:-spacing) 4
	set tracker_struct($w:-background) ""
	set tracker_struct($w:-foreground) "black"
	set tracker_struct($w:-backgroundsel) "yellow"
	set tracker_struct($w:-foregroundcur) "white"
	set tracker_struct($w:-backgroundcur) "black"

	# parse options
	set valid_opts {-spacing -rows -cols -background -foreground -backgroundsel -colchars}
	foreach {opt val} $args {
		if {[lsearch -exact $valid_opts $opt] == -1} {
			return -code error -errorinfo \
				"tracker($w): unknown option: $opt"
		} else {
			set tracker_struct($w:$opt) $val
		}
	}
	# col chars other than 1?
	if {[llength $tracker_struct($w:-colchars)] == 0} {
		lappend tracker_struct($w:-colchars) 1
	}
	set cclen [llength $tracker_struct($w:-colchars)]
	for {set i $cclen} {$i < $tracker_struct($w:-cols)} {incr i} {
		lappend tracker_struct($w:-colchars) \
		 [lindex $tracker_struct($w:-colchars) [expr $i%$cclen]]
	}
	set tracker_struct($w:font) \
	 [font create -family Courier -size 10 \
	 -weight bold -slant roman -underline false -overstrike false]
	set tracker_struct($w:font:-ascent) [font metrics $tracker_struct($w:font) -ascent]
	set tracker_struct($w:font:-descent) [font metrics $tracker_struct($w:font) -descent]
	set tracker_struct($w:font:-linespace) [font metrics $tracker_struct($w:font) -linespace]
	set tracker_struct($w:font:-width) [font measure $tracker_struct($w:font) m]
	set tracker_struct($w:-charwidth) $tracker_struct($w:font:-width)
	set tracker_struct($w:-charheight) $tracker_struct($w:font:-linespace)
	set tracker_struct($w:-width) [expr $tracker_struct($w:-cols)*\
	 ($tracker_struct($w:-spacing)+$tracker_struct($w:-charwidth))]
	set tracker_struct($w:-height) [expr $tracker_struct($w:-rows)*\
	 ($tracker_struct($w:-spacing)+$tracker_struct($w:-charheight))]
	set c [canvas $w \
		-width      [expr [tracker_col_to_x $w $tracker_struct($w:-cols)]-1]\
		-height     [expr [tracker_row_to_y $w $tracker_struct($w:-rows)]-1]\
		-takefocus  1]
	rename $c ${w}_canvas
	set tracker_struct($w:canvas) ${w}_canvas
	set tracker_struct($w:window) $w

	set tracker_struct($w:cursor:x) 0
	set tracker_struct($w:cursor:y) 0

	set tracker_struct($w:sel:start:x) 0
	set tracker_struct($w:sel:start:y) 0
	set tracker_struct($w:sel:stop:x) 0
	set tracker_struct($w:sel:stop:y) 0

	set tracker_struct($w:internal:subcol) 0

	# setup callback proc
	proc $w args "return \[eval tracker_callback $w \$args\]"

	if [tracker_init $w] {
		return $c
	} else {
		return -code error -errorinfo \
			"tracker($w): init failed"
	}
 }

 proc tracker_callback {w command {args {}}} {
	# dispatch command, if it exists
	global tracker_struct
	if {[llength [info procs tracker_$command]] > 0} {
		return [eval tracker_$command $w $args]
	} else {
		return -code error -errorinfo \
			"tracker($w): no such command: $command"
	}
 }

 proc tracker_xy {x y {prefix xy}} {
	# make an xy tag index
	return "${prefix}_${x}_${y}"
 }

 proc tracker_init {w} {
	# initialize tracker, canvas items
	global tracker_struct
	set rh $tracker_struct($w:-charheight)
	set rx 1
	for {set x 0} {$x < $tracker_struct($w:-cols)} {incr x} {
		set rw [expr $tracker_struct($w:-charwidth)*[lindex $tracker_struct($w:-colchars) $x]]
		set ry 1
		for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} {
			$tracker_struct($w:canvas) create rectangle \
				$rx $ry [expr $rx+$rw] [expr $ry+$rh] \
				-fill $tracker_struct($w:-background) \
				-outline {} \
				-tags [list bg [tracker_xy $x $y]]
			tracker_bindcell $w $y $x [tracker_xy $x $y]
			incr ry [expr $rh+$tracker_struct($w:-spacing)]
		}
		incr rx [expr $rw+$tracker_struct($w:-spacing)]
	}
	bind $tracker_struct($w:window) <KeyPress> "tracker_keypress $w %K %s"
	bind $tracker_struct($w:window) <ButtonPress-1> "focus $w"
	tracker_move $w 0 0
	return 1
 }

 proc tracker_move {w dx dy} {
	# move cursor by relative amount dx dy, wrap if needed
	global tracker_struct
	$tracker_struct($w:canvas) itemconfigure bg -fill {}
	incr tracker_struct($w:cursor:x) $dx
	incr tracker_struct($w:cursor:y) $dy
	if {$tracker_struct($w:cursor:x) < 0} {
		incr tracker_struct($w:cursor:x) $tracker_struct($w:-cols)
	}
	if {$tracker_struct($w:cursor:y) < 0} {
		incr tracker_struct($w:cursor:y) $tracker_struct($w:-rows)
	}
	set tracker_struct($w:cursor:x) \
	 [expr $tracker_struct($w:cursor:x) %$tracker_struct($w:-cols)]
	set tracker_struct($w:cursor:y) \
	 [expr $tracker_struct($w:cursor:y) %$tracker_struct($w:-rows)]
	$tracker_struct($w:canvas) itemconfigure bg -fill $tracker_struct($w:-background)
	$tracker_struct($w:canvas) itemconfigure txt -fill $tracker_struct($w:-foreground)
	$tracker_struct($w:canvas) itemconfigure \
	 [tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y)] \
	 -fill $tracker_struct($w:-backgroundcur)
	$tracker_struct($w:canvas) itemconfigure \
	 [tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y) xytxt] \
	 -fill $tracker_struct($w:-foregroundcur)
	tracker_deselect $w
	set tracker_struct($w:internal:subcol) 0
 }

 proc tracker_setdata {w row col d} {
	# change data at specified position
	global tracker_struct
	set coords [$tracker_struct($w:canvas) coords [tracker_xy $col $row]]
	set tag [tracker_xy $col $row xytxt]
	$tracker_struct($w:canvas) delete $tag
	set x [expr [lindex $coords 0]]
	set y [expr [lindex $coords 1]]
	set tracker_struct($w:data:$col,$row) \
	 [string range $d 0 [expr [lindex $tracker_struct($w:-colchars) $col]-1]]
	if {$row == $tracker_struct($w:cursor:y) && $col == $tracker_struct($w:cursor:x)} {
		set fill $tracker_struct($w:-foregroundcur)
	} else {
		set fill $tracker_struct($w:-foreground)
	}
	$tracker_struct($w:canvas) create text $x $y -tags [list $tag txt] \
	 -text $tracker_struct($w:data:$col,$row) -font tracker_struct($w:font) \
	 -fill $fill -anchor nw
	tracker_bindcell $w $row $col $tag
 }

 proc tracker_getdata {w row col {d {}}} {
	# get data at specified position
	global tracker_struct
	set r $d
	catch {set r $tracker_struct($w:data:$col,$row)}
	return $r
 }

 proc tracker_copy {w} {
	# perform a copy of selected area
	global tracker_struct
	for {set ty $tracker_struct($w:sel:start:y); set by 0} \
	 {$ty < $tracker_struct($w:sel:stop:y)} {incr ty; incr by} {
		for {set tx $tracker_struct($w:sel:start:x); set bx 0} \
		 {$tx < $tracker_struct($w:sel:stop:x)} {incr tx; incr bx} {
			catch {
				set tracker_struct($w:copybuf:$bx,$by) \
				 $tracker_struct($w:data:$tx,$ty)
			}
		}
	}
	set tracker_struct($w:copybuf:w) $bx
	set tracker_struct($w:copybuf:h) $by
 }

 proc tracker_delete {w} {
	# delete selected area
	global tracker_struct
	for {set ty $tracker_struct($w:sel:start:y)} \
	 {$ty < $tracker_struct($w:sel:stop:y)} {incr ty} {
		for {set tx $tracker_struct($w:sel:start:x)} \
		 {$tx < $tracker_struct($w:sel:stop:x)} {incr tx} {
			$tracker_struct($w:canvas) delete [tracker_xy $tx $ty xytxt]
			unset tracker_struct($w:data:$tx,$ty)
		}
	}
 }

 proc tracker_cut {w} {
	# perform a cut (that is: copy & delete)
	tracker_copy $w
	tracker_delete $w
 }

 proc tracker_paste {w} {
	# paste data from copybuf to current position
	global tracker_struct
	set py $tracker_struct($w:cursor:y)
	for {set by 0} {$by < $tracker_struct($w:copybuf:h)} {incr by; incr py} {
		set px $tracker_struct($w:cursor:x)
		for {set bx 0} {$bx < $tracker_struct($w:copybuf:w)} {incr bx; incr px} {
			catch {
				tracker_setdata $w $py $px $tracker_struct($w:copybuf:$bx,$by)
			}
		}
	}
	tracker_move $w 0 0
 }

 proc tracker_bindcell {w row col tag} {
	# re-bind events to specific cell
	global tracker_struct
	$tracker_struct($w:canvas) bind $tag <ButtonPress-1> "tracker_moveabs $w $col $row"
	$tracker_struct($w:canvas) bind $tag <B1-Motion> "tracker_extendsel $w %x %y"
 }

 proc tracker_keypress {w ks st} {
	# handle global (canvas) keypress (from event)
	global tracker_struct
	switch $ks {
		Left {tracker_move $w -1 0; return}
		Right {tracker_move $w 1 0; return}
		Up {tracker_move $w 0 -1; return}
		Down {tracker_move $w 0 1; return}
	}
	if {[expr $st & 0x4] > 0} {
		switch $ks {
			c {tracker_copy $w; return}
			x {tracker_cut $w; return}
			v {tracker_paste $w; return}
		}
	}
	if {[regexp -nocase -- {^[0123456789abcdef]$} $ks]} {
		set ret [tracker_inputdata $w \
		 $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y) $ks $st]
		return $ret
	}
 }

 proc tracker_inputdata {w col row keysym state} {
	# keypresses relate to data input are sent here (from tracker_keypress)
	# here is handled multi-digit cell input
	# you can override with your own input method
	global tracker_struct
	set colch  [lindex $tracker_struct($w:-colchars) $col]
	set subcol $tracker_struct($w:internal:subcol)
	set default [string repeat 0 $colch]
	set nd [lreplace [lrange \
	 [split [tracker_getdata $w $row $col $default] {}] \
	 0 [expr $colch-1]\
	 ] $subcol $subcol $keysym]
	set nd [join $nd {}]
	tracker_setdata $w $row $col $nd
	incr tracker_struct($w:internal:subcol)
	if {$tracker_struct($w:internal:subcol) >= $colch} {
		tracker_move $w 0 1
	}
 }

 proc tracker_moveabs {w mx my} {
	# move cursor to absolute position
	global tracker_struct
	set tracker_struct($w:cursor:x) $mx
	set tracker_struct($w:cursor:y) $my
	tracker_move $w 0 0
	set tracker_struct($w:sel:start:x) $mx
	set tracker_struct($w:sel:start:y) $my
	set tracker_struct($w:sel:stop:x) $mx
	set tracker_struct($w:sel:stop:y) $my
	tracker_deselect $w
 }

 proc tracker_col_from_x {w x} {
	global tracker_struct
	set curcol 0
	set xlim 0
	while {$curcol < $tracker_struct($w:-cols)} {
		incr xlim [expr ($tracker_struct($w:-charwidth)+$tracker_struct($w:-spacing))*\
		 [lindex $tracker_struct($w:-colchars)) $curcol]]
		incr curcol
		if {[expr $x-$tracker_struct($w:-charwidth)/2] < $xlim} {return $curcol}
	}
	return -1
 }

 proc tracker_row_from_y {w y} {
	global tracker_struct
	set currow 0
	set ylim 0
	while {$currow < $tracker_struct($w:-rows)} {
		incr ylim [expr ($tracker_struct($w:-charheight)+$tracker_struct($w:-spacing))]
		incr currow
		if {[expr $y-$tracker_struct($w:-charheight)/2] < $ylim} {return $currow}
	}
	return -1
 }

 proc tracker_col_to_x {w col} {
	global tracker_struct
	set x 0
	set li 0
	while {$col >= 0} {
		incr x [expr ($tracker_struct($w:-charwidth)*\
		 [lindex $tracker_struct($w:-colchars) $li])+\
		 $tracker_struct($w:-spacing)]
		incr li
		if {$li >= [llength $tracker_struct($w:-colchars)]} {
			return $x
		}
	}
	return $x
 }

 proc tracker_row_to_y {w row} {
	global tracker_struct
	return [expr $row*($tracker_struct($w:-charheight)+$tracker_struct($w:-spacing))]
 }

 proc tracker_extendsel {w _x _y} {
	# extend selection to specified position (from event)
	global tracker_struct
	set mx [tracker_col_from_x $w $_x]
	set my [tracker_row_from_y $w $_y]
	set tracker_struct($w:sel:stop:x) $mx
	set tracker_struct($w:sel:stop:y) $my
	$tracker_struct($w:canvas) dtag sel
	for {set ty $tracker_struct($w:sel:start:y)} {$ty < $tracker_struct($w:sel:stop:y)} {incr ty} {
		for {set tx $tracker_struct($w:sel:start:x)} {$tx < $tracker_struct($w:sel:stop:x)} {incr tx} {
			$tracker_struct($w:canvas) addtag sel withtag [tracker_xy $tx $ty]
		}
	}
	$tracker_struct($w:canvas) itemconfigure bg -fill $tracker_struct($w:-background)
	$tracker_struct($w:canvas) itemconfigure sel -fill $tracker_struct($w:-backgroundsel)
	$tracker_struct($w:canvas) itemconfigure \
	 [tracker_xy $tracker_struct($w:cursor:x) $tracker_struct($w:cursor:y)] \
	 -fill $tracker_struct($w:-backgroundcur)
 }

 proc tracker_deselect {w} {
	# clears current selection
	global tracker_struct
	set tracker_struct($w:sel:stop:x) $tracker_struct($w:sel:start:x)
	set tracker_struct($w:sel:stop:y) $tracker_struct($w:sel:start:y)
 }

 proc tracker_focus {w} {
	# take focus (by a click, from event)
	focus $w
 }
----
[[ [Category Widget] ]]