27 lines
671 B
Text
27 lines
671 B
Text
@(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)
|