diff options
Diffstat (limited to 'soundex.scm')
| -rw-r--r-- | soundex.scm | 30 |
1 files changed, 15 insertions, 15 deletions
diff --git a/soundex.scm b/soundex.scm index eb3a542..6d73341 100644 --- a/soundex.scm +++ b/soundex.scm @@ -8,16 +8,16 @@ ; Taken from Knuth, Vol. 3 "Sorting and searching", pp 391--2 (require 'common-list-functions) - +;@ (define SOUNDEX (let* ((letters-to-omit - (list #\A #\E #\H #\I #\O #\U #\W #\Y)) + (list #\A #\E #\H #\I #\O #\U #\W #\Y)) (codes (list (list #\B #\1) (list #\F #\1) (list #\P #\1) (list #\V #\1) - ; + ;; (list #\C #\2) (list #\G #\2) (list #\J #\2) @@ -26,19 +26,19 @@ (list #\S #\2) (list #\X #\2) (list #\Z #\2) - ; + ;; (list #\D #\3) (list #\T #\3) - ; + ;; (list #\L #\4) - ; + ;; (list #\M #\5) (list #\N #\5) - ; + ;; (list #\R #\6))) (xform (lambda (c) - (let ((code (assq c codes))) + (let ((code (assv c codes))) (if code (cadr code) c))))) @@ -50,10 +50,10 @@ (string->list name))))) (if (null? char-list) name - (let* (; Replace letters except first with codes: + (let* ( ;; Replace letters except first with codes: (n1 (cons (car char-list) (map xform char-list))) - ; If 2 or more letter with same code are adjacent - ; in the original name, omit all but the first: + ;; If 2 or more letter with same code are adjacent + ;; in the original name, omit all but the first: (n2 (let loop ((chars n1)) (cond ((null? (cdr chars)) chars) @@ -62,14 +62,14 @@ (cadr chars)) (loop (cdr chars)) (cons (car chars) (loop (cdr chars)))))))) - ; Omit vowels and similar letters, except first: + ;; Omit vowels and similar letters, except first: (n3 (cons (car char-list) (remove-if (lambda (c) - (memq c letters-to-omit)) + (memv c letters-to-omit)) (cdr n2))))) - ; - ; pad with 0's or drop rightmost digits until of form "annn": + ;; + ;; pad with 0's or drop rightmost digits until of form "annn": (let loop ((rev-chars (reverse n3))) (let ((len (length rev-chars))) (cond ((= 4 len) |