; anagram phrases

(define (remove x xs)
  (let loop ((xs xs) (zs '()))
    (cond ((null? xs) (reverse zs))
          ((equal? (car xs) x) (loop (cdr xs) zs))
          (else (loop (cdr xs) (cons (car xs) zs))))))

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

(define (map-input reader proc . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (result '()))
      (if (eof-object? item)
          (begin (if f? (close-input-port p)) (reverse result))
          (loop (reader p) (cons (proc item) result))))))

(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 (filter-input reader pred?)
  (lambda args
    (let loop ((item (apply reader args)))
      (if (or (eof-object? item) (pred? item)) item
        (loop (apply reader args))))))

(define (read-words dict)
  (define (valid? word)
    (and (< 2 (string-length word))
         (all? (and char-alphabetic? char-lower-case?)
               (string->list word))))
  (define (proc word)
    (cons word (sort char<? (string->list word))))
  (map-input (filter-input read-line valid?) proc dict))

(define words (read-words "moby.common"))

(define (relevant cs words)
  (filter (lambda (w) (minus cs (cdr w))) words))

(define (minus xs ys)
  (let loop ((xs xs) (ys ys) (zs (list)))
    (cond ((null? ys) (append (reverse zs) xs))
          ((null? xs) #f)
          ((char<? (car xs) (car ys))
            (loop (cdr xs) ys (cons (car xs) zs)))
          ((char<? (car ys) (car xs)) #f)
          (else (loop (cdr xs) (cdr ys) zs)))))

(define (anagrams str words)
  (let* ((cs (sort char<? (map char-downcase
               (remove #\space (string->list str)))))
         (ws (relevant cs words)))
    (map (lambda (ws) (sort string<? ws)) (reverse
      (let anagrams ((cs cs) (ws ws))
        (define (cons-x x) (lambda (xs) (cons x xs)))
        (cond ((null? cs) (list (list)))
              ((null? ws) #f)
              ((equal? cs (cdar ws))
                (list (list (caar ws))))
              (else (append
                (let ((tss (anagrams cs (cdr ws))))
                  (if tss tss (list)))
                (let ((ts (minus cs (cdar ws))))
                  (if ts (let ((tss (anagrams ts (cdr ws))))
                           (if tss (map (cons-x (caar ws)) tss) (list)))
                      (list)))))))))))