codepad

Language:

; rhyming dictionary

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

(define (any? pred? xs)
  (cond ((null? xs) #f)
        ((pred? (car xs)) #t)
        (else (any? pred? (cdr xs)))))

(define (read-dict file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop ((line (read-line))) ; discard commentary
        (if (string=? "##" (substring line 0 2))
            (loop (read-line))))
      (let loop ((line (read-line)) (ds (list)))
        (if (eof-object? line) ds
          (loop (read-line)
                (let ((xs (string-split #\space line)))
                  (cons (cons (car xs) (reverse (cddr xs))) ds))))))))

(define (vowel? str)
  (let ((len (string-length str)))
    (char-numeric? (string-ref str (- len 1)))))

(define dict
  (filter (lambda (w) (any? vowel? w))
    (map (lambda (w) (remove "" w))
      (read-dict "c06d"))))

(define (rhyme? w1 w2)
  (let ((d1 (assoc w1 dict)) (d2 (assoc w2 dict)))
    (if (not (and d1 d2)) -1
      (if (string=? w1 w2) 0
        (let loop ((d1 (cdr d1)) (d2 (cdr d2)))
          (cond ((or (null? d1) (null? d2)) #f)
                ((not (string=? (car d1) (car d2))) #f)
                ((vowel? (car d1)) #t)
                (else (loop (cdr d1) (cdr d2)))))))))

(define (sign phonemes)
  (let loop ((ps phonemes) (ss (list)))
    (if (null? ps) #f
      (if (vowel? (car ps))
          (string-join #\space (cons (car ps) ss))
          (loop (cdr ps) (cons (car ps) ss))))))

(define (group eql? xs)
  (let loop ((xs xs) (ys (list)) (zs (list)))
    (cond ((and (null? xs) (null? ys)) zs)
          ((and (null? xs) (pair? ys)) (cons ys zs))
          ((null? ys)
            (loop (cdr xs)
                  (cons (caar xs) (list (cdar xs)))
                  zs))
          ((eql? (caar xs) (car ys))
            (loop (cdr xs)
                  (cons (car ys) (cons (cdar xs) (cdr ys)))
                  zs))
          (else (loop (cdr xs)
                      (cons (caar xs) (list (cdar xs)))
                      (cons ys zs))))))

(define sign-dict
  (group string=?
    (sort (lambda (x y) (string<? (car x) (car y)))
      (map (lambda (w) (cons (sign (cdr w)) (car w))) dict))))

(define (rhymes word)
  (cdr (assoc (sign (cdr (assoc word dict))) sign-dict)))

Private [?]

Run code