procedure main(arglist)             # computes soundex of each argument
every write(x := !arglist, " => ",soundex(x))
end

procedure soundex(name)
   local  dig,i,x
   static con
   initial {                                   # construct mapping x[i] => i all else .
      x := ["bfpv","cgjkqsxz","dt","l","mn","r"]
      every ( dig := con := "") ||:= repl(i := 1 to *x,*x[i]) do con ||:= x[i]
      con := map(map(&lcase,con,dig),&lcase,repl(".",*&lcase))
      }

   name := map(name)                           # lower case
   name[1] := map(name[1],&lcase,&ucase)       # upper case 1st
   name := map(name,&lcase,con)                # map cons
   every x := !"123456" do
       while name[find(x||x,name)+:2] := x     # kill duplicates
   while name[upto('.',name)] := ""            # kill .
   return left(name,4,"0")
end