Escriba la función más corta para generar el código American Soundex para un apellido que solo contenga las letras mayúsculas AZ. Su función debe producir resultados consistentes con todos los ejemplos de la página vinculada (que se muestran a continuación), aunque no es necesario ni debe eliminar los prefijos. Los guiones en la salida son opcionales. ¡Que te diviertas!

Nota: Es posible que no se utilice la soundex()función incluida en PHP o sus equivalentes en otros lenguajes de programación.

Los ejemplos:

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

Perl, 143 150 caracteres

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"}

Esta solución contiene solo expresiones regulares que se aplican una tras otra. Desafortunadamente, no encontré una representación más corta con un bucle, así que codifiqué todas las llamadas en el script.

La misma versión pero un poco más legible:

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
}

Edición 1: ahora la solución está escrita en forma de una función. El anterior era leer / escribir de / a STDIN / STDOUT. Me costó siete personajes solucionar eso.

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

Corre como etex filename.tex [Ashcraft].

Pitón, 274 285 241 235 225 200 190 183 179 174 166 161

- Se corrigió la última cláusula (H o W como separadores de consonantes). Ashcraft ahora tiene el resultado correcto. - Hecho el dict más pequeño - Formating es menor (no requiere Python 2.6) - Más simple búsqueda de dict k - valor vocal cambió de '*'a ''y .appenda +=[i] - Lista de comprensión FTW - llamada eliminado para upper: D

No puedo seguir jugando al golf. En realidad lo hice. ¡Ahora creo que no puedo seguir jugando al golf! Lo hice de nuevo ...

Usando la tabla de traducción:

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]

Código de comprensión de la lista anterior:

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]

Código antiguo

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]

Prueba:

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

Da:

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

Como se esperaba.

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}

Estoy usando la solución de Howard con mi tabla de traducción (en y/A-Z/table/slugar de cada s/[ABC]+/N/g)

J - 99

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

Pruebas:

  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|
+-------+-------+-------+---------+--------+--------+---------+------+------+-----+----------+----+

GolfScript (74 caracteres)

Esta implementación utiliza una cadena mágica que tiene caracteres no imprimibles. En xxdforma de salida es

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;

Sin usar los cambios básicos para comprimir una lista de números de 3 bits, sería

{.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;

Prueba en línea

Básicamente es un montón de bucles aburridos, pero hay un truco interesante:

.7=$2$=

Esto está dentro de un pliegue cuyo propósito es manejar letras dobles. Las letras adyacentes con el mismo código se fusionan en una unidad, incluso si están separadas por una Ho una W. Pero esto no se puede implementar de manera trivial eliminando todos Hlos Wsys de la cadena, porque en el caso (ciertamente improbable en la vida real, pero no descartado por la especificación) que la primera letra es Ho Wy la segunda letra es una consonante , no debemos eludir esa consonante cuando eliminamos la primera letra. (Agregué un caso de pruebaWM que debería dar W500para verificar esto).

Entonces, la forma en que manejo eso es hacer un pliegue y eliminar cada letra que no sea la primera (un efecto secundario conveniente de usar el pliegue) que es igual a la anterior o igual a7 código interno paraH y W.

Dado ay ben la pila, la forma ingenua de verificar si a == b || b == 7sería

.2$=1$7=+

Pero hay un ahorro de 2 caracteres al usar una copia calculada de la pila:

.7=$

Si bes igual a, 7entonces copia a; de lo contrario se copia b. Entonces, al compararlo a, obtenemos un valor de veracidad garantizado si bfuera 7independientemente del valor de a. (Antes de que los pedantes pesen, GolfScript no tiene NaN).

PowerShell, 150161

Primero prueba y estoy seguro de que se puede jugar un poco más al golf.

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]}

Funciona correctamente con los casos de prueba tanto de la página vinculada como del artículo de Wikipedia:

Jackson, Pfister, Tymczak, Gutiérrez, Ashcraft, Ashcroft, VanDeusen, Robert, Rupert, Rubin, Washington, Lee

Rubí 140

Estoy usando Ruby 2.0, pero creo que también debería funcionar con versiones anteriores.

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

Ejemplo:

puts f "PFISTER" => P236

APL (83)

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