codepad

Language:

; soundex

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (test)
  (let ((names1 (list "Euler"  "Gauss" "Hilbert"
                      "Knuth"  "Lloyd" "Lukasiewicz"))
        (names2 (list "Ellery" "Ghosh" "Heilbronn"
                      "Kant"   "Ladd"  "Lissajous"))
        (result (list "E460"   "G200"  "H416"
                      "K530"   "L300"  "L222")))
    (assert (map soundex names1) result)
    (assert (map soundex names2) result)))

(define (soundex str)
  (define (code c)
    ;            ABCDEFGHIJKLMNOPQRSTUVWXYZ
    (string-ref "01230120022455012623010202"
      (- (char->integer (char-upcase c)) 65)))
  (define (finish zs)
    (substring (list->string (reverse
      (append (list #\0 #\0 #\0) zs))) 0 4))
  (let* ((cs (cdr (map char-upcase (string->list str))))
         (f (string-ref str 0)) (fx (code f))
         (prev (if (char=? fx #\0) #\0 fx)))
    (let loop ((cs cs) (zs (list f)) (prev prev))
      (if (null? cs) (finish zs)
        (let ((z (code (car cs))))
          (cond ((char=? z prev) (loop (cdr cs) zs prev))
                ((char=? z #\0) (loop (cdr cs) zs #\0))
                (else (loop (cdr cs) (cons z zs) z))))))))

Private [?]

Run code