FB II Compiler

PG PRO

Debugging

Memory

System

Mathematics

Resources

Disk I/O

Windows

Controls

Menus

Mouse

Keyboard

Text

Fonts

Drawing

Sound

Clipboard

Printing

Communication

ASM

Made with FB

TEXT

Code with SOUNDEX


Urk! I thought a SOUNDEX example came with FBII... but I just searched my drive and can't find one...

So, I dug around in some _old_ programming books, and found this explanation;

1) Retain the first letter of the name
2) Drop all letters A,E,I,O,U,W,H, and Y, and one each of double letters.
3) For the next three letters remaining, assign the following numbers;
B,F,P,V : 1
C,G,J,K,Q,S,X,Z : 2
D,T : 3
L : 4
M,N : 5
R : 6
4) If less than 3 consonants are left, fill with 0's.
5) Ignore adjacent equivalent letters with the same number.

Examples: MURPHY becomes M610
WARRICK becomes W620 (RR treated as one letter, CK treated as one letter)
ANDERS, ANDERSON, ANDRESEN and AMITER all become A536.

Now, I guess you'd like _code_ to go with that... okay!

Bill


COMPILE 0,_dimmedVarsOnly _noReDimVars
DIM gt$
END GLOBALS
TRON ON

' FN zap$ completely removes ALL occurrences of zap$ from the
' source string. It is part of FnJnII, by Ariel Publishing.
' If you don't have it, you'll have to write your own...

' INPUTS: src$ - STR255: the original string
' zap$ - STR255: the string to be removed
' OUTPUT: src$ - STR255: the new "clean" string

LOCAL MODE
  DIM c%, zLen%
LOCAL FN zap$(src$,zap$)
'guts removed!!! Buy FnJnII or "do it yourself!" :-)
END FN = src$

LOCAL FN Soundex$(t$)
  DIM rslt$, temp$, l%, i%
  t$ = UCASE$(t$)
  rslt$ = LEFT$(t$,1)
  t$ = RIGHT$(t$,LEN(t$)-1)
  t$ = FN zap$(t$,"A")
  t$ = FN zap$(t$,"E")
  t$ = FN zap$(t$,"I")
  t$ = FN zap$(t$,"O")
  t$ = FN zap$(t$,"U")

  t$ = FN zap$(t$,"W")
  t$ = FN zap$(t$,"H")
  t$ = FN zap$(t$,"Y")
  l% = LEN(t$)
  i% = 1
  DO 'remove double letters
    LONG IF MID$(t$,i%+1,1) = MID$(t$,i%,1)
      t$ = LEFT$(t$,i%-1) + RIGHT$(t$,l%-i%)
      l% = LEN(t$)
    END IF
    INC(i%)
  UNTIL i% >= l%
  l% = LEN(t$)
  WHILE l% > 0
    temp$ = LEFT$(t$,1)
    SELECT temp$
      CASE "B","F","P","V"
        rslt$ = rslt$ + "1"
      CASE "C","G","J","K","Q","S","X","Z"
        rslt$ = rslt$ + "2"
      CASE "D","T"
        rslt$ = rslt$ + "3"
      CASE "L"
        rslt$ = rslt$ + "4"
      CASE "M","N"
        rslt$ = rslt$ + "5"
      CASE "R"
        rslt$ = rslt$ + "6"
      CASE ELSE
'skip the "invalid" letter!
    END SELECT
    t$ = RIGHT$(t$,l%-1)
    l% = LEN(t$)
  WEND
  t$ = rslt$ 'just so we don't have to change this code
  l% = LEN(t$)
  i% = 1
  DO 'remove double numbers
    LONG IF MID$(t$,i%+1,1) = MID$(t$,i%,1)
      t$ = LEFT$(t$,i%-1) + RIGHT$(t$,l%-i%)
      l% = LEN(t$)
    END IF
    INC(i%)
  UNTIL i% >= l%
  LONG IF LEN(t$) > 4
    rslt$ = LEFT$(t$,4)
  XELSE
    t$ = t$ + "000"
    rslt$ = LEFT$(t$,4)
  END IF
END FN = rslt$

WINDOW 1,"TEST",(0,0)-(500,350),_docNoGrow
TEXT _geneva,12
CLS
PRINT "Testing!": PRINT
PRINT " Murphy; ";: gt$ = FN Soundex$("Murphy") : PRINT gt$
PRINT " Warrick; ";: gt$ = FN Soundex$("Warrick") : PRINT gt$
PRINT " Anders; ";: gt$ = FN Soundex$("Anders") : PRINT gt$
PRINT " Anderson; ";: gt$ = FN Soundex$("Anderson") : PRINT gt$
PRINT " Andresen; ";: gt$ = FN Soundex$("Andresen") : PRINT gt$
PRINT " Amiter; ";: gt$ = FN Soundex$("Amiter") : PRINT gt$
DO
  HANDLEEVENTS
UNTIL MOUSE(_down) 'or cmd-period...
END