' **************************************************************
' PROGRAM: FUNCTION METAPHONE(STRING x$)
' PURPOSE: metaphone calculator
' ARGUMENT: a single word
' RETURNS: metaphone code for the word passed as an argument
' AUTHOR: vovchik (Puppy Linux forum)
' DEPENDS: bacon, bash
' PLATFORM: Puppy Linux (actually, any *nix)
' DATE: 24-03-2010
' VERSION: 0.01a
' NOTES: Remove DECLARATIONS, INIT_VARS and METAPHONE_TEST
' to use METAPHONE(x$) in your own programs.
'
' See also: http://en.wikipedia.org/wiki/Metaphone
'
' ***************************************************************
' Original C version by Michael Kuhn
' Translated from C to Delphi by Tom White
' Translated to Visual Basic by Dave White
' ***************************************************************
' *****************
' 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 INSERTSTR$(STRING oldtxt$, NUMBER mypos, STRING inserttxt$)
' --------
LOCAL txt$, myresult
txt$ = CONCAT$(LEFT$(oldtxt$, mypos - 1), inserttxt$)
txt$ = CONCAT$(txt$, MID$(oldtxt$, mypos + LEN(inserttxt$)))
myresult$ = LEFT$(txt$, LEN(oldtxt$))
RETURN myresult$
END FUNCTION
FUNCTION InStrC(STRING SearchIn$, STRING SoughtCharacters$)
LOCAL myresult, i
' Returns the position of the first character in SearchIn that is contained
' in the STRING SoughtCharacters. Returns 0 IF none found.
SoughtCharacters$ = UCASE$(SoughtCharacters$)
SearchIn$ = UCASE$(SearchIn$)
FOR i = 1 TO LEN(SearchIn$)
IF INSTR(SoughtCharacters$, MID$(SearchIn$, i, 1)) > 0 THEN
myresult = i
RETURN myresult
END IF
NEXT i
myreturn = 0
RETURN myresult
END FUNCTION
FUNCTION METAPHONE$(STRING A$)
LOCAL inp$, outp$, myreturn$ TYPE STRING
LOCAL vowels$, frontv$, varson$, dbl$ TYPE STRING
LOCAL excppair$, nxtltr$ TYPE STRING
LOCAL curltr$, prevltr$, nextltr$, nextltr2$, nextltr3$ TYPE STRING
LOCAL alphachr$ TYPE STRING
LOCAL T, ii, jj, lng, lastchr TYPE NUMBER
LOCAL vowelafter, vowelbefore, frontvafter, silent, hard TYPE NUMBER
IF LEN(A$) < 1 THEN
A$ = ""
END IF
inp$ = UCASE$(A$)
vowels$ = "AEIOU"
frontv$ = "EIY"
varson$ = "CSPTG"
' Lets us allow certain letters to be doubled
dbl$ = "."
excppair$ = "AGKPW"
nxtltr$ = "ENNNR"
alphachr$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
' Remove non-alpha characters
outp$ = ""
FOR T = 1 TO LEN(inp$)
IF INSTR(alphachr$, MID$(inp$, T, 1)) > 0 THEN
outp$ = CONCAT$(outp$, MID$(inp$, T, 1))
END IF
NEXT T
inp$ = outp$
outp$ = ""
IF LEN(inp$) EQ 0 THEN
myreturn$ = ""
RETURN myreturn$
END IF
' Check rules at beginning of word
IF LEN(inp$) > 1 THEN
b$ = MID$(inp$, 1, 1)
c$ = MID$(inp$, 2, 1)
ii = INSTR(excppair$, b$)
jj = INSTR(nxtltr$, c$)
IF ii EQ jj AND ii > 0 THEN
inp$ = MID$(inp$, 2, LEN(inp$) - 1)
END IF
END IF
IF EQUAL(MID$(inp$, 1, 1), "X") THEN
inp$ = INSERTSTR$(inp$, 1, "S")
END IF
IF EQUAL(MID$(inp$, 1, 2), "WH") THEN
inp$ = CONCAT$("W", MID$(inp$, 3))
END IF
IF EQUAL(RIGHT$(inp$, 1), "S") THEN
inp$ = LEFT$(inp$, LEN(inp$) - 1)
END IF
ii = 0
' Main loop
REPEAT
ii = ii + 1
silent = FALSE
hard = FALSE
curltr$ = MID$(inp$, ii, 1)
vowelbefore = FALSE
prevltr$ = " "
IF ii > 1 THEN
prevltr$ = MID$(inp$, ii - 1, 1)
IF InStrC(prevltr$, vowels$) > 0 THEN
vowelbefore = TRUE
END IF
END IF
IF ((ii EQ 1) AND (InStrC(curltr$, vowels$) > 0)) THEN
outp$ = CONCAT$(outp$, curltr$)
GOTO ContinueMainLOOP
END IF
vowelafter = FALSE
frontvafter = FALSE
nextltr$ = " "
IF ii < LEN(inp$) THEN
nextltr$ = MID$(inp$, ii + 1, 1)
IF InStrC(nextltr$, vowels$) > 0 THEN
vowelafter = TRUE
END IF
IF InStrC(nextltr$, frontv$) > 0 THEN
frontvafter = TRUE
END IF
END IF
' Skip double letters EXCEPT ones in variable double
IF InStrC(curltr$, dbl$) EQ 0 THEN
IF EQUAL(curltr$, nextltr$) THEN
GOTO ContinueMainLOOP
END IF
END IF
nextltr2$ = " "
IF LEN(inp$) - ii > 1 THEN
nextltr2$ = MID$(inp$, ii + 2, 1)
END IF
nextltr3$ = " "
IF (LEN(inp$) - ii) > 2 THEN
nextltr3$ = MID$(inp$, ii + 3, 1)
END IF
SELECT curltr$
CASE "B"
silent = FALSE
IF (ii EQ LEN(inp$)) AND EQUAL(prevltr$, "M") THEN
silent = TRUE
END IF
IF NOT(silent) THEN
outp$ = CONCAT$(outp$, curltr$)
END IF
CASE "C"
IF NOT((ii > 2) AND EQUAL(prevltr$, "S") AND frontvafter) THEN
IF ((ii > 1) AND EQUAL(nextltr$, "I") AND (EQUAL(nextltr2$, "A"))) THEN
outp$ = CONCAT$(outp$, "X")
ELSE
IF frontvafter THEN
outp$ = CONCAT$(outp$, "S")
ELSE
IF ((ii > 2) AND (EQUAL(prevltr$, "S")) AND (EQUAL(nextltr$, "H"))) THEN
outp$ = CONCAT$(outp$, "K")
ELSE
IF EQUAL(nextltr$, "H") THEN
IF ((ii EQ 1) AND (InStrC(nextltr2$, vowels$) EQ 0)) THEN
outp$ = CONCAT$(outp$, "K")
ELSE
outp$ = CONCAT$(outp$, "X")
END IF
ELSE
IF EQUAL(prevltr$, "C") THEN
outp$ = CONCAT$(outp$, "C")
ELSE
outp$ = CONCAT$(outp$, "K")
END IF
END IF
END IF
END IF
END IF
END IF
CASE "D"
IF ((EQUAL(nextltr$, "G")) AND (InStrC(nextltr2$, frontv$) > 0)) THEN
outp$ = CONCAT$(outp$, "J")
ELSE
outp$ = CONCAT$(outp$, "T")
END IF
CASE "G"
silent = FALSE
IF ((ii < LEN(inp$)) AND (EQUAL(nextltr$, "H")) AND (InStrC(nextltr2$, vowels$) EQ 0)) THEN
silent = TRUE
END IF
IF ((ii EQ LEN(inp$) - 4) AND (EQUAL(nextltr$, "N")) AND (EQUAL(nextltr2$, "E")) AND (EQUAL(nextltr3$, "D"))) THEN
silent = TRUE
ELIF ((ii EQ LEN(inp$) - 2) AND (EQUAL(nextltr$, "N"))) THEN
silent = TRUE
END IF
IF (EQUAL(prevltr$, "D")) AND frontvafter THEN
silent = TRUE
END IF
IF EQUAL(prevltr$, "G") THEN
hard = TRUE
END IF
IF NOT(silent) THEN
IF frontvafter AND (NOT(hard)) THEN
outp$ = CONCAT$(outp$, "J")
ELSE
outp$ = CONCAT$(outp$, "K")
END IF
END IF
CASE "H"
silent = FALSE
IF InStrC(prevltr$, varson$) > 0 THEN
silent = TRUE
END IF
IF vowelbefore AND (NOT(vowelafter)) THEN
silent = TRUE
END IF
IF NOT(silent) THEN
outp$ = CONCAT$(outp$, curltr$)
END IF
CASE "F";
CASE "J";
CASE "L";
CASE "M";
CASE "N";
CASE "R"
outp$ = CONCAT$(outp$, curltr$)
CASE "K"
IF NOT(EQUAL(prevltr$, "C")) THEN
outp$ = CONCAT$(outp$, curltr$)
END IF
CASE "P"
IF EQUAL(nextltr$, "H") THEN
outp$ = CONCAT$(outp$, "F")
ELSE
outp$ = CONCAT$(outp$, "P")
END IF
CASE "Q"
outp$ = CONCAT$(outp$, "K")
CASE "S"
IF ((ii > 2) AND (EQUAL(nextltr$, "I")) AND ((EQUAL(nextltr2$, "O")) OR (EQUAL(nextltr2$, "A")))) THEN
outp$ = CONCAT$(outp$, "X")
END IF
IF (EQUAL(nextltr$, "H")) THEN
outp$ = CONCAT$(outp$, "X")
ELSE
outp$ = CONCAT$(outp$, "S")
END IF
CASE "T"
IF ((ii > 0) AND (CONCAT$(nextltr$, "I")) AND ((CONCAT$(nextltr2$, "O")) OR (CONCAT$(nextltr2$, "A")))) THEN
outp$ = CONCAT$(outp$, "X")
END IF
IF EQUAL(nextltr$, "H") THEN
IF ((ii > 1) OR (InStrC(nextltr2$, vowels$) > 0)) THEN
outp$ = CONCAT$(outp$, "0")
ELSE
outp$ = CONCAT$(outp$, "T")
END IF
ELIF NOT((ii < LEN(inp$) - 3) AND (EQUAL(nextltr$, "C")) AND (EQUAL(nextltr2$, "H"))) THEN
outp$ = CONCAT$(outp$, "T")
END IF
CASE "V"
outp$ = CONCAT$(outp$, "F")
CASE "W";
CASE "Y"
IF (ii < LEN(inp$) - 1) AND vowelafter THEN
outp$ = CONCAT$(outp$, curltr$)
END IF
CASE "X"
outp$ = CONCAT$(outp$, "KS")
CASE "Z"
outp$ = CONCAT$(outp$, "S")
END SELECT
LABEL ContinueMainLOOP
UNTIL (ii > LEN(inp$))
RETURN outp$
END FUNCTION
' --------
SUB METAPHONE_TEST(STRING Word2Find$)
' --------
LOCAL MetaPhoneCode$
LOCAL i
PRINT
FOR i = 1 TO MaxWords
MetaPhoneCode$ = METAPHONE$(Words$[i])
PRINT i, ". ", q$, Word2Find$, q$;
IF EQUAL(METAPHONE$(Word2Find$), MetaPhoneCode$) 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
METAPHONE_TEST("stupid")
END
' *****************
' END MAIN
' *****************