######################################################################
#
# Package: cost250
# File: runexp.tcl
# Project: COST-250 Speaker Recognition Reference System
# Author: H. Melin, KTH/CTT, 16/02/1998
#
# Description:
# Main loop for running experiments.
#
# ---------------------------------------------------------------
#
# History:
# 21/06/1999 - part of COST250 Speaker Recognition Reference System, release 1.0
# 24/02/1999 - part of development release 0.2
# 24/02/1999 H. Melin - added error handling
# 23/02/1999 - part of development release 0.1
#
######################################################################
package provide cost250 1.0
namespace eval Experiment {
namespace export run
###########################################################
#
# stripComments: Strip comments from line of input.
#
# Comments are defined as
#
# - a hash mark (#) and the following text on the line
# - matching brackets <...> and all text between the brackets.
#
proc stripComments { line lineIndex } {
set errorMsg ""
# Anything after a hash mark (#) is treated as a comment and is discarded here
set hashIndex [string first "#" $line]
if {$hashIndex >= 0} {
incr hashIndex -1
set line [string range $line 0 $hashIndex]
}
# Anything between angle brackets <...> is treated as a comment and is discarded here
set openBracketIndex [string first "<" $line]
while {$openBracketIndex >= 0 && $errorMsg == ""} {
set closeBracketIndex [string first ">" $line]
if {$closeBracketIndex == -1} {
set errorMsg "'<' has no matching '>'"
} elseif {$closeBracketIndex < $openBracketIndex} {
set errorMsg "'>' before '<'"
} else {
incr openBracketIndex -1
incr closeBracketIndex
set s [string range $line 0 $openBracketIndex]
append s [string range $line $closeBracketIndex end]
set line $s
}
set openBracketIndex [string first "<" $line]
}
if {$errorMsg != ""} {
error $errorMsg
}
return $line
}
#####################################################################
#
# Experiment loop: read an experiment description file and exectute
# the given enrollments and tests.
#
# If everything goes fine, return 1, otherwise 0.
#
# -------------------------------------------------------------------
#
# Format definition for experiment description files.
#
# Field indices:
# spIndex - real identity of speaker making the claim
# idIndex - identity he/she is claiming
# fileIndex - first file. This and remaining fields contain file names.
#
# Special values:
# enrollId - indicates enrollment operation if it appears in field $spIndex.
#
variable spIndex 0
variable idIndex 1
variable fileIndex 2
variable enrollId "enroll"
#
# Required number of files for verification and enrollment
variable numNeededFiles [list 1 1]
proc run { experimentFileName args } {
variable spIndex
variable idIndex
variable fileIndex
variable enrollId
variable numNeededFiles
# Parse args
set option(-database) ""
set option(-system) ""
set option(-outdir) "./"
set option(-resultfile) "./results.llk"
array set option $args
set database $option(-database)
set recsys $option(-system)
# Collect statistics
set numEnrollments 0
set numTrueSpeakerTests 0
set numFalseSpeakerTests 0
set numTests 0
# Open file with experiment description
set experimentFile [open $experimentFileName]
# Open a file for result output
set resultChannel [open $option(-resultfile) w]
# Create output directory (only creates if non-exiting)
file mkdir $option(-outdir)
puts "\n--- Running experiment in $experimentFileName:\n"
# Read and process each line of experiment description
set errorMsg ""
set ok 1
set lineIndex 0
gets $experimentFile line
while {![eof $experimentFile] && $ok == 1} {
set isEnrollCycle 0
incr lineIndex
if {$ok} {
if {[catch {set line [stripComments $line $lineIndex]} errorMsg]} {
set errorMsg "syntax error in $experimentFileName line $lineIndex: $errorMsg"
set ok 0
}
}
# Parse the fields of a line
if {$ok} {
set fields [split [string trim $line]]
set numFields [llength $fields]
if {$numFields > 0} {
# Extract information from line
set speaker [lindex $fields $spIndex]
if {$enrollId == [string tolower $speaker]} {
set isEnrollCycle 1
}
set identity [lindex $fields $idIndex]
set fileTags [lrange $fields $fileIndex end]
set numFiles [llength $fileTags]
# Check information
set n [lindex $numNeededFiles $isEnrollCycle]
if {$numFiles < $n} {
set errorMsg "too few files for operation on line $lineIndex of $experimentFileName: $numFiles, need $n"
set ok 0
}
if {$ok} {
if {$isEnrollCycle} {
if {[catch [$recsys enrollment $identity $fileTags $option(-outdir)] subErrorMsg]} {
set errorMsg "enrollment operation failed on line $lineIndex of $experimentFileName ($subErrorMsg)"
set ok 0
} else {
# Collect statistics
incr numEnrollments
}
} else {
if {[catch [$recsys verification $speaker $identity $fileTags $resultChannel] subErrorMsg]} {
set errorMsg "verification operation failed on line $lineIndex of $experimentFileName ($subErrorMsg)"
set ok 0
} else {
# Collect statistics
incr numTests
if {$speaker == $identity} {
incr numTrueSpeakerTests
} else {
incr numFalseSpeakerTests
}
}
}
}
}
}
if {$ok} {
gets $experimentFile line
}
}
# Close files
if {[catch [close $resultChannel] localErrorMsg]} {
puts "Warning: cannot close $option(-resultfile)"
}
if {[catch [close $experimentFile] localErrorMsg]} {
puts "Warning: cannot close $experimentFileName"
}
if {! $ok} {
puts "\n*** aborting ***"
}
# Print statistics
puts "\nExperiment summary:"
if {$ok} {
puts "- Status: OK"
} else {
puts "- Status: FAILED on line $lineIndex"
}
puts "- Definition file: $experimentFileName"
puts "- Number of enrollments: $numEnrollments"
puts "- Number of tests: $numTests"
puts " true speaker: $numTrueSpeakerTests"
puts " false speaker: $numFalseSpeakerTests"
puts "- Result file: $option(-resultfile)"
if {! $ok} {
puts "- Error message follows:\n"
puts "ERROR: $errorMsg"
}
puts "\n"
if {! $ok} {
# We could throw an error here, but I choose to just return 0 for error and 1 for ok
return 0
}
return 1
}
}
# -------------- end of runexp.tcl ------------------------- #