Soundex function

Question

Write the shortest function to generate the American Soundex code for a surname only containing the uppercase letters A-Z. Your function must produce output consistent with all the linked page's examples (given below), although it need not and should not remove prefixes. Hyphens in the output are optional. Have fun!

Note: You may not use the soundex() function included in PHP or equivalents in other programming languages.

The examples:

WASHINGTON W-252
LEE L-000
GUTIERREZ G-362
PFISTER P-236 
JACKSON J-250 
TYMCZAK T-522
VANDEUSEN V-532
ASHCRAFT A-261

Answer 1

Perl, 143 150 characters

sub f{$_="$_[0]000";/./;$t=$&;s/(?<=.)[HW]//g;s/[BFPV]+/1/g;s/[CGJKQSXZ]+/2/g;s/[DT]+/3/g;s/L+/4/g;s/[MN]+/5/g;s/R+/6/g;s/(?<=.)\D//g;/.(...)/;"$t$1"}

This solution contains only regular expressions which are applied one after another. Unfortunately I didn't find a shorter representation with a loop so I hard-coded all the calls into the script.

The same version but a little bit more readable:

sub f{
  $_="$_[0]000";        # take first argument and append "000"
  /./;$t=$&;            # save first char to variable $t
  s/(?<=.)[HW]//g;      # remove and H or W but not the first one
  s/[BFPV]+/1/g;        # replace one or more BFPV by 1
  s/[CGJKQSXZ]+/2/g;    # replace one or more CGJKQSXZ by 2
  s/[DT]+/3/g;          # replace one or more DT by 3
  s/L+/4/g;             # replace one or more L by 4
  s/[MN]+/5/g;          # replace one or more MN by 5
  s/R+/6/g;             # replace one or more R by 6
  s/(?<=.)\D//g;        # remove and non-digit from the result but not the first char
  /.(...)/;"$t$1"       # take $t plus the characters 2 to 4 from result
}

Edit 1: Now the solution is written in form of a function. The previous one was reading/writing from/to STDIN/STDOUT. It cost me seven characters to work around that.

Answer 2

J - 99

{.,([:-.&' '@":3{.!.0[:(#~1,}.~:}:)^:#,@(;:@]>:@I.@:(e.&>"0 _~)[#~e.))&'BFPV CGJKQSXZ DT L MN R'@}.

Testing:

  sndx=: {.,([:-.&' '@":3{.!.0[:(#~1,}.~:}:)^:#,@(;:@]>:@I.@:(e.&>"0 _~)[#~e.))&'BFPV CGJKQSXZ DT L MN R'@}.
  test=: ;: 'JACKSON PFISTER TYMCZAK GUTIERREZ ASHCRAFT ASHCROFT VANDEUSEN ROBERT RUPERT RUBIN WASHINGTON LEE'
  (,. sndx&.>) test


+-------+-------+-------+---------+--------+--------+---------+------+------+-----+----------+----+
|JACKSON|PFISTER|TYMCZAK|GUTIERREZ|ASHCRAFT|ASHCROFT|VANDEUSEN|ROBERT|RUPERT|RUBIN|WASHINGTON|LEE |
+-------+-------+-------+---------+--------+--------+---------+------+------+-----+----------+----+
|J250   |P123   |T520   |G362     |A261    |A261    |V532     |R163  |R163  |R150 |W252      |L000|
+-------+-------+-------+---------+--------+--------+---------+------+------+-----+----------+----+

Answer 3

eTeX, 377.

\let\E\expandafter
\def\x#1;#2#3{\def\s##1#2{##1\s#3}\edef\t{\s#1\iffalse#2\fi}\E\x\t;}
\def\a[#1#2]{\if{{\fi\uppercase{\x#1,#2};B1F1P1V1C2G2J2K2Q2S2X2Z2D3T3L4M5N5R6A7E7I7O7U7
    H{}W{}Y{}{11}1{22}2{33}3{44}4{55}5{66}6{{}\toks0\bgroup}!}\E\$\t0000!#1}}
\def\$#1,#2{\if#1#2\relax\E\%\else\E\%\E#2\fi}
\def\%{\catcode`79 \scantokens\bgroup\^}
\def\^#1#2#3#4!#5{\message{#5#1#2#3}\end}
\E\a

Run as etex filename.tex [Ashcraft].

Answer 4

Python, 274 285 241 235 225 200 190 183 179 174 166 161

- Fixed last clause (H or W as consonant separators). Ashcraft now has the right result. - Made the dict smaller - Formating is smaller (doesn't require python 2.6) - Simpler dict search for k - Changed vowel value from '*' to '' and .append to +=[i] - List comprehension FTW - Removed call to upper :D

I Can't golf any further. Actually I did. Now I think I can't golf any further! Did it again...

Using translate table:

def f(n):z=n.translate(65*'_'+'#123#12_#22455#12623#1_2#2'+165*'_').replace('_','');return n[0]+(''.join(('',j)[j>'#']for i,j in zip(z[0]+z,z)if i!=j)+'000')[:3]

Old list comprehension code:

x=dict(zip('CGJKQSXZDTLMNRBFPV','2'*8+'3345561111'))
def f(n):z=[x.get(i,'')for i in n if i not in'HW'];return n[0]+(''.join(j for i,j in zip([x.get(n[0])]+z,z)if i!=j)+'000')[:3]

Old code:

x=dict(zip('CGJKQSXZDTLMNRBFPV','2'*8+'3345561111'))
def f(n):
 e=a=[];k=n[0]in x
 for i in[x.get(i,'')for i in n.upper()if i not in'HW']:
  if i!=a:e+=[i]
  a=i
 return n[0]+(''.join(e)+'000')[k:3+k]

Test:

[f(i) for i in ['WASHINGTON', 'LEE', 'GUTIERREZ', 'PFSTER', 'JACKSON',
                'TYMCZAK', 'VANDEUSEN', 'ASHCRAFT']]

Gives:

['W252', 'L000', 'G362', 'P236', 'J250', 'T522', 'V532', 'A261']

As expected.

Answer 5

Perl, 110

sub f{$_="$_[0]000";/./;$t=$&;s/(?<=.)[HW]//g;y/A-Z/:123:12_:22455:12623:1_2:2/s;s/(?<=.)\D//g;/.(...)/;$t.$1}

I'm using Howard's solution with my translate table (y/A-Z/table/s instead of every s/[ABC]+/N/g)

Answer 6

GolfScript (74 chars)

This implementation uses a magic string which has non-printable characters. In xxd output form it's

0000000: 7b2e 313c 5c5b 7b36 3326 2741 4c15 c252  {.1<\[{63&'AL..R
0000010: d056 4c1e 8227 3235 3662 6173 6520 3862  .VL..'256base 8b
0000020: 6173 653d 7d25 7b2e 373d 2432 243d 7b3b  ase=}%{.7=$2$={;
0000030: 7d2a 7d2a 5d31 3e31 2c2d 5b30 2e2e 5d2b  }*}*]1>1,-[0..]+
0000040: 333c 7b2b 7d2f 7d3a 533b                 3<{+}/}:S;

Without using the base changes to compress a list of 3-bit numbers, it would be

{.1<\[{63&[1 0 1 2 3 0 1 2 7 0 2 2 4 5 5 0 1 2 6 2 3 0 1 7 2 0 2]=}%{.7=$2$={;}*}*]1>1,-[0..]+3<{+}/}:S;

Online test

It's basically a bunch of boring loops, but there's one interesting trick:

.7=$2$=

This is inside a fold whose purpose is to handle double-letters. Adjacent letters with the same code are merged into one unit, even if separated by an H or a W. But this can't be implemented trivially by removing all Hs and Ws from the string, because in the (admittedly unlikely in real life, but not ruled out by the spec) case that the first letter is H or W and the second letter is a consonant, we need to not elide that consonant when we remove the first letter. (I added a test case WM which should give W500 to check this).

So the way I handle that is to do a fold and to delete each letter other than the first (a convenient side-effect of using fold) which is either equal to the previous one or equal to 7, the internal code for H and W.

Given a and b on the stack, the naïve way to check whether a == b || b == 7 would be

.2$=1$7=+

But there's a 2-character saving by using a computed copy-from-stack:

.7=$

If b is equal to 7 then it copies a; otherwise it copies b. So by then comparing with a we get a guaranteed truthy value if b was 7 regardless of the value of a. (Before any pedants weigh in, GolfScript doesn't have NaNs).

Answer 7

APL (83)

{(⊃⍵),,/⍕¨3↑0~⍨1↓K/⍨~K=1⌽K←0,⍨{7|+/' '=S↑⍨⍵⍳⍨S←' BFPV CGJKQSXZ DT L MN R'}¨⍵~'HW'}⍞

Answer 8

PowerShell, 150 161

First try and I'm sure there can be golfed quite a bit more.

filter s{$s=-join$_[1..9]
1..6+'$1','',$_[0]|%{$s=$s-replace('2[bfpv]2[cgjkqsxz]2[dt]2l2[mn]2r2(.)\1+2\D|^.2^'-split2)[++$a],$_}
-join"${s}000"[0..3]}

Works correctly with the test cases from both the linked page and the Wikipedia article:

Jackson, Pfister, Tymczak, Gutierrez, Ashcraft, Ashcroft, VanDeusen, Robert, Rupert, Rubin, Washington, Lee

Answer 9

Ruby 140

I'm using Ruby 2.0, but I think it should work with earlier versions too.

def f s
a=s[i=0]
%w(HW BFPV CGJKQSXZ DT L MN R).each{|x|s.gsub!(/[#{x}]+/){i>0&&$`[0]?i: ''};i+=1}
a+(s[1..-1].gsub(/\D/,'')+'000')[0,3]
end

Example:

puts f "PFISTER" => P236