Version 3 of Handwriting Word Recognizer

Updated 2003-06-12 05:50:26

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, [email protected], 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.
 #
 #   [email protected] 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
 }


 #
 #        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 <Return> {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