;;; jumble.scm
;;; Copyright (c) Robert R. Snapp 2005
;;;
;;; (jumble str) returns a list of all permutations of the letters contained in string 
;;; str that exactly match a word contained in a master dictionary. For example,
;;; (jumble "theater") => ("theater" "thereat" "teather")

;;; Modifiable parameters:
;;; *dpath* should be the path name of dictionary file: each entry should be separated by
;;; white space.

;(define *words* "/usr/share/dict/words")
(define *words* "/usr/lib/share/dict/words")
(define *scowl* "/Users/snapp/Library/Dictionaries/scowl-6/final/english-words.80")

(define *dpath* '())
(set! *dpath* *words*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I/O routines

;; read-next-word returns tne next contiguous string of non-whitespace characters from
;; stream s as a character string.

(define read-next-word
  (lambda (stream)
    (letrec ((aux 
              (lambda (word)
                (let ((next-char (read-char stream)))
                  (cond ((eof-object? next-char) 
                         (if (null? word) 
                             '()
                             (list->string (reverse word))))
                        ((char-whitespace? next-char) (list->string (reverse word)))
                        (else (aux (cons next-char word))))))))
      (aux '()))))


(define load-word-vector
  (lambda (stream)
    (let ((words '())
          (words-per-period 10000))
      (do ((next-word (read-next-word stream) (read-next-word stream))
           (word-count 0 (+ word-count 1))) 
        ((null? next-word) (list->vector (reverse words)))
        (if (zero? (modulo word-count words-per-period)) (display "."))
        (if (char-lower-case? (car (string->list next-word)))
            (set! words (cons next-word words)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Binary Search

(define binary-search 
  (lambda (obj vec)
    (letrec ((findobj 
              (lambda (start end)
                (let ((range (- end start)))
                  (if (<= range 0)
                      (if (string=? obj (vector-ref vec start))
                          obj
                          '())
                      (let* ((mid (+ start (round (/ range 2))))
                             (obj2 (vector-ref vec mid)))
                        (if (string<? obj obj2)
                            (findobj start (- mid 1))
                            (if (string>? obj obj2)
                                (findobj (+ mid 1) end)
                                obj))))))))
      (let ((len (vector-length vec)))
        (and (not (zero? len))
             (findobj 0 (- len 1)))))))


;;; map-insert accepts two arguments: a symbol (s) and a list of lists (lol).
;;; A list of lists is returned, where symbol s is placed at the first position of each
;;; list in lol.

(define map-insert
  (lambda (s lol)
    (cond ((null? lol) '())
          (else (cons (cons s (car lol))
                      (map-insert s (cdr lol)))))))

;;; unique-permutations generates the unique permutations of the symblols 
;;; contained in list args.
;;; (unique-permuations '(a b c)) => ((a b c) (a c b) (b a c) (b c a) (c b a) (c a b))
;;; (unique-permuations '(a b a)) => ((a b a) (a a b) (b a a))

(define unique-permutations
  (lambda (args)
    (cond ((null? args) (list '()))
          (else (letrec 
                    ((aux ; aux generates unique permations that include all symbols
                          ; in done and rem, but don't begin with any symbols 
                          ; contained in done.
                      (lambda (done rem)
                        (cond ((null? rem) '())
                              (else
                               (let ((next (car rem))
                                     (rest (cdr rem)))
                                 (if (member next done)
                                     (aux (cons next done) rest)
                                     (append (map-insert 
                                              next
                                              (unique-permutations (append done rest)))
                                             (aux (cons next done) rest)))))))))
                  (aux '() args))))))

;;; *dict* is a vector that is the master dictionary. Each entry should be a character string listed in increasing alphabetic order.

(define *dict* '())

(define legal-words
  (lambda (list-of-strings)
    (cond ((null? list-of-strings) '())
          (else (let ((next (car list-of-strings))
                      (rest (cdr list-of-strings)))
                  (if (null? (binary-search next *dict*))
                      (legal-words rest)
                      (cons next (legal-words rest))))))))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The public interface

;; jumble accepts a string and returns a list of all character permutations that match an entry
;; in the master dictionary. E.g., (jumble "abc") => ("bac" "cab").
;;

(define jumble
  (lambda (str)
    (legal-words (map list->string (unique-permutations (string->list str))))))

;;;;;;;;;;;;;;;;;;;;;
;;; Initialization:

(define initialize-dictionary
  (lambda ()
    (display "Reading dictionary file:")
    (display *dpath*)
    (set! *dict* (call-with-input-file *dpath* load-word-vector))
    (display "done.\n")))

(initialize-dictionary)