       ͻ
        Lesson 6 Part 130  F-PC 3.5 Tutorial by Jack Brown 
       ͼ

       Ŀ
         Simple String Package Case Study ( continued ) 
       

\ String input.  Usage:  string $IN
: $IN  ( addr len  -- )
    OVER SWAP MLEN EXPECT ;

\ String equality.  Usage  string1 string2 S=
\ Leaves a true flag if strings are equal.
: S= ( addr1 len1 addr2 len2 -- flag )
     ROT OVER =
     IF  TRUE SWAP 0 ?DO DROP OVER C@ OVER C@ =
         IF 1 1 D+ TRUE
         ELSE FALSE LEAVE
         THEN LOOP
     ELSE DROP FALSE
     THEN NIP  NIP ;

\ String array.
\ Usage:   5 20 SARRAY NAMES
\         " JACK" 1 NAME  S!     1 NAME  TYPE
\         " JOHN" 2 NAME  S!     2 NAME  TYPE      etc...
: SARRAY  ( n len -- )  \ when compiling
        CREATE  ABS 255 MIN 1 MAX SWAP
                0 ?DO DUP DUP C,
                0 ?DO BL C, LOOP 0 C,
                LOOP DROP
        DOES>   SWAP 1- OVER C@
                2+ * + 1+ DUP SEARCH ;

\  Ralph Dean's FORTH implementation of SOUNDEX program that
\  originally  appeared in the May 1980 Byte Magazine.
\
\  Executing SOUND will cause a prompt for the name.
\  The name is terminated after 30 characters or <enter>.
\  The soundex code is then computed and typed out.
\  The string variable S$ contains the code produced.
\  For more information on Soundex codes see the original
\  Byte article.


FORTH DEFINITIONS DECIMAL
30 STRING N$   \ Input string whose soundex code is to be found.
 4 STRING S$   \ Output string containing soundex code.
 1 STRING K$   1 STRING L$

: NAME ( --  )  \ Prompt for input of last name.
        CR ." Last Name? "  N$  $IN ;

: FIRST1 ( -- ) \ Move first character to S$
        1 N$ LEFT$ S$ S! ;

: ITH  ( n m  --  k )
        N$  MID$ DROP C@ 64 - ;

: KTH ( k -- )
        DUP " 01230120022455012623010202"
        MID$ K$ S! ;

: BLS ( -- )
        S$ K$ S+ S$ S! ;

: TEST ( -- flag )
        K$ L$ S= K$ " 0" S= OR 0= ;

: IST  ( n   n flag )
        DUP 1 < OVER 26 > OR 0= ;

\ Compute soundex code
: COMP ( -- )
        N$ LEN 1+ 2
        DO I I ITH IST
           IF   KTH TEST IF BLS THEN
           ELSE DROP
           THEN
        K$ L$ S!
        LOOP ;

\ This is the Program.   BROWN , BRUN , BRAWN  all give B650
: SOUNDEX ( -- )
        NAME FIRST1 N$ LEN 2 >
        IF COMP THEN S$ " 0000" S+ S$ S!
        CR ." Soundex Code =  " S$ TYPE CR ;

Ŀ
   Please Move to Lesson 6 Part 140  

