# soundex.pl
# by George Armhold <armhold@dimacs.rutgers.edu>
# 3/22/92

# return the Soundex value of a string using the following rules:
#
#   1) remove W and H
#   2) remove all vowels except in the first position (A E I O U Y)
#   3) recode characters per table:
#           A E I O U Y             0       
#           B F P V                 1
#           C G J K Q S X Z         2
#           D T                     3
#           L                       4
#           M N                     5
#           R                       6
#
#   4) if two adjacent digits are now identical, remove one
#   5) truncate to six digits or pad out the result with zeroes to
#   make six digits  
#   6) replace the first digit with the first character from the
#   original word 


sub soundex {
# takes a string as an argument, and returns its soundex value

    local($pattern) = @_;

    # upper-case the pattern to normalize matches
    $pattern =~ tr/a-z/A-Z/;

    $pattern =~ s/[^A-Z0-9]//ge; # allow only alphanumerics

    # remove W & H
    $pattern =~ s/(W|H)//ge;

    # remember the first char
    local($first) = substr($pattern, 0, 1);

    # remove vowels except in the first position
    local($temp) = substr($pattern, 1, length($pattern) - 1); 
    $temp =~ s/(A|E|I|O|U|Y)//ge;

    # preserve the first char, and attach the rest (vowel-less)
    $pattern = $first . $temp;

    # vowels have value 0
    $pattern =~ s/(A|E|I|O|U|Y)/0/ge;

    # these chars have value 1
    $pattern =~ s/(B|F|P|V)/1/ge;

    # these chars have value 2
    $pattern =~ s/(C|G|J|K|Q|S|X|Z)/2/ge;

    # these chars have value 3
    $pattern =~ s/(D|T)/3/ge;

    # this char has value 4
    $pattern =~ s/L/4/g;

    # these chars have value 5
    $pattern =~ s/(M|N)/5/ge;

    # this char has value 6
    $pattern =~ s/R/6/g;

    $pattern =~ tr/\0-\377//s;	# remove adjacent identical digits

    # pad on zeroes if necessary and truncate
    $pattern .= "000000";	
    $pattern = substr($pattern, 0, 6); 

    substr($pattern, 0, 1) = $first; # replace the first char
    
    $pattern;			# return value
}

1;				# because this is a require'd file