aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Just another update

Browse source
This commit is contained in:
Ingy döt Net 2015-02-20 00:35:01 -05:00
parent a25938f123
commit 00a190b0a6
6591 changed files with 94363 additions and 23227 deletions
Download patch file Download diff file Expand all files Collapse all files

22
Task/Soundex/TXR/soundex-2.txr
View file

@ -1,12 +1,11 @@
@(next :args)
@(do (defun get-code (c)
(cond ((memq c '(#\B #\F #\P #\V)) #\1)
((memq c '(#\C #\G #\J #\K
#\Q #\S #\X #\Z)) #\2)
((memq c '(#\D #\T)) #\3)
((eql c #\L) #\4)
((memq c '(#\M #\N)) #\5)
((eq c #\R) #\6)))
(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))
@ -14,12 +13,13 @@
(let* ((su (upcase-str s))
(o (chr-str su 0)))
(for ((i 1) (l (length su)) cp cg)
((< i l) (sub-str (cat-str '(,o "000") nil) 0 4))
((< i l) (sub-str (cat-str ^(,o "000") nil) 0 4))
((inc i) (set cp cg))
(set cg (get-code (chr-str su i)))
(if (and cg (null (eql cg cp)))
(set o (cat-str '(,o ,cg) nil))))))))
@(collect)
(set o (cat-str ^(,o ,cg) nil))))))))
@(next :args)
@(repeat)
@arg
@ (output)
@arg -> @(soundex arg)