Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!tut.cis.ohio-state.edu!pt.cs.cmu.edu!dsl.pitt.edu!pitt!willett!ForthNet
From: ForthNet@willett.pgh.pa.us (ForthNet articles from GEnie)
Newsgroups: comp.lang.forth
Subject: other forth applications
Message-ID: <1732.UUL1.3#5129@willett.pgh.pa.us>
Date: 14 Sep 90 03:39:23 GMT
Organization: String, Scotch tape, and Paperclips.  (in Pgh, PA)
Lines: 81


 Date: 09-11-90 (13:10)              Number: 3758 (Echo)
   To: ZAFAR ESSAK                   Refer#: 3743
 From: JACK BROWN                      Read: NO
 Subj: SOUNDEX                       Status: PUBLIC MESSAGE

 ZE>I have been experimenting with the utility SOUNDEX described by Ron
 ZE>Braithwaite in FD X/3 & 4 in 1988.  I modified it slightly for use 
 ZE>without a string stack and to be compatible with F-PC as follows: 

 Ralph Dean had a Forth implementation of SOUNDEX in Dr Dobbs #50
 You can get his complete implementation in the file BSTRING.SEQ that
 can be found in L6.ZIP  of Jack Brown's F-PC 3.5 Tutorial.

[ Lesson's 1 - 7 are on wsmr-simtel20.army.mil and wuarchive.wustl.edu.
  The file is called fpcl1-7.zip.  -dwp ]

 Below is the last section of this file.   You could use Ralph's
 implementation to check your own.  You will need to get the
 file BSTRING.SEQ from L6.ZIP to compile the code below.

 \  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$ conatains 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 ;
 ---
  * QDeLuxe 1.01 #260s  Are you a member of FIG? Why not join today!

 NET/Mail : British Columbia Forth Board - Burnaby BC - (604)434-5886   
-----
This message came from GEnie via willett through a semi-automated process.
Report problems to: uunet!willett!dwp or dwp@willett.pgh.pa.us