23 lines
592 B
Common Lisp
23 lines
592 B
Common Lisp
(defun get-code (c)
|
|
(case 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* ((l (coerce (string-upcase s) 'list))
|
|
(o (list (first l))))
|
|
(loop for c in (rest l)
|
|
for cg = (get-code c) and
|
|
for cp = #\Z then cg
|
|
when (and cg (not (eql cg cp))) do
|
|
(push cg o)
|
|
finally
|
|
(return (subseq (coerce (nreverse `(#\0 #\0 #\0 ,@o)) 'string) 0 4))))))
|