Data update

Task/Soundex/Emacs-Lisp/soundex.l

@@ -0,0 +1,108 @@
+(defconst articulation-1 '("b" "f" "p" "v" "B" "F" "P" "V"))
+
+(defconst articulation-2 '("c" "g" "j" "k" "q" "s" "x" "z" "C" "G" "J" "K" "Q" "S" "X" "Z"))
+
+(defconst articulation-3 '("d" "t" "D" "T"))
+
+(defconst articulation-4 '("l" "L"))
+
+(defconst articulation-5 '("m" "n" "M" "N"))
+
+(defconst articulation-6 '("r" "R"))
+
+(defconst vowel '("a" "e" "i" "o" "u" "A" "E" "I" "O" "U"))
+
+(defconst semi-vowels '("h" "w" "y" "H" "W" "Y"))
+
+(defun drop-vowels (str)
+  "Keep first letter, drop a, e, i, o, u."
+  (let ((first-letter (substring str 0 1))
+        (string-minus-first-letter (substring str 1)))
+    (concat first-letter (replace-regexp-in-string "[aeiou]" "" string-minus-first-letter))))
+
+(defun drop-semi-vowels (str)
+  "Keep first letter, drop h, w, y."
+  (let ((first-letter (substring str 0 1))
+        (string-minus-first-letter (substring str 1)))
+    (concat first-letter (replace-regexp-in-string "[hwy]" "" string-minus-first-letter))))
+
+(defun drop-repeated-adjacent-consonants (str)
+  "Drop repeated adjacent consonants with same Soundex number."
+  (let ((current-letter)
+        (next-letter)
+        (current-soundex-number)
+        (next-soundex-number)
+        (modified-word str)
+        (position-in-word 0))
+    (condition-case nil
+        (while (substring modified-word position-in-word (+ 2 position-in-word))
+          (setq current-letter (substring modified-word position-in-word (1+ position-in-word)))
+          (setq next-letter (substring modified-word (1+ position-in-word) (+ position-in-word 2)))
+          (setq current-soundex-number (get-soundex-number current-letter))
+          (setq next-soundex-number (get-soundex-number next-letter))
+          (when (and
+                 (equal current-soundex-number next-soundex-number)
+                 (member current-soundex-number '("1" "2" "3" "4" "5")))
+            (setq modified-word (replace-regexp-in-string (concat current-letter next-letter) current-letter modified-word)))
+          (setq position-in-word (1+ position-in-word)))
+      (error nil))
+    modified-word))
+
+(defun get-soundex-number (letter)
+  "Get the Soundex number of LETTER.
+LETTER should be a string of just one letter.
+Soundex numbers are numbers 1-6.
+If the letter is a vowel or y, h, or w, there is
+no Soundex number, so get an 8 for a vowel or a 9
+for y, y, or w."
+  (cond ((member letter articulation-1) "1")
+        ((member letter articulation-2) "2")
+        ((member letter articulation-3) "3")
+        ((member letter articulation-4) "4")
+        ((member letter articulation-5) "5")
+        ((member letter articulation-6) "6")
+        ((member letter vowel)          "8")
+        ((member letter semi-vowel)     "9")))
+
+(defun soundex-all-but-first-letter (str)
+  "Converts STR to Soundex except for first letter.
+For this function to work correctly, vowels and
+h, w, and y must have already been removed.
+Also, certain consonants must have already been
+removed per the Soundex processing rules."
+  (let ((word-position 0)
+        (current-letter)
+        (converted-word "")
+        (converted-character "")
+        (word-length (length str)))
+    (while (< word-position word-length)
+      (setq current-letter (substring str word-position (1+ word-position)))
+      (if (> word-position 0)
+          (setq converted-character (get-soundex-number current-letter))
+        (setq converted-character current-letter))
+      (setq word-position (1+ word-position))
+      (setq converted-word (concat converted-character converted-word)))
+    (setq converted-word (reverse converted-word))
+    (setq word-length (length converted-word))
+    (cond ((= word-length 4)
+           converted-word)
+          ((> word-length 4)
+           (substring converted-word 0 4))
+          ((< word-length 4)
+           (let* ((difference (- 4 word-length))
+                  (pad ""))
+             (dotimes (_ difference)
+               (setq pad (concat "0" pad)))
+             (concat converted-word pad))))))
+
+(defun soundex-word (str)
+  "Code STR to Soundex.
+This function applies all the steps needed
+to code STR into the correct Soundex code."
+  (let ((converted-word str))
+    (setq converted-word (drop-repeated-adjacent-consonants converted-word))
+    (setq converted-word (drop-semi-vowels converted-word))
+    (setq converted-word (drop-repeated-adjacent-consonants converted-word))
+    (setq converted-word (drop-vowels converted-word))
+    (setq converted-word (soundex-all-but-first-letter converted-word))
+    converted-word))

Task/Soundex/QBasic/soundex.basic

@@ -0,0 +1,37 @@
+DECLARE FUNCTION getCode$ (c$)
+DECLARE FUNCTION Soundex$ (palabra$)
+
+FOR i = 1 TO 20
+    READ nombre$
+    PRINT ""; ""; nombre$; ""; ""; TAB(15); Soundex$(nombre$)
+NEXT i
+
+DATA "Aschraft","Ashcroft","Euler","Gauss","Ghosh","Hilbert","Heilbronn","Lee","Lissajous","Lloyd"
+DATA "Moses","Pfister","Robert","Rupert","Rubin","Tymczak","VanDeusen","Wheaton","Soundex$","Example"
+
+FUNCTION getCode$ (c$)
+    IF INSTR("BFPV", c$) THEN getCode$ = "1"
+    IF INSTR("CGJKQSXZ", c$) THEN getCode$ = "2"
+    IF INSTR("DT", c$) THEN getCode$ = "3"
+    IF "L" = c$ THEN getCode$ = "4"
+    IF INSTR("MN", c$) THEN getCode$ = "5"
+    IF "R" = c$ THEN getCode$ = "6"
+    IF INSTR("HW", c$) THEN getCode$ = "."
+END FUNCTION
+
+FUNCTION Soundex$ (palabra$)
+    palabra$ = UCASE$(palabra$)
+    code$ = MID$(palabra$, 1, 1)
+    previo$ = getCode$(LEFT$(palabra$, 1)) ''""
+
+    FOR i = 2 TO (LEN(palabra$))
+        actual$ = getCode$(MID$(palabra$, i, 1))
+        IF actual$ <> "." THEN
+            IF LEN(actual$) > 0 AND actual$ <> previo$ THEN code$ = code$ + actual$
+            previo$ = actual$
+            IF LEN(code$) = 4 THEN EXIT FOR
+        END IF
+    NEXT i
+    IF LEN(code$) < 4 THEN code$ = code$ + STRING$(4 - LEN(code$), "0")
+    Soundex$ = LEFT$(code$, 4)
+END FUNCTION

Task/Soundex/True-BASIC/soundex.basic

@@ -0,0 +1,33 @@
+FUNCTION getcode$(c$)
+    IF POS("BFPV",c$)<>0 THEN LET getcode$ = "1"
+    IF POS("CGJKQSXZ",c$)<>0 THEN LET getcode$ = "2"
+    IF POS("DT",c$)<>0 THEN LET getcode$ = "3"
+    IF "L" = c$ THEN LET getcode$ = "4"
+    IF POS("MN",c$)<>0 THEN LET getcode$ = "5"
+    IF "R" = c$ THEN LET getcode$ = "6"
+    IF POS("HW",c$)<>0 THEN LET getcode$ = "."
+END FUNCTION
+
+FUNCTION soundex$(palabra$)
+    LET palabra$ = UCASE$(palabra$)
+    LET code$ = (palabra$)[1:1+1-1]
+    LET previo$ = getcode$((palabra$)[1:1])
+    FOR i = 2 TO (LEN(palabra$))
+    LET actual$ = getcode$((palabra$)[i:i+1-1])
+    IF actual$ <> "." THEN
+       IF LEN(actual$) > 0 AND actual$ <> previo$ THEN LET code$ = code$ & actual$
+       LET previo$ = actual$
+       IF LEN(code$) = 4 THEN EXIT FOR
+    END IF
+NEXT i
+IF LEN(code$) < 4 THEN LET code$ = code$ & repeat$("0"[1:1],4-LEN(code$))
+LET soundex$ = (code$)[1:4]
+END FUNCTION
+
+FOR i = 1 TO 20
+READ nombre$
+PRINT ""; ""; nombre$; ""; ""; TAB(15); soundex$(nombre$)
+NEXT i
+DATA "Aschraft", "Ashcroft", "Euler", "Gauss", "Ghosh", "Hilbert", "Heilbronn", "Lee", "Lissajous", "Lloyd"
+DATA "Moses", "Pfister", "Robert", "Rupert", "Rubin", "Tymczak", "VanDeusen", "Wheaton", "Soundex$", "Example"
+END

Task/Soundex/Yabasic/soundex.basic

@@ -0,0 +1,36 @@
+restore
+for c = 1 to 20
+    read nombre$
+    print "\"", nombre$, "\"   \t", Soundex$(nombre$)
+next c
+data "Aschraft","Ashcroft","Euler","Gauss","Ghosh","Hilbert","Heilbronn","Lee","Lissajous","Lloyd"
+data "Moses","Pfister","Robert","Rupert","Rubin","Tymczak","VanDeusen","Wheaton","Soundex$","Example"
+print
+end
+
+sub getCode$ (c$)
+    if instr("BFPV", c$)  return "1"
+    if instr("CGJKQSXZ", c$)  return "2"
+    if instr("DT", c$)  return "3"
+    if "L" = c$  return "4"
+    if instr("MN", c$)  return "5"
+    if "R" = c$  return "6"
+    if instr("HW", c$)  return "."
+end sub
+
+sub Soundex$ (palabra$)
+    palabra$ = upper$(palabra$)
+    code$ = mid$(palabra$, 1, 1)
+    previo$ = getCode$(left$(palabra$, 1))
+
+    for i = 2 to (len(palabra$))
+        actual$ = getCode$(mid$(palabra$, i, 1))
+        if actual$ <> "." then
+            if len(actual$) > 0 and actual$ <> previo$  code$ = code$ + actual$
+            previo$ = actual$
+            if len(code$) = 4  break
+        end if
+    next i
+    if len(code$) < 4  code$ = left$(code$ + "0000", 4)
+    return left$(code$, 4)
+end sub