; squaring the bishop
; based on ftp://ftp.fourmilab.ch/pub/babbage/Osqbish.html

(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)))))))

; insert string (list of chars) cs into trie t
(define (insert cs t)
  (cond ((null? cs) t)
        ((assoc (car cs) t) => (lambda (x)
          (cons (cons (car cs) (insert (cdr cs) (cdr x))) (remove x t))))
        (else (cons (cons (car cs) (insert (cdr cs) '())) t))))

; one trie for each length of word
(define tries (make-vector 50 '()))

; word contains only alphabetic characters
(define (valid? word)
  (let loop ((cs (string->list word)))
    (if (null? cs) #t
      (and (char-alphabetic? (car cs)) (loop (cdr cs))))))

; insert word-list into tries
(define (make-tries word-list)
  (with-input-from-file word-list
    (lambda ()
      (do ((word (read-line) (read-line)))
          ((eof-object? word))
        (when (valid? word)
          (let ((len (string-length word)))
            (vector-set! tries len
              (insert (string->list word)
                (vector-ref tries len)))))))))

; pick a word list and execute the command
; moby project at http://icon.shef.ac.uk/Moby/mwords.html
; (make-tries "/usr/share/dict/words")
; (make-tries "moby.common")   ;  74550 words
; (make-tries "moby.scrabble") ; 113809 words
; (make-tries "moby.words")    ; 354984 words

; mappend is like map but builds up its output with append instead of cons
(define (mappend f . xss) (apply append (apply map f xss)))

; auxiliary function for prefs
(define (expand ps t)
  (if (null? t) (list (reverse ps))
    (mappend (lambda (x) (expand (cons (car x) ps) (cdr x))) t)))

; all words of length n that begin with the letters cs
(define (prefs n cs)
  (let loop ((cs cs) (ps '()) (t (vector-ref tries n)))
    (cond ((null? cs) (expand ps t))
          ((assoc (car cs) t) => (lambda (x)
            (loop (cdr cs) (cons (car cs) ps) (cdr x))))
          (else '()))))

; the nth item of each list in a list of lists
(define (nths n xss)
  (map (lambda (xs) (list-ref xs n)) xss))

; compute a word square for the requested word
(define (square word)
  (let* ((len (string-length word))
         (ss  (let* ((ss (list (string->list word)))
                     (ps (prefs len (nths 1 ss))))
                (map (lambda (p) (append ss (list p))) ps))))
    (let loop ((n 2) (ss ss))
      (if (= len n)
          (map (lambda (s) (map list->string s)) ss)
          (loop (+ n 1)
                (mappend (lambda (s)
                           (let ((ps (prefs len (nths n s))))
                             (map (lambda (p) (append s (list p)))
                                  ps)))
                         ss))))))

(display (square "praxis")) (newline)
(time (display (length (square "bishop")))) (newline)