[Handwriting Word Recognizer] ---- [http://www.psnw.com/~alcald/sr.jpg] ---- 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 recognized 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 of a word 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 duplications of words if storing samples of thousands of words. ---- How to use * Select a user * Write the word on the text area. Must use continuous stroke. You can't lift the pen to cross a t or dot an i * If word is not recognized, type it in the box on the lower right and click the Def button then click the Save button to save the "features" to the database. * I found it takes about 10-15 repetitions of the above sequence to start getting consistent recognition of a word. * If recognized, the word will appear above the row of buttons and be appended to the accumulated sentence. * Click Erase to clear for the next word or attempt. * If the program is called from a Tk app with the name of the app and a variable as arguments, when you click the Done button, the sentence will be sent to the calling app via the send command and stored in the variable. * The Read button reads into memory the database of "features" for all the user's words that have been trained. The Save button saves the features to the disk. * The UnDef button undefines the current features fromthe word or letter in the lower right entry box. * The Output to? button sends the recognized sentence to a selected Tk app as the variable named sentence * Unsets an existing definition ---- [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 {StrokeBegin %W %x %y} bind $w {Stroke %W %x %y} bind $w {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 } proc StrokeEnd {w x y} { global stroke set n $stroke(N) msg "$n points" if {$n > 4} { # arrow at end foreach {ox oy} $stroke([expr {$n - 4}]) {break} $w create line $ox $oy $x $y -arrow last -tag segments # if enough points, and rec_type == "auto", process it # if rec type != auto will use the button on the toolbar instead. recog stroke_end } # dot at begin foreach {ox oy} $stroke(0) {break} set x [expr {$ox + 4}] set y [expr {$oy + 4}] set ox [expr {$ox - 4}] set oy [expr {$oy - 4}] $w create oval $ox $oy $x $y -fill white -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 } # # Create the toplevel interface # proc main {} { global msg char rec_type sentence user argv wm title . "Word Recognizer" # drawing surface canvas .c # label to show accumulated sentence label .l -text "recognized words" -pady 0 # row of controls frame .b # send the accumulated sentence to the text entry box from the other # program passed in as argument at startup of script # program can be called from another Tk program like this: # exec sr.tcl [tk appname] variable # where variable is the name of a variable to store the output from # the word recognizer. button .b.d -text Done -pady 0 -command { if {[lindex $argv 0] != ""} { send [lindex $argv 0] "set [lindex $argv 1] \"$sentence\"" } elseif {$output_to != ""} { send $output_to "set sentence \"$sentence\"" } exit } menubutton .b.us -text User -pady 0 -relief raised -menu .b.us.menu menu .b.us.menu .b.us.menu add radiobutton -label "Default" -variable user -value Default \ -command {.b.us config -text "Default";set ftrfile ftrs.def.$user;read_defs} .b.us.menu add radiobutton -label "Alex " -variable user -value Alex \ -command {.b.us config -text "Alex ";set ftrfile ftrs.def.$user;read_defs} .b.us.menu add radiobutton -label "Kathy " -variable user -value Kathy \ -command {.b.us config -text "Kathy ";set ftrfile ftrs.def.$user;read_defs} .b.us.menu add radiobutton -label "Becky " -variable user -value Becky \ -command {.b.us config -text "Becky ";set ftrfile ftrs.def.$user;read_defs} button .b.r -text Read -command read_defs -pady 0 button .b.s -text Save -command save_defs -pady 0 button .b.c -text Erase -command clear -pady 0 button .b.u -text Unset -command unset_def -pady 0 button .b.f -text UnDef -command undef_char -pady 0 button .b.t -text Def -command set_def -pady 0 # menu for selecting Tk app to send the output to using the Tk "send" command # the output will go to where the current focus is in the application menubutton .b.output -text "Output to?" -relief raised -pady 0 -menu .b.output.menu menu .b.output.menu foreach app [winfo interps] { .b.output.menu add radiobutton -label $app -variable output_to } # if not called with an argument that gives a variable or list into which the output # can be sent, the menubutton that enables selecting an app. can be used. If # arguments are passed in, disable the button. if {$argv != "" } { .b.output configure -state disabled } # make it so you can turn off recognition until later if desired # was hoping add feature where you could collect more than one # stroke like for the dot on the i or the cross on the t but not # implemented yet. set rec_type auto menubutton .b.rec_type -text "Rec.?" -pady 0 -menu .b.rec_type.menu -relief raised menu .b.rec_type.menu .b.rec_type.menu add radiobutton -label "At end of strokes" -variable rec_type -value auto .b.rec_type.menu add radiobutton -label "When recog button clicked" \ -variable rec_type -value stroke_end button .b.rec -text Recog -command "recog button" -pady 0 entry .b.e -width 20 -textvariable char bind .b.e {set_def} label .b.msg -textvariable msg -width 20 pack .b.d .b.us .b.output .b.rec_type .b.r .b.s .b.c .b.u .b.f .b.rec .b.t .b.e \ -side left -fill x pack .b.msg -side right -fill x -expand 1 # buttons along the bottom, canvas fills remainder pack .b -side bottom -fill x pack .c -side top -fill both -expand 1 for {set x 0} {$x < 850} {incr x 10} { if {[expr $x % 20] == "0"} { .c create line $x 75 [expr $x + 10] 75 -width 1 -fill black } } .c create line 0 150 850 150 -width 3 -fill black # setup stroke collector StrokeInit .c pack .l -side top -fill x return } frame .set_user pack .set_user wm geometry . +200+400 label .set_user.label -text "Plese select user. Each can\n have their own recog file." menubutton .set_user.button -text "OK" -relief raised -indicatoron true -menu .set_user.button.menu menu .set_user.button.menu .set_user.button.menu add radiobutton -label "Default" -variable user -value Default .set_user.button.menu add radiobutton -label "Alex " -variable user -value Alex .set_user.button.menu add radiobutton -label "Kathy " -variable user -value Kathy .set_user.button.menu add radiobutton -label "Becky " -variable user -value Becky pack .set_user.label .set_user.button tkwait variable user destroy .set_user # initialize a variable to hold a "sentence" made up of the recognized words # for the session. That value can be exported to another program. set sentence "" set ftrfile ftrs.def.$user main # adjust length of text on user button so the GUI doesn't resize every time you change # users set labeltext [set user] for {set x 0} {$x < [expr 7 - [string length $user]]} {incr x} { append labeltext " " } .b.us config -text "$labeltext" read_defs