Data commit

Task/Soundex/TXR/soundex-1.txr

@@ -0,0 +1,74 @@
+@(next :args)
+@###
+@# soundex-related filters
+@###
+@(deffilter remdbl ("AA" "A") ("BB" "B") ("CC" "C") ("DD" "D") ("EE" "E")
+                   ("FF" "F") ("GG" "G") ("HH" "H") ("II" "I") ("JJ" "J")
+                   ("KK" "K") ("LL" "L") ("MM" "M") ("NN" "N") ("OO" "O")
+                   ("PP" "P") ("QQ" "Q") ("RR" "R") ("SS" "S") ("TT" "T")
+                   ("UU" "U") ("VV" "V") ("WW" "W") ("XX" "X") ("YY" "Y")
+                   ("ZZ" "Z"))
+@(deffilter code ("B" "F" "P" "V" "1")
+                 ("C" "G" "J" "K" "Q" "S" "X" "Z" "2")
+                 ("D" "T" "3") ("L" "4") ("M" "N" "5")
+                 ("R" "6") ("A" "E" "I" "O" "U" "Y" "0") ("H" "W" ""))
+@(deffilter squeeze ("11" "111" "1111" "11111" "1")
+                    ("22" "222" "2222" "22222" "2")
+                    ("33" "333" "3333" "33333" "3")
+                    ("44" "444" "4444" "44444" "4")
+                    ("55" "555" "5555" "55555" "5")
+                    ("66" "666" "6666" "66666" "6"))
+@(bind prefix ("VAN" "CON" "DE" "DI" "LA" "LE"))
+@(deffilter remzero ("0" ""))
+@###
+@# soundex function
+@###
+@(define soundex (in out))
+@  (local nodouble letters remainder first rest coded)
+@  (next :string in)
+@  (coll)@{letters /[A-Za-z]+/}@(end)
+@  (cat letters "")
+@  (output :into nodouble :filter (:upcase remdbl))
+@letters
+@  (end)
+@  (next :list nodouble)
+@  (maybe)
+@prefix@remainder
+@    (output :into nodouble)
+@nodouble
+@remainder
+@    (end)
+@  (end)
+@  (next :list nodouble)
+@  (collect)
+@{first 1}@rest
+@    (output :filter (code squeeze remzero) :into coded)
+@{rest}000
+@    (end)
+@    (next :list coded)
+@{digits 3}@(skip)
+@  (end)
+@  (output :into out)
+@    (rep):@first@digits@(first)@first@digits@(end)
+@  (end)
+@  (cat out)
+@(end)
+@###
+@# process arguments and list soundex codes
+@###
+@(collect :vars ())
+@input
+@  (output :filter (:fun soundex))
+@input
+@  (end)
+@(end)
+@###
+@# compare first and second argument under soundex
+@###
+@(bind (first_arg second_arg . rest_args) input)
+@(cases)
+@  (bind first_arg second_arg :filter (:fun soundex))
+@  (output)
+"@first_arg" and "@second_arg" match under soundex
+@  (end)
+@(end)

Task/Soundex/TXR/soundex-2.txr

@@ -0,0 +1,27 @@
+@(do (defun get-code (c)
+       (caseq c
+         ((#\B #\F #\P #\V) #\1)
+         ((#\C #\G #\J #\K #\Q #\S #\X #\Z) #\2)
+         ((#\D #\T) #\3)
+         (#\L #\4)
+         ((#\M #\N) #\5)
+         (#\R #\6)))
+
+     (defun soundex (s)
+       (if (zerop (length s))
+         ""
+         (let* ((su (upcase-str s))
+                (o [su 0]))
+           (for ((i 1) (l (length su)) cp cg)
+                ((< i l) [`@{o}000` 0 4])
+                ((inc i) (set cp cg))
+             (set cg (get-code [su i]))
+             (if (and cg (not (eql cg cp)))
+               (set o `@o@cg`)))))))
+@(next :args)
+@(repeat)
+@arg
+@  (output)
+@arg -> @(soundex arg)
+@  (end)
+@(end)