######################################################################
#
# Package: cost250
# File: vqst.tcl
# Project: COST-250 Speaker Recognition Reference System
# Author: H. Melin, KTH/CTT, 16/02/1998
#
# Description:
# Implementation of recognition system methods for VQST.
#
#
# ---------------------------------------------------------------
#
# History:
# 03/12/1999 - changing default codebook size (cbSize) from 16 to 64.
# 21/06/1999 - part of COST250 Speaker Recognition Reference System, release 1.0b1
# 21/06/1999 - added "normalization" and "nonClientModels" properties
# and corresponding functionality: it is now possible to
# specify a list of competing non-client models.
# 21/06/1999 - default value for lpcConfig changed from
# "-f200 -o30 -p8 -s1" to "-f200 -o60 -p12 -a0.97 -s1".
# The new setting chooses 12th order LPC, 100 frames
# per second computed from 25 ms analysis window.
# 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 ReferenceSystem {
# Export public commands
namespace export new
# In this array all instance variables are stored
variable registry
# This array store default values for instance variables
variable registryDefault
# This list contains the names of all the instance variables
variable instanceVariables
########################################################################
#
# Instance variables
# ==================
#
# The registry array shall be indexed with $instance.$variable
# where $variable is one of the below. The registryDefault array
# is indexed with only the string $variable.
#
# ------ Verification method settings:
#
# Directories:
#
# binDir where executable VQST files reside. May be empty if
# they are in the current search path.
#
# Names of binary executables (without path):
#
# alw2linProgram A-law to linear sample decoding
# lin2parProgram parameterization
# concatProgram concatenation of parameterized files
# gencbProgram codebook training
# vqtestProgram compute codebook distortion against a test utterance
#
# Parameter values:
#
# cbSize size of codebooks to create
# lpcConfig configuration options to $lin2parProgram
# normalization score normalization method
# 0: none - use score from client model only
# 1: choose for each test - normalization is made
# to a single model that is chosen from a list
# of models given by the property "nonClientModels".
# The choice of model is done on a per-test basis
# as the model that gives the lowest distortion for
# the given test utterance(s).
# nonClientModels a list of models that represent classes of
# non-client speakers. It can be for instance
# a single world model ("W") or a pair of
# gender-dependent models ("M F"). The property
# value must be a list of names separated by a
# single space.
#
#
# ------ Runtime:
#
# Objects:
#
# database instance of Database
#
# Directories:
#
# tmpDir where to create temporary files
# cliDir where to find client model files (codebooks)
# refDir where to find non-client model files (codebooks)
#
# Filename extensions of files we create:
#
# linearExt sample files with linear scale
# paramExt parameter files
# modelExt client and non-client model files (codebooks)
#
# Other:
#
# trace
# uniqTag
# lpcConfigFileName
# isInit set to 1 when method init is called.
#
# Keep a list of all available instance variables
set instanceVariables [list \
binDir \
alw2linProgram lin2parProgram concatProgram gencbProgram vqtestProgram \
cbSize lpcConfig normalization nonClientModels \
database \
tmpDir cliDir refDir \
linearExt paramExt modelExt \
trace uniqTag lpcConfigFileName isInit]
# Define default values for instance variables
#
# Note: the default value of lpcConfig was "-f200 -o30 -p8 -s1"
# in the development releases 0.1 and 0.2. The default value
# was changed with release 1.0.
#
set registryDefault(binDir) ""
set registryDefault(alw2linProgram) "alw2lin"
set registryDefault(lin2parProgram) "lpccep"
set registryDefault(concatProgram) "concat"
set registryDefault(gencbProgram) "gencb"
set registryDefault(vqtestProgram) "vqtest"
set registryDefault(cbSize) "64"
set registryDefault(lpcConfig) "-f200 -o60 -p12 -a0.97 -s1"
set registryDefault(normalization) "1"
set registryDefault(nonClientModels) "W"
set registryDefault(database) ""
set registryDefault(tmpDir) "/tmp"
set registryDefault(cliDir) "cli"
set registryDefault(refDir) "ref"
set registryDefault(linearExt) ".lin"
set registryDefault(paramExt) ".lpc"
set registryDefault(modelExt) ".cb"
set registryDefault(trace) 0
set registryDefault(uniqTag) ""
set registryDefault(lpcConfigFileName) ""
set registryDefault(isInit) 0
#############################################################
#
# new: create a new recognizer instance.
#
proc new { db } {
variable registry
variable registryDefault
variable instanceVariables
# Create a unique instance name
set instanceBase "rec"
set ns [uplevel 1 namespace current]
if {"::" != $ns} {
append ns "::"
}
set i 1
while {1 == 1} {
set instance [format "%s%s%02d" $ns $instanceBase $i]
if {"" == [info commands $instance]} {
# We found an unused instance name
break
}
incr i
}
# Create instance variables by copying default values
foreach variable $instanceVariables {
set registry($instance.$variable) $registryDefault($variable)
}
# Set values of instance variables given as argument
set registry($instance.database) $db
# Setup other instance variables
set registry($instance.uniqTag) [pid]
# Create a command called $instance
proc $instance { method args } "ReferenceSystem::methods $instance \$method \$args"
return $instance
}
###########################################################
#
# methods: method call dispatcher
#
proc methods {name method argList} {
variable registry
switch $method {
destroy -
set -
init -
print -
enrollment -
verification {
if {[catch "method_$method $name $argList" result]} {
regsub -- "method_$method" $result "$name $method" result
return -code error $result
} else {
return $result
}
}
default {
return -code error "ERROR: \"$name $method\" is not defined"
}
}
}
## ------------ here comes local help commands ------------------ ##
###########################################################
#
# createLPCConfigFile: create a configuration file for
# lpc program (lpccep).
#
# Write the contents of the argument string to a file and return
# the name of the created file.
#
proc createLPCConfigFile { instance configString } {
variable registry
set fileName [file join $registry($instance.tmpDir) "lpcc$registry($instance.uniqTag).cfg"]
if {[catch {
set file [open $fileName "w"]
puts $file $configString
close $file
} errorMsg]} {
error "createLPCConfigFile: cannot create LPCC config file $fileName"
}
return $fileName
}
#####################################################################
#
# parameterize: parameterize the given sample files.
#
# Input argument $sampleFiles is a list of file tags. A directory
# name is prepended to this file tag to produce the sample file name.
#
# Sample files are assumed to be A-law files.
#
# Returns a list of parameter file names.
#
# Call parameterizeCleanup with the list of parameter file names
# as argument to delete files created by this function.
#
proc parameterize { instance sampleFiles } {
variable registry
set ok 1
# Get instance variables
set binDir $registry($instance.binDir)
set alw2lin [file join $binDir $registry($instance.alw2linProgram)]
set lin2par [file join $binDir $registry($instance.lin2parProgram)]
for {set i 0} {$i < [llength $sampleFiles] && $ok == 1} {incr i} {
if {[catch {set sampleFileName "[$registry($instance.database) filename [lindex $sampleFiles $i]]"} errorMsg]} {
set ok 0
}
if {$ok} {
set base [file join $registry($instance.tmpDir) [format "%s_%d" $registry($instance.uniqTag) $i]]
set linearFileName "$base$registry($instance.linearExt)"
set paramFileName "$base$registry($instance.paramExt)"
}
# Show progress
if {$ok} {
if {$registry($instance.trace) > 0} {
puts -nonewline "."
flush stdout
}
}
# Decode A-law samples and store a file with linear 16-bit samples
if {$ok} {
if {[catch [exec $alw2lin $sampleFileName $linearFileName] errorMsg]} {
set errorMsg "parameterize: cannot decode A-law file ($errorMsg)"
set ok 0
}
}
# Compute LPC-cepstra
if {$ok} {
if {[catch [exec $lin2par $linearFileName $paramFileName $registry($instance.lpcConfigFileName)] errorMsg]} {
set errorMsg "parameterize: cannot compute LPCC ($errorMsg)"
set ok 0
}
}
if {$ok} {
lappend paramFiles $paramFileName
}
}
if {$registry($instance.trace) > 0} {
puts ""
}
if {! $ok} {
error $errorMsg
} else {
return $paramFiles
}
}
#####################################################################
#
# parameterizeCleanup: delete all files created by parameterize.
#
proc parameterizeCleanup { instance paramFiles } {
variable registry
for {set i 0} {$i < [llength $paramFiles]} {incr i} {
# Remove file name extension
regsub $registry($instance.paramExt)$ [lindex $paramFiles $i] "" base
set linearFileName "$base$registry($instance.linearExt)"
set paramFileName "$base$registry($instance.paramExt)"
catch [file delete $linearFileName]
catch [file delete $paramFileName]
}
}
#####################################################################
#
# modelFileName: synthesize a model file name for the given identity.
#
proc modelFileName { instance identity {dir ""} } {
variable registry
if {$dir == ""} { set dir $registry($instance.cliDir) }
set fn [file join $dir $identity$registry($instance.modelExt)]
return $fn
}
## ------------ here comes method implementations --------------- ##
###########################################################
#
# Method destroy: free resources allocated for the given instance.
# and delete the object itself.
#
proc method_destroy { instance } {
variable registry
variable instanceVariables
# delete temporary files
if {$registry($instance.isInit)} {
if {[catch [file delete $registry($instance.lpcConfigFileName)] errorMsg]} {
puts "method_destroy: Warning: cannot delete $registry($instance.lpcConfigFileName) ($errorMsg)"
}
}
# Delete instance variables
# ...
# Delete the object/command itself
rename $instance ""
}
###########################################################
#
# Method set: set the value of an instance variable.
# This method may only be called before the init method
# is called.
#
proc method_set { instance varName value } {
variable registry
variable instanceVariables
# check that method init has not been called
if {$registry($instance.isInit)} {
error "method_set: already initialized: 'set' only allowed before 'init'"
}
# see if there is a variable with that name
if {[lsearch -exact $instanceVariables $varName] < 0} {
error "method_set: no such variable to set: $varName"
}
# ok, set value
set registry($instance.$varName) $value
}
###########################################################
#
# Method print: print the contents of the object
#
proc method_print { instance {channel stdout} } {
variable registry
variable registryDefault
variable instanceVariables
puts $channel "$instance:"
foreach variable $instanceVariables {
set value $registry($instance.$variable)
set default $registryDefault($variable)
puts -nonewline $channel [format " %-17s : %s" $variable $value]
if {$value != $default && $default != "" && $variable != "isInit"} {
puts -nonewline $channel " (default: $default)"
}
puts $channel ""
}
puts $channel ""
}
###########################################################
#
# Method init: initialize recognition system.
#
# Between creation with 'new' and calling this method, user
# may call 'set' to change values of instance variables.
#
proc method_init { instance } {
variable registry
# init may only be called once
if {$registry($instance.isInit)} {
error "method_init: already initialized"
}
set lpcConfig $registry($instance.lpcConfig)
if {[catch {set registry($instance.lpcConfigFileName) [createLPCConfigFile $instance $lpcConfig]} errorMsg]} {
error "method_init: initialization failed ($errorMsg)"
}
# Remember that init has been called
set registry($instance.isInit) 1
}
#####################################################################
#
# Method enrollment: perform one enrollment cycle.
#
#
proc method_enrollment { instance identity fileTags outDir } {
variable registry
# init must have been called first
if {!$registry($instance.isInit)} {
error "method_enrollment: recognizer not initialized"
}
puts "Enrollment: enroll $identity: [join $fileTags]"
set ok 1
# Get instance variables
set binDir $registry($instance.binDir)
# Programs we'll need:
set concat [file join $binDir $registry($instance.concatProgram)]
set gencb [file join $binDir $registry($instance.gencbProgram)]
# Parameterize each of the input files
if {$ok} {
if {[catch {set paramFiles [parameterize $instance $fileTags]} errorMsg]} {
set errorMsg "method_enrollment: could not parameterize files ($errorMsg)"
set ok 0
}
}
# Concatenate each parameter file into a large file
if {$ok} {
set trainFileName [file join $registry($instance.tmpDir) $registry($instance.uniqTag)$registry($instance.paramExt)]
if {[catch [eval [concat exec $concat $trainFileName $paramFiles]] errorMsg]} {
set errorMsg "method_enrollment: could not concatenate training files ($errorMsg)"
set ok 0
}
}
# Create codebook
if {$ok} {
if {[catch {set printOut [exec $gencb $trainFileName $registry($instance.cbSize) [modelFileName $instance $identity $outDir]]} errorMsg]} {
set errorMsg "method_enrollment: could not train codebook ($errorMsg)"
set ok 0
} else {
puts $printOut
puts ""
}
}
# Cleanup temporary files
if {[info vars paramFiles] != ""} {
parameterizeCleanup $instance $paramFiles
}
catch [file delete $trainFileName]
if {! $ok} {
error $errorMsg
}
}
#####################################################################
#
# Method verification: perform one verification cycle.
#
#
proc method_verification { instance speaker identity fileTags resultChannel } {
variable registry
set ok 1
# init must have been called first
if {$ok} {
if {!$registry($instance.isInit)} {
set errorMsg "method_verification: recognizer not initialized"
set ok 0
}
}
if {$ok} {
puts "Verification: $speaker claims to be $identity: [join $fileTags]"
}
# Unfortunately, the vqtest program can take only one speech file
if {$ok} {
if {[llength fileTags] > 1} {
set errorMsg "method_verification: verification on multiple files not yet supported"
set ok 0
}
}
# Parse the list of non-client models
if { $registry($instance.normalization) == "1" } {
set ncmList [split $registry($instance.nonClientModels)]
} else {
set ncmList ""
}
# Check if we have the required non-client model(s)
if {$ok} {
for {set i 0} {$i < [llength $ncmList]} {incr i} {
set nonClientModel [modelFileName $instance [lindex $ncmList $i] $registry($instance.refDir)]
if {[file exists $nonClientModel] == 0} {
set errorMsg "method_verification: cannot find non-client model $nonClientModel"
set ok 0
}
}
}
# Programs we'll need:
set vqtest [file join $registry($instance.binDir) $registry($instance.vqtestProgram)]
# Parameterize each of the input files
if {$ok} {
if {[catch {set paramFiles [parameterize $instance $fileTags]} errorMsg]} {
set errorMsg "method_verification: could not parameterize files ($errorMsg)"
set ok 0
}
}
# Match test utterance against client and non-client models
if {$ok} {
if {[catch {set cResult [eval [concat exec $vqtest [modelFileName $instance $identity] $paramFiles "-"]]} errorMsg]} {
set errorMsg "method_verification: could not compute client distortion ($errorMsg)"
set ok 0
} else {
# Extract the distance figure from the returned string (third and last field)
set cDistance [lindex [split $cResult ","] end]
}
}
if {$ok} {
set rDistanceList ""
set rMinDistance 0
set rModelIndex -1
# Go through each of the model in the non-client model set
for {set i 0} {$i < [llength $ncmList]} {incr i} {
set nonClientModel [modelFileName $instance [lindex $ncmList $i] $registry($instance.refDir)]
if {[catch {set rResult [eval [concat exec $vqtest $nonClientModel $paramFiles "-"]]} errorMsg]} {
set errorMsg "method_verification: could not compute non-client distortion for [lindex $ncmList $i] ($errorMsg)"
set ok 0
} else {
# Extract the distance figure from the returned string (third and last field)
set rDistance [lindex [split $rResult ","] end]
lappend rDistanceList $rDistance
# Look for model with smallest distance
if { $rDistance < $rMinDistance || $rModelIndex == -1 } {
set rMinDistance $rDistance
set rModelIndex $i
}
}
}
}
if { $ok } {
if { $rModelIndex != -1 } {
# Compute the distance for the non-client model set
# Here we choose the one smallest distance; we could do something else,
# for instance take the average over N models.
set rDistance $rMinDistance
# Compute normalized score
set score [expr $rDistance / $cDistance]
} else {
# Then we use no score normalization
set score [expr 1 / $cDistance]
}
}
# Print normalized score to result file
if {$ok} {
puts $resultChannel [format "%s %s %8.6f 0.0 %s" $speaker $identity $score [join $fileTags]]
}
# Cleanup temporary files
if {[info vars paramFiles] != ""} {
parameterizeCleanup $instance $paramFiles
}
if {! $ok} {
error $errorMsg
}
}
}
# ------------------------------ end of vqst.tcl ------------------------------------- #