[Handwriting Word Recognizer]
----
[http://www.psnw.com/~alcald/sr.jpg]
----
'''Under Construction'''
----
This a modification of the "Mouse-stroke character recognizer" by Mike Hall
which in turn borrows code from several other sources.

I am working on a medical records application for doctors. I was intrigued
by handwriting recognition, especially where the application can be trained
to read the average physician's human unreadable, but never the less 
consistent chicken scratch. Illegible handwriting is a big problem in the
medical field.  

I was intrigued by the tablet PC's possible impact on the medical field but
was dismayed to find that the HWR that comes with Windows on the tablet PC 
could not be trained to recognized chicken scratch.  It has a large library
of data to compare the user's handwriting against, but it must be fairly 
legible to have acceptable accuracy. I wanted something that could be trained.

Basically, I added more cells to the mouse stroke recognizer so that it can now
recognize a whole word at a time instead of just one letter. The recoganized 
words are accumulated into a "sentence" that can be output to the app that
calls the program using the Tk send command. 

I have tried this on Linux using an Aiptek  hyperpen tablet and it works 
amazingly well once you get enough samples. It takes about 10 - 15 samples
before you get consitent recognition. I have not tested it with a large number
of words in it's database. It might get slow or start getting more duplicatons
of workds if storing samples of thousands of words.  
----
[Alex Caldwell] M.D.
----

 #!/usr/local/bin/wish8.4

 #
 #	Mouse-stroke character recognizer,
 #	major pieces stolen from other sources.
 #	Mike Hall, mghall@enteract.com, 2000-12-23
 #

 #
 #	mouse stroke collector, from page 484 of
 #	Practical Programming in Tcl/Tk, Third Edition, 2000, Brent Welch
 #


 #  Modified by Alex Caldwell to try to allow recognizing whole words instead of
 #  characters.
 #
 #      I Mainly increased the number of cells to 25 which seems to increase the
 #   accuracy,  but it now takes more training for each word before recognition
 #   gets consistent.
 #
 #     It seems to work surprisingly well, but might  get slow with a
 #   very large collection of words in the ftrs array.
 #
 #     Allow multiple users to have their own features file
 #
 #   Collect the recognized words into "sentence" that can be output
 #   to stdout or to another program - in this case using the Tk send command.
 #
 #     Added some lines to canvas like on school composition paper to help keep your
 #   handwriting more consistent. It works well with a Cirque glidepoint mouse or an
 #   Aiptek hyperpen pointing device.
 #
 #   alcald@psnw.com 12/21/2002

 # sets up bindings on the canvas to collect mouse strokes. Could be used on other
 # canvases too.

 proc StrokeInit {w} {
    bind $w <Button-1>	  {StrokeBegin	%W %x %y}
    bind $w <B1-Motion>	  {Stroke	%W %x %y}
    bind $w <ButtonRelease-1> {StrokeEnd	%W %x %y}
    return
 }

 

 proc StrokeBegin {w x y} {
    global stroke
    catch {unset stroke}
    # stroke(N) holds the no of points
    set stroke(N) 0
    # stroke(0) holes the coordin. of first point?
    set stroke(0) [list $x $y]
    msg "1 point ..."
    return
 }


 proc Stroke {w x y} {
    global stroke
    
    # get last point
    set n $stroke(N)
    foreach {ox oy} $stroke($n) {break}
    
    # filter? abs(dx) + abs(dy) > threshold
    
    # install latest point
    incr n
    set stroke(N) $n
    set stroke($n) [list $x $y]
    puts "$stroke($n)"
    msg "$n points ..."
    
    #puts "[lsort [array get stroke]]"
    
    # draw latest segment
    $w create line $ox $oy $x $y -width 2 -tag segments
    return
 }



 #
 #	Get min/max x/y values of the stroke
 #
 proc get_min_max { } {
    global stroke
    global xl xh yl yh x1 x2 y1 y2 x3 y3 x4 y4
    
    # initialize from first point
    foreach {xl yl} $stroke(0) {break}
    set xh $xl
    set yh $yl
    
    # adjust from remaining data
    set n $stroke(N)
    for {set i 1} {$i <= $n} {incr i} {
        foreach {x y} $stroke($i) {break}
        if {$x < $xl} {
            set xl $x
        } elseif {$x > $xh} {
            set xh $x
        }
        if {$y < $yl} {
            set yl $y
        } elseif {$y > $yh} {
            set yh $y
        }
    }
    
    # divide the box in thirds each way (25 sub boxes)
    set x1 [expr {$xl + ($xh - $xl)/5.}]
    set y1 [expr {$yl + ($yh - $yl)/5.}]
    set x2 [expr {$xl + 2.*($xh - $xl)/5.}]
    set y2 [expr {$yl + 2.*($yh - $yl)/5.}]
    set x3 [expr {$xl + 3.*($xh - $xl)/5.}]
    set y3 [expr {$yl + 3.*($yh - $yl)/5.}]
    set x4 [expr {$xl + 4.*($xh - $xl)/5.}]
    set y4 [expr {$yl + 4.*($yh - $yl)/5.}]
    # check aspect (for vertical and horizontal strokes)
    set dx [expr {abs($xh - $xl)}]
    set dy [expr {abs($yh - $yl)}]
    set thresh 6.0
    if {$dy > [expr {$thresh * $dx}]} {
        # vertical
        set x1 $xl
        set x2 $xh
        
    } elseif {$dx > [expr {$thresh * $dy}]} {
        # horizontal
        set y1 $yl
        set y2 $yh
    }
    
    return
 }



 #
 #	Display the box outline and the interior dividers
 #
 proc show_boxes { } {
    global stroke
    global xl xh  yl yh  x1 x2  y1 y2  x3 y3  x4 y4
    
    # enclosing box
    .c create rectangle [expr {$xl-1}] [expr {$yl-1}]  \
            [expr {$xh+1}] [expr {$yh+1}] -tags boxes -outline blue
    
    # interior crossing lines
    .c create line $xl $y1 $xh $y1 -tags boxes -fill red
    .c create line $xl $y2 $xh $y2 -tags boxes -fill red
    .c create line $xl $y3 $xh $y3 -tags boxes -fill red
    .c create line $xl $y4 $xh $y4 -tags boxes -fill red
    .c create line $x1 $yl $x1 $yh -tags boxes -fill red
    .c create line $x2 $yl $x2 $yh -tags boxes -fill red
    .c create line $x3 $yl $x3 $yh -tags boxes -fill red
    .c create line $x4 $yl $x4 $yh -tags boxes -fill red
    # label showing no of points in the stroke on upper left of enclosing box
    .c create text $xl $yl -text "$stroke(N)" -anchor sw -fill blue \
            -tags boxes
    return
 }


 #
 #	Convert from x/y coordinates to cell-values in the box
 #
 #	Normal		XOR crossings
 #
 #	0  1  2	 3  4	       0  1  3  5  7
 #	5  6  7	 8  9	       8  9  11 13 15
 #	10 11 12 13 14		    16 17 19 21 23
 #   15 16 17 18 19      24 25 27 29 31
 #   20 21 22 23 24      32 33 35 37 39

 proc cell_value {x y} {
    global x1 x2 y1 y2 x3 y3 x4 y4
    
    # get cell value for x coordinate
    if {$x < $x1} {
        set xv 0
    } elseif {$x <= $x2} {
        set xv 1
    } elseif {$x <= $x3} {
        set xv 2
    } elseif {$x <= $x4} {
        set xv 3
    } else {
        set xv 4
    }
    
    # get cell value for y coordinate
    if {$y < $y1} {
        set yv 0
    } elseif {$y <= $y2} {
        set yv 4
    } elseif {$y <= $y3} {
        set yv 12
    } elseif {$y <= $y4} {
        set yv 24
    } else {
        set yv 32
    }
    
    # overall cell value
    return [expr {$xv + $yv}]
 }



 #
 #	Reset crossing counts
 #
 proc init_crossing { } {
    global crosses
    foreach x {1 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 N} {
        set crosses($x) 0
    }
    return
 }

 #
 #	Track line-crossing counts from old-cell to new-cell
 #
 proc crossing {old new} {
    global crosses
    incr crosses(N)
    set cn [expr {$new ^ $old}]
    foreach bit {1 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32} {
        if {$cn & $bit} {
            incr crosses($bit)
        }
    }
    return
 }

 #
 #	Convert strokes to list of cells
 #

 proc box_cells { } {
    global stroke
    global cells
    
    # setup
    catch {unset cells}
    init_crossing
    
    # start first point
    foreach {x y} $stroke(0) {break}
    set ocv [cell_value $x $y]
    set cells $ocv
    puts "\$ocv == $ocv"
    # convert rest of points
    set n $stroke(N)
    for {set i 1} {$i <= $n} {incr i} {
        foreach {x y} $stroke($i) {break}
        set cv [cell_value $x $y]
        if {$cv != $ocv} {
            # new cell, accumulate
            lappend cells $cv
            # track line crossings
            crossing $ocv $cv
            # new current cell value
            set ocv $cv
        }
    }
    return
 }


#
#	Construct the resulting set of features
#		- first cell, last cell
#		- last crossing, last crossing
#		- four crossing counts (2 x-axis, 2 y-axis)
#
proc ftr { } {
    global cells
    puts "cells == $cells"
    global crosses
    puts "crosses == [array get crosses]"
    
    set c0 [lindex $cells 0]
    set c1 [lindex $cells 1]
    set cn [lindex $cells end]
    set cp [lindex $cells [expr {[llength $cells]-2}]]
    
    set d1 [expr {$c0 ^ $c1}]
    set dn [expr {$cn ^ $cp}]
    
    return "$c0 $cn $d1 $dn $crosses(1) $crosses(2) $crosses(4) $crosses(6) $crosses(8) \
    $crosses(10) $crosses(12) $crosses(14) $crosses(16) $crosses(18) $crosses(20) \
    $crosses(22) $crosses(24) $crosses(26) $crosses(28) $crosses(30) $crosses(32)"
}

 proc show_ftr {f} {
    global xl xh yl yh
    global cells
    global sentence
    .c create text $xl $yh -text $f -anchor nw -fill red -tags boxes
    set x [match $f]
    if {$x == ""} {
        set x unk
    }
    set x "[llength $cells] $x"
    puts "Cells == $cells"
    
    msg $x
    .c create text $xh $yl -text "$x" -anchor se -fill purple -tags boxes
    if {[lindex $x 1] != "unk"} {
        bell;bell
        append sentence "[lindex $x 1] "
        puts $sentence
        .l configure -text "$sentence"
        update idletasks
        #This will convert text to speech if you have ViaVoice
        catch {
            exec /usr/lib/ViaVoiceOutloud/samples/cmdlinespeak/cmdlinespeak \
           "I recognized the word [lindex $x 1]"
            exec /usr/lib/ViaVoiceOutloud/samples/cmdlinespeak/cmdlinespeak \
           "Your complete sentence now reads: $sentence"
        } mistake
        if [info exists mistake] {
            if [regexp "no such file or directory" $mistake] {
                puts "You don't have speach enabled on your system"
                puts "\$mistake == $mistake"
            } else {
                puts "You seem to have Via Voice installed - that is good"
            }
        }
    } else {
        update idletasks
        puts "I'm sorry, I don't recognise that word."
        catch {
            exec /usr/lib/ViaVoiceOutloud/samples/cmdlinespeak/cmdlinespeak "I'm sorry,
 I don't understand that word. You can train me by typing it
 in the box and then click the def button."
            
        } mistake
        if [info exists mistake] {
            if [regexp "no such file or directory" $mistake] {
                puts "You don't have speach enabled on your system"
                puts "\$mistake == $mistake"
            } else {
                puts "You seem to have Via Voice installed - that is good!"
            }
        }
        
    }
    return
 }

 #
 #	Recognize the stroke
 #	Leeden recognizer, from page 204 of
 #	Principles of Interactive Computer Graphics 2nd ed, 1979, Newman+Sproull
 #
 proc recog {from} {
    global rec_type
    
    get_min_max
    show_boxes
    box_cells
    if {$rec_type == "auto" && $from == "stroke_end"} {
        set f [ftr]
        puts "\$f == $f"
        show_ftr $f
    } elseif {$rec_type == "stroke_end" && $from == "button"} {
        set f [ftr]
        show_ftr $f
    }
    return
 }

 #
 #	Clear the canvas, prepare for another run
 #
 proc clear { } {
    global stroke
    .c delete segments
    .c delete boxes
    unset stroke
    return
 }

 #
 #	Update the log message
 #
 proc msg {x} {
    global msg
    set msg $x
    return
 }

 #
 #	Lookup this stroke's features
 #
 proc match {f} {
    global ftrs
    
    if {[info exists ftrs($f)]} {
        return $ftrs($f)
    } else {
        return ""
    }
 }

 #
 #	Set a new definition
 #
 proc set_def { } {
    global ftrs char
    
    set f [ftr]
    set x [match $f]
    if {$x != ""} {
        msg "Conflict: $ftrs($f) and $char"
    } else {
        set ftrs($f) $char
        msg "set $char"
    }
    return
 }



 #
 #	Unset an existing definition
 #
 proc unset_def { } {
    global ftrs
    
    set f [ftr]
    if {[info exists ftrs($f)]} {
        set x $ftrs($f)
        msg "Erasing $x $f"
        unset ftrs($f)
    }
    return
 }

 #
 #	Unset all definitions for a word
 #
 proc undef_char { } {
    global ftrs char
    foreach f [array names ftrs] {
        if {$ftrs($f) == $char} {
            unset ftrs($f)
        }
    }
    return
 }

 #
 #	Read the features
 #
 proc read_defs { } {
    global ftrs
    global ftrfile
    
    if {[catch {open $ftrfile r} fid] == 0} {
        while {[gets $fid line] > 0} {
            set ftrs([lrange $line 1 end]) [lindex $line 0]
        }
        close $fid
        msg "read [array size ftrs] entries"
    } else {
        msg "No ftrs file"
    }
    return
 }

 #
 #	Save the defined features
 #
 proc save_defs { } {
    global ftrs
    global ftrfile
    
    if {[catch {open $ftrfile w} fid] == 0} {
        foreach {k v} [array get ftrs] {
            # escape some special characters
            if {[string match {[\{\[\" ]} $v]} {
                puts $fid "\\$v $k"
            } else {
                puts $fid "$v $k"
            }
        }
        close $fid
    }
    msg "saved [array size ftrs] entries"
    return
 }