[FF] 2007-05-20 - Today a little problem came to me, and quicly found a solution. Many thanks to tclers guys. Issue was: encapsulating and hiding the interface of a widget, instead of just overloading/extending it Practical application: this widget actually does nothing useful, but it does pretty nice, and maybe it can be useful to rip off the concept (though I could clean it up a bit) ''I'm not used to put many comments... proc names this time should be auto-explanatory! O;)'' ---- ====== #!/usr/bin/env wish proc tracker {w args} { global tracker_struct # set default options set tracker_struct($w:-width) 500 set tracker_struct($w:-height) 300 set tracker_struct($w:-rows) 16 set tracker_struct($w:-cols) 6 set tracker_struct($w:-spacing) 3 # parse options set valid_opts {-width -height -rows -cols} 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 } } set c [canvas $w \ -width $tracker_struct($w:-width) \ -height $tracker_struct($w:-height) \ -takefocus 1] rename $c ${w}_canvas set tracker_struct($w:canvas) ${w}_canvas set tracker_struct($w:window) $w 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:cursor:x) 0 set tracker_struct($w:cursor:y) 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 {}}} { 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_init {w} { global tracker_struct for {set y 0} {$y < $tracker_struct($w:-rows)} {incr y} { for {set x 0} {$x < $tracker_struct($w:-cols)} {incr x} { set rw $tracker_struct($w:-charwidth) set rh $tracker_struct($w:-charheight) set rx [expr 1+$x*($rw+$tracker_struct($w:-spacing))] set ry [expr 1+$y*($rh+$tracker_struct($w:-spacing))] $tracker_struct($w:canvas) create rectangle \ $rx $ry [expr $rx+$rw] [expr $ry+$rh] \ -fill {} -outline black \ -tags [list bg xy$x$y] } } bind $tracker_struct($w:window) "tracker_keypress $w %K" bind $tracker_struct($w:window) "focus $w" tracker_move $w 0 0 return 1 } proc tracker_move {w dx dy} { 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)] set xy $tracker_struct($w:cursor:x)$tracker_struct($w:cursor:y) $tracker_struct($w:canvas) itemconfigure xy$xy -fill black } proc tracker_keypress {w ks} { #puts "[lindex [info level 0] 0]: $w $ks" switch $ks { Left {tracker_move $w -1 0} Right {tracker_move $w 1 0} Up {tracker_move $w 0 -1} Down {tracker_move $w 0 1} } } pack [tracker .t -width 400 -height 400] ====== <> Widget