#=======================================================================
#  JANUS-SR   Janus Speech Recognition Toolkit
# ----------------------------------------------------------
#  Author  :  Matthias und Roald
#  Module  :  align.tcl
#  Date    :  30.10.97
#
#  Remarks :  Computes word error rate of a hypothesis against a
#             reference utterance, using DTW (Viterbi) algorithm.
#
#======================================================================

# The return value is a list of the following form:
#   {errorRate numErrors alignList errorList}
# errorList contains for every word of the hypothesis the error(s)
# detected between this word and its predecessor:
#   d# : # deletions
#   i  : insertion
#   s  : substitution
#   -  : no error
# Note that d# may be combined with s,-: d#s => # deletions, followed by a
# subst. d#- => # deletions, followed by correct word.
# Note that there may be more than one possible best alignments, but  
# only
# one of these is returned.
# Note that the reference as well as the hypothesis must contain at least
# one word!

proc wordErrorRate {reference hypothesis} {
    ;# note that START and END also belong to reference and hypothesis
    set reference [linsert $reference 0 "..START.."]
    lappend reference "..END.."
    set reflen [llength $reference]
    set index 0
    ;# indexing reference words
    foreach elem $reference {
        set refarray([expr $reflen - 1 - $index]) $elem
        incr index
    }
    ;# Initialize actual vector (diagram column)
    set hypword [lindex $hypothesis 0]
    set colnum [llength $hypothesis]
    for {set index 0} {$index < ($reflen - 1)} {incr index} {
        set value [expr $reflen - 2 - $index]
        set actvec($index) $value
        if {$value > 0} {
            set eType "d$value"
        } else {set eType ""}
        set refword $refarray($index)
        if {[string compare $refword $hypword]} {
            incr actvec($index)
            append eType s
        } else {append eType -}
        set backtrack($colnum,$index) [expr $reflen - 1]
        set errorType($colnum,$index) $eType
    }
    set index [expr $reflen - 1]
    set actvec($index) 1
    set backtrack($colnum,$index) $index
    set errorType($colnum,$index) i
    incr colnum -1
    ;# main loop: steps through hypothesis list

    foreach hypword [lreplace $hypothesis 0 0] {
        for {set index 0} {$index < $reflen} {incr index} {
            set minvalue [expr $actvec($index) + 1]
            set minindex $index
            set mineType i
            if {[string compare $refarray($index) $hypword]} {
                set offset 1
            } else {
                set offset 0
            }
            for {set j [expr $index + 1]} {$j < $reflen} {incr j} {
                set delet [expr $j - $index - 1]
                set value [expr $actvec($j) + $offset + $delet]
                if {$value < $minvalue} {
                    set minvalue $value
                    set minindex $j
                    if {$delet > 0} {set mineType d$delet} else {
                        set mineType ""
                    }
                    if {$offset == 1} {append mineType s} else {
                        append mineType -
                    }
                }
            }
            set actvec($index) $minvalue
            set backtrack($colnum,$index) $minindex  ;# backtrack. link
            set errorType($colnum,$index) $mineType
        }
        incr colnum -1
    }
    ;# last step
    set minvalue [expr $actvec(0) + 1]
    set minindex 0
    for {set j 1} {$j < $reflen} {incr j} {
        set value [expr $actvec($j) + $j - 1]
        set delet [expr $j - 1]
        if {$value < $minvalue} {
            set minvalue $value
            set minindex $j
            if {$delet > 0} {set mineType d$delet} else {
                set mineType ""
            }
        }
    }
    ;# backtracking
    set alignlist {}
    if {[string length $mineType] > 0} {
        set errorlist [list $mineType]
    } else {set errorlist {}}
    for {set colnum 1} {$colnum <= [llength $hypothesis]} {incr colnum} {
        set alignlist [linsert $alignlist 0 $refarray($minindex)]
        set mineType $errorType($colnum,$minindex)
        set errorlist [linsert $errorlist 0 $mineType]
        set minindex $backtrack($colnum,$minindex)
    }
    return [list [expr 1.00*$minvalue/($reflen-2)] $minvalue $alignlist $errorlist]
}

# Test

set reference {Guten Morgen es ist viertel vor sechs}
set hypothesis {Puten Morgen ist vierte vor sie sechs}
puts "Reference: $reference\nHypothesis: $hypothesis"
set res [wordErrorRate $reference $hypothesis]
puts "Word error rate = [lindex $res 0] ([lindex $res 1] errors)."
puts "Reached with alignment: [lindex $res 2]"
puts "Corr. error sequence: [lindex $res 3]"
exit