Purpose: a pattern matching algorithm to how close two strings sound similar to one another.
DKF: This code has been greatly tightened and should be clearer too. Some idioms work better in Tcl than they do in other languages, so transcribing an algorithm from C is not always straight-forward...
## Be nice and friendly with namespaces
namespace eval ::soundex {namespace export soundex}
## Set up some static data only once
array set ::soundex::soundexcode {
a 0 b 1 c 2 d 3 e 0 f 1 g 2
h 0 i 0 j 2 k 2 l 4 m 5 n 5
o 0 p 1 q 2 r 6 s 2 t 3 u 0
v 1 w 0 x 2 y 0 z 2
}
proc ::soundex::soundex {string} {
variable soundexcode
## force lowercase and strip out all non-alphabetic characters
regsub -all {[^a-z]} [string tolower $string] {} letters
## the null string is code Z000
if {![string length $letters]} { return Z000 }
set last -1
set key {}
## scan until end of string or until the key is built
foreach char [split $letters {}] {
set code $soundexcode($char)
## Fold together adjacent letters with the same code
if {$last != $code} {
set last $code
## Ignore code==0 letters except as separators
if {$last} {
append key $last
## Only need the first four
if {[string length $key] >= 4} {break}
}
}
}
## normalise by adding zeros to get four characters
string range "[string toupper $key]0000" 0 3
}DKF: Are soundex codes all numeric except for the one for the empty string? Or should the append really be an append of $char instead?
LV: There are some alternative algorithms to soundex that attempt to achive similar functionality. I recall seeing several coded for Perl. The benefit was that they achieved varying degrees of better matches. Anyone familar with alternatives?
## ********************************************************
##
## Name: metaphone.tcl
##
## Description:
## A better soundex type algorithm
##
## Usage:
##
## Comments:
## The idea here is not to match some existing standard.
##
## The idea *is* to try to reduce *english* to a sound
## based structure while preserving readability.
##
## This results in output that *can* be used for the same
## purpose as soundex.
##
## No question, this is a first pass and needs polish!
##
proc metaphone { string } {
set patterns {
(ough|igh|a|e|i|o|u|y) {}
(gth) g
(th|t|tt) t
(sch|sh|ss|s) s
(ghn|gn|nn) n
(ch|zh|gh|x|j) x
(ph|ff|f) f
(ck|kk|k) k
(gg|gh) g
(ll|lh) l
(mm|mn) m
(dd|dh) d
(zz|sz) z
wh w
h {}
}
foreach [ list pattern replacement ] $patterns {
regsub -all -nocase $pattern $string $replacement string
}
regsub -all {\s+} $string { } string
return $string
}
## ******************************************************** if 0 {
DKF - I see what is meant by first pass, given that it equivalences sought, satay and asti... :^)
}
You write that as if it were pregnant with significance. Why should it not do so?