' ************************************************************
' PROGRAM:      FUNCTION SOUNDEX(STRING x$)
' PURPOSE:      simple soundex calculator
' ARGUMENT:     a single word
' RETURNS:      soundex code for the word passed as an argument
' AUTHOR:               vovchik (Puppy Linux forum)
' DEPENDS:      bacon, bash
' PLATFORM:     Puppy Linux (actually, any *nix with GTK)
' DATE:         24-03-2010
' VERSION:      0.01a
' NOTE:         Remove DECLARATIONS, INIT_VARS and SOUNDEX_TEST
'                       to use SOUNDEX(x$) in your own programs
'
' See also: http://en.wikipedia.org/wiki/Soundex
'
' ************************************************************

' *****************
' DECLARATIONS
' *****************

OPTION BASE 1
CONST MaxWords = 9
GLOBAL Words$[MaxWords]

' *****************
' END DECLARATIONS
' *****************


' *****************
' SUBS AND FUNCS
' *****************

' --------
SUB INIT_VARS()
' --------
    q$ = CHR$(34)
    MyVersion$ = "v. 0.1a"
    Words$[1] = "stupid"
    Words$[2] = "stu and pid"
    Words$[3] = "hello"
    Words$[4] = "foobar"
    Words$[5] = "stpid"
    Words$[6] = "supid"
    Words$[7] = "stuuupid"
    Words$[8] = "sstuuupiiid"
    Words$[9] = "stoopid"
END SUB

' --------
FUNCTION STRING$(NUMBER Quantity, STRING MyChar$)
' --------
    LOCAL NewString$
    LOCAL i
    NewString$ = ""
    FOR i = 1 TO Quantity
        NewString$ = CONCAT$(NewString$, MyChar$)
    NEXT i
    RETURN NewString$
END FUNCTION

' --------
FUNCTION SOUNDEX$(STRING UserWord$)
' --------
    LOCAL NewText$, InitLet$, TestWord$, Char$, Soundex$
    LOCAL Counter, Number
    ' To make processing simpler, uppercase the input word
    NewText$ = UCASE$(UserWord$)
    ' Keep the first letter for later
    InitLet$ = LEFT$(NewText$, 1)
    ' Substitute the letters for numbers
    TestWord$ = ""
    FOR Counter = 1 TO LEN(NewText$)
        Char$ = MID$(NewText$, Counter, 1)
        IF INSTR("BFPV", Char$) THEN Char$ = "1"
        IF INSTR("CGJKQSXZ", Char$) THEN Char$ = "2"
        IF INSTR("DT", Char$) THEN Char$ = "3"
        IF INSTR("L", Char$) THEN Char$ = "4"
        IF INSTR("MN", Char$) THEN Char$ = "5"
        IF INSTR("R", Char$) THEN Char$ = "6"
        TestWord$ = CONCAT$(TestWord$, Char$)
    NEXT Counter
    ' Strip out the letters H and W
    NewText$ = ""
    FOR Counter = 1 TO LEN(TestWord$)
        Char$ = MID$(TestWord$, Counter, 1)
        Number = INSTR("HW", Char$)
        IF Number < 1 THEN
            NewText$ = CONCAT$(NewText$, Char$)
        END IF
    NEXT Counter
    ' Check that no two adjacent codes are the same
    TestWord$ = ""
    FOR Counter = 1 TO LEN(NewText$)
        Char$ = MID$(NewText$, Counter, 1)
        IF NOT(EQUAL(Char$, RIGHT$(TestWord$, 1))) THEN
            TestWord$ = CONCAT$(TestWord$, Char$)
        END IF
    NEXT Counter
    ' Strip out any non-alphabetic characters, vowels and Y
    NewText$ = ""
    FOR Counter = 1 TO LEN(TestWord$)
        Char$ = MID$(TestWord$, Counter, 1)
        Number = INSTR("123456", Char$)
        IF Number > 0 THEN NewText$ = CONCAT$(NewText$, Char$)
    NEXT Counter
    ' Create the final code
    Number = INSTR("BCDFGJKLMNPQRSTVXZ", InitLet$)
    IF Number > 0 THEN
        Soundex$ = CONCAT$(InitLet$, MID$(NewText$, 2, 3))
    ELSE
        Soundex$ = CONCAT$(InitLet$, MID$(NewText$, 1, 3))
    END IF
    ' If less than four characters pad right with "0"s
    IF LEN(Soundex$) < 4 THEN
        Soundex$ = CONCAT$(Soundex$, STRING$(4 - LEN(Soundex$), "0"))
    END IF
    RETURN Soundex$
END FUNCTION

' --------
SUB SOUNDEX_TEST(STRING Word2Find$)
' --------
    LOCAL SoundexCode$
    LOCAL i
    PRINT
    FOR i = 1 TO MaxWords
        SoundexCode$ = SOUNDEX$(Words$[i])
        PRINT i, ". ", q$, Word2Find$, q$;
        IF EQUAL(SOUNDEX$(Word2Find$), SoundexCode$) THEN
            PRINT " sounds like ";
        ELSE
            PRINT " does NOT sound like ";
        END IF
        PRINT q$, Words$[i], q$,"."
    NEXT i
    PRINT
END SUB

' *****************
' END SUBS & FUNCS
' *****************


' *****************
' MAIN
' *****************

INIT_VARS
SOUNDEX_TEST("stupid")
END

' *****************
' END MAIN
' *****************