; Here's my code for your study.  The time I spent on it:
;
; $ date
; Thu Oct 21 21:37:32 PDT 1999          start
; [~20 minute interruption in here somewhere]
; $ date
; Thu Oct 21 23:55:53 PDT 1999          in final form
;
; (Er, ignore the date, just look at the time -- I never bothered to fix
; the clock.)
;
; A few notes: 
;
; - The first two functions below have nonportable definitions, but
; should work with any Scheme I know.  I've tested it on SCM and my own
; Scheme interpreter.
;
; - To run, load this and call (test-me).  See that function for where
; it gets its input.
;
; - Most of the code I had lying around already.  The new code is those
; two nonportable functions plus everything after the comment saying
; `encode.scm'.
;
; - I think this could be a little cleaner still, and I'm certain it
; could be more efficient, but I stopped at the point of diminishing
; returns.
;
; Enjoy!
;
; -Darius

;;; helpers.scm

;; nonportable
(define character->digit
  (lambda (c)
    (- (char->integer c) (char->integer #\0))))

;; nonportable
(define digit->character
  (lambda (digit)
    (integer->char (+ digit (char->integer #\0)))))

;; Return all elements of LS for which TEST? is true, in order.
(define filter
  (lambda (test? ls)
    (let loop ((ls ls))
      (cond ((null? ls)
	     '())
	    ((test? (car ls))
	     (cons (car ls) (loop (cdr ls))))
	    (else (loop (cdr ls)))))))

(define read-line
  (lambda (port)
    (let loop ((acc '()))
      (let ((c (read-char port)))
	(cond ((eof-object? c)
	       (if (null? acc)
		   c
		   (list->string (reverse acc))))
	      ((char=? c #\newline)
	       (list->string (reverse acc)))
	      (else
	       (loop (cons c acc))))))))

(define for-each-input-line
  (lambda (proc port)
    (let reading ()
      (let ((line (read-line port)))
	(cond ((not (eof-object? line))
	       (proc line)
	       (reading)))))))


;;; trie.scm
;;;
;;; Tries
;;;
;;; A trie is a set of sequences.
;;;
;;; We represent it by a pair of:
;;;  - a flag telling whether the empty list is in the set, and
;;;  - an a-list mapping each different CAR of all sequences in the
;;; set to the trie for all the CDRs of the sequences with that CAR.
;;;
;;; Many of the functions take a parameter =? which compares sequence
;;; elements for equality.  An XS parameter will be a list of such
;;; elements.
;;;
;;; I haven't needed to implement deletion yet...
;;; 
;;; Darius Bacon <djello@well.com>
;;; http://www.well.com/~djello
;;; 


(define trie/make cons)
(define trie/null? car) 
(define trie/a-list cdr)
(define trie/set-null! set-car!) 
(define trie/set-a-list! set-cdr!)

;; Return an equivalent of ASSOC that compares using =?.
(define trie/associator
  (lambda (=?)
    (cond ((eq? =? eq?) assq)
	  ((eq? =? eqv?) assv)
	  ((eq? =? equal?) assoc)
	  (else
	   (lambda (x a-list)
	     (let searching ((a-list a-list))
	       (cond ((null? a-list) #f)
		     ((=? x (caar a-list)) (car a-list))
		     (else (searching (cdr a-list))))))))))


;; Return a new trie with no members.
(define make-empty-trie
  (lambda () 
    (trie/make #f '())))

;; Return true iff TRIE has no members.
(define trie-empty?
  (lambda (trie)
    (and (not (trie/null? trie))
	 (null? (trie/a-list trie)))))

;; Return the set of all CARs of members of TRIE, as an unordered
;; list without duplicates.
(define trie-prefixes
  (lambda (trie)
    (map car (trie/a-list trie))))

;; Mutate TRIE to have the new member XS if it doesn't already.
(define trie-adjoin!
  (lambda (=?)
    (let ((step (trie-step =? #t)))
      (lambda (trie xs)
	(let stepping ((trie trie) (xs xs))
	  (if (null? xs) 
	      (trie/set-null! trie #t)
	      (stepping (step trie (car xs))
			(cdr xs))))))))

;; Return true iff TRIE has the member XS.
(define trie-member?
  (lambda (=?)
    (let ((step (trie-step =? #f)))
      (lambda (trie xs)
	(let stepping ((trie trie) (xs xs))
	  (cond ((not trie) #f)
		((null? xs) (trie/null? trie))
		(else 
		 (stepping (step trie (car xs))
			   (cdr xs)))))))))

;; Return the trie containing all the CDRs of the sequences in TRIE
;; whose CAR equals X; or #f if none.  (Mutations to the returned trie
;; also affect TRIE.)  If EXTEND?, then extend the trie if none.
(define trie-step
  (lambda (=? extend?)
    (let ((ass= (trie/associator =?)))
      (lambda (trie x)
	(cond ((ass= x (trie/a-list trie))
	       => cdr)
	      (extend?
	       (let ((new (make-empty-trie)))
		 (trie/set-a-list! trie (cons (cons x new) 
					      (trie/a-list trie)))
		 new))
	      (else #f))))))


;;; encode.scm

(define dictionary (make-empty-trie))

(define test-me
  (lambda ()
    (test-on-files "study-dict.txt" "lots-of-phone-numbers")))

(define test-on-files
  (lambda (dictionary-file phone-file)
    (call-with-input-file dictionary-file
      (lambda (port)
	(install-dictionary! dictionary port)))
    (call-with-input-file phone-file
      (lambda (port)
	(write-encodings port (current-output-port))))))

(define write-encodings
  (lambda (phone-port out-port)
    (for-each-input-line (lambda (phone)
			   (write-output-lines phone out-port))
			 phone-port)))

;; Compute each possible encoding for PHONE (a string) and write it to
;; PORT formatted as in the requirements.
(define write-output-lines
  (lambda (phone port)
    (for-each-encoding (parse-phone phone)
		       (lambda (encoding)
			 (display phone port)
			 (display ": " port)
			 (display encoding port)
			 (newline port)))))

;; Return a list of the digits in PHONE, minus noise characters.
(define parse-phone
  (lambda (phone)
    (map character->digit 
	 (filter char-numeric? (string->list phone)))))

(define noise-letters '(#\- #\"))

;; Compute the possible encodings for DIGITS and call PROC on each.
;; Pre: the empty string is not a dictionary word.
(define for-each-encoding
  (lambda (digits proc)
    (let ((step (trie-step eqv? #f))
	  (at-word-end? trie/null?))

      ;; RP: a reversed prefix of the output (a list of characters
      ;;     in reverse order).
      ;; TRIE: the corresponding subtrie of the dictionary.
      ;; DIGITS: a suffix of the input digits list.
      ;; Call PROC on each way to complete this partial encoding.
      ;; Return true iff there's at least one completion.
      (define complete 
	(lambda (rp trie digits)
	  (if (null? digits)
	      (and (or (eq? trie dictionary) (at-word-end? trie))
		   (begin (proc (list->string (reverse rp)))
			  #t))
	      (let ((any-letters?
		     (try-each-letter (legal-letters-for (car digits))
				      rp trie (cdr digits)))
		    (any-noise-letters?
		     (try-each-letter noise-letters rp trie digits))
		    (any-words?
		     (and (at-word-end? trie)
			  (complete (cons #\space rp) dictionary digits))))
		(or any-letters? any-noise-letters? any-words?
		    (try-a-lone-digit rp trie digits))))))

      ;; Pre: DIGITS is nonnull.
      (define try-a-lone-digit
	(lambda (rp trie digits)
	  (and (eq? trie dictionary)
	       (or (null? rp) 
		   (and (char=? #\space (car rp))  ; redundant test, I think
			(not (char-numeric? (cadr rp)))))
	       (complete (let ((rp (cons (digit->character (car digits))
					 rp)))
			   (if (null? (cdr digits))
			       rp  ; ugh. otherwise we get a trailing space.
			       (cons #\space rp)))
			 trie
			 (cdr digits)))))

      (define try-each-letter
	(lambda (letters rp trie digits)

	  (define try-letter
	    (lambda (letter)
	      (cond ((step trie letter)
		     => (lambda (trie)
			  (complete (cons letter rp) trie digits)))
		    (else #f))))

	  (let trying ((letters letters) (success? #f))
	    (if (null? letters)
		success?
		(trying (cdr letters)
			(or (try-letter (car letters)) 
			    success?))))))

      (complete '() dictionary digits))))

;; Return a list of all letters that can encode DIGIT.
(define legal-letters-for
  (let ((table (list->vector
		(map (lambda (lowercase)
		       (append lowercase (map char-upcase lowercase)))
		     '((#\e)
		       (#\j #\n #\q)
		       (#\r #\w #\x)
		       (#\d #\s #\y)
		       (#\f #\t)
		       (#\a #\m)
		       (#\c #\i #\v)
		       (#\b #\k #\u)
		       (#\l #\o #\p)
		       (#\g #\h #\z))))))
    (lambda (digit)
      (vector-ref table digit))))

(define adjoin! (trie-adjoin! eqv?))

(define install-dictionary!
  (lambda (trie port)
    (for-each-input-line (lambda (word)
			   (adjoin! trie (string->list word)))
			 port)))

;(test-me)