ANEW --SOUNDEX--                              \  Wil Baden  2002-10-14

\  *******************************************************************
\  *                                                                 *
\  *  Wil Baden  2002-10-14                                          *
\  *                                                                 *
\  *     SOUNDEX  ( str /str -- addr 4 )                             *
\  *                                                                 *
\  *  Convert name to Soundex code.                                  *
\  *                                                                 *
\  *  Uses:  Char>Upper  THIRD  from Toolbelt                        *
\  *                                                                 *
\  *******************************************************************

CREATE  Soundex-Addr  4 chars ALLOT

CREATE  Soundex-Codes
    HERE  26 chars ALLOT  S" 01230120022455012623010202" ROT SWAP MOVE

: Char>Soundex             ( char -- code )
    32 OR  [char] a -  dup 26 U<  IF
        chars Soundex-Codes + C@
    ELSE
        DROP  [char] 0
    THEN ;

: SOUNDEX                  ( str /str -- addr 4 )
    Soundex-Addr 4  [char] 0  FILL
    over C@ Char>Upper  Soundex-Addr C!  1 /STRING
    Soundex-Addr CHAR+ 3  2SWAP       ( addr+1 3 str /str)
    BOUNDS ?DO                        ( addr+i 4-i)
        I C@ Char>Soundex  I 1- C@ Char>Soundex  over <>
        over [char] 0 <> AND  IF
            THIRD C!                  ( addr+i 4-i)
            1 /STRING
            dup 0= IF  LEAVE  THEN
        ELSE DROP THEN
    LOOP
    2DROP
    Soundex-Addr 4 ;

\  *************************  Test SOUNDEX  **************************

\  Uses:  USES:  Iterpretive ."

CR ." \ " USES: SOUNDEX TYPE  SPACE

    Buerck Lee kuhne SCHAEFER cummings Nguyen Aaron

    etc  ."  should be " CR ." \ B620 L000 K500 S160 C552 N250 A650 "

\\  ***********************  End of SOUNDEX  *************************