#!/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) <KeyPress> "tracker_keypress $w %K"
        bind $tracker_struct($w:window) <ButtonPress-1> "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]