;;; jumble2005.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:
;;; *word-paths* is a list of path names that will be searched in the order that they appear.
;;; One of them should correspond to a word dictionary, i.e. a comprehensive list of english
;;; words, with one word per line.


(define *word-paths*
  '("words"                          ; use the local dictionary first, if it exists.
    "web2"                           ; An alternate local dictionary name
   "/usr/share/dict/words"           ; mac default dictionary path
   "R:\\cs32\\web2.dat"              ; dictionary path for Votey's windows machines.
   "/usr/lib/share/dict/words"       ; unix default dictionary path
   "/usr/share/lib/dict/words"       ; alternate unix path
   "/usr/dict/words"))               ; another choice


;;; Language check --- we need to use the MzScheme file library, so check the language.
(display "Language should be set to PLT->MzScheme or better.")
(newline)

(require (lib "file.ss")) ;;; Will generate an error if require is not defined.


;;; dict-search accepts a list of strings, where each character string represents a possible path for a dictionary.
;;; The first path that is found to exist on the current machine is returned. Otherwise #f is returned.
;;;
(define dict-search
  (lambda (x)
    (cond ((null? x) #f)
          ((file-exists? (car x)) (car x))
          (else (dict-search (cdr x))))))
          

(define *dpath* #f)
(display "Looking for master dictionary: a file named words ...")

(let ((words (dict-search *word-paths*)))
  (if words
     (begin (display " found ") (set! *dpath* words) (display *dpath*) (newline))
     (error " whoops! Can't find a master dictionary. Try to download words.")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I/O routines

;; read-next-word returns the 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 ()
    (begin
      (display "Reading the dictionary file:")
      (display *dpath*)
      (set! *dict* (call-with-input-file *dpath* load-word-vector))
      (display "done (")
      (display (vector-length *dict*))
      (display " words)."))))

(initialize-dictionary)