; this is assuming that the input is case-insensitive and will terminate on
; any non-alphabetic character

(define (trie-new)
  (make-vector 27 0))

(define (trie-insert tr s)
  (let ((tr   (trie-new))
        (l    (string-length s)))
    (let loop ((i  0)
               (t  tr))
      (if (= i l)
          (begin
            (vector-set! t 26 (+ 1 (vector-ref t 26)))
            tr)
          (let ((c  (char->integer (char-downcase (string-ref s i)))))
            (cond ((or (< c 0) (> c 25))
                    (vector-set! t 26 (+ 1 (vector-ref t 26)))
                    (loop (+ 1 i) tr))
                  ((vector? (vector-ref t c))
                    (loop (+ 1 i) (vector-ref t c)))
                  (else
                    (let ((tn   (trie-new)))
                      (vector-set! tn 26 (vector-ref t c))
                      (vector-set! t c tn)
                      (loop (+ 1 i) tn)))))))))

; this is assuming that the input is case-insensitive
; despite a unique word count implying words and not 'words with following or 
; leading punctuation', this will terminate only on space or newline

(define (trie-new)
  (make-vector 256 0))

(define (trie-insert tr s)
  (let ((tr   (trie-new))
        (l    (string-length s)))
    (let loop ((i  0)
               (t  tr))
      (if (= i l)
          (begin
            (vector-set! t 0 (+ 1 (vector-ref t 0)))
            tr)
          (let ((c  (char->integer (char-downcase (string-ref s i)))))
            (cond ((or (= 32 c) (= 10 c))    ; 32 = #\space   10 = #\newline
                    (vector-set! t 0 (+ 1 (vector-ref t 0)))
                    (loop (+ 1 i) tr))
                  ((vector? (vector-ref t c))
                    (loop (+ 1 i) (vector-ref t c)))
                  (else
                    (let ((tn   (trie-new)))
                      (vector-set! tn 0 (vector-ref t c))
                      (vector-set! t c tn)
                      (loop (+ 1 i) tn)))))))))

; this is assuming that the input is case-insensitive
; despite a unique word count implying words and not 'words with following or 
; leading punctuation', this will terminate only on space or newline

(define (trie-new)
  (make-vector 256 0))

(define (trie-insert tr s)
  (let ((l   (string-length s)))
    (let loop ((i  (or (and (= 0 l) 0) (- l 1)))
               (t  tr))
      (if (= i 0)
          (begin
            (vector-set! t 0 (+ 1 (vector-ref t 0)))
            tr)
          (let ((c  (char->integer (char-downcase (string-ref s i)))))
            (cond ((or (= 32 c) (= 10 c))    ; 32 = #\space   10 = #\newline
                    (vector-set! t 0 (+ 1 (vector-ref t 0)))
                    (loop (- i 1) tr))
                  ((vector? (vector-ref t c))
                    (loop (- i 1) (vector-ref t c)))
                  (else
                    (let ((tn   (trie-new)))
                      (vector-set! tn 0 (vector-ref t c))
                      (vector-set! t c tn)
                      (loop (- i 1) tn)))))))))

(define (words-read f)
  (with-input-from-file f
    (lambda ()
      (let loop ((l    (read-line))
                 (tr   (trie-new)))
        (if (eof-object? l)
            tr
            (loop (trie-insert tr l) (read-line)))))))

(define idx-list
  (let loop ((i   1)
             (r   '()))
    (if (= i 256)
        r
        (loop (+ 1 i) (cons i r)))))

(define char-list
  (map integer->char idx-list))

(define (trie->wordlist tr)
  (vector-set! tr 0 0)    ; remove repeated spaces
  (let ((r   '()))
    (let loop ((b   '())
               (t   tr))
      (for-each
        (lambda (i c)
          (let ((e   (vector-ref t i)))
            (if (vector? e)
                (loop (cons c b) e)
                (or (= 0 e)
                    (set! r (cons (cons (list->string (cons c b)) e) r))))))
          idx-list char-list)
      (or (= 0 (vector-ref t 0))
          (set! r (cons (cons (list->string b) (vector-ref t 0)) r))))
    r))

(import (chicken io)
        (chicken sort))

(define (trie-new)
  (make-vector 256 0))

(define (trie-insert tr s)
  (let ((l   (string-length s)))
    (let loop ((i  (- l 1))
               (t  tr))
      (if (< i 0)
          (begin
            (vector-set! t 0 (+ 1 (vector-ref t 0)))
            tr)
          (let ((c  (char->integer (char-downcase (string-ref s i)))))
            (cond ((or (= 32 c) (= 10 c))    ; 32 = #\space   10 = #\newline
                    (vector-set! t 0 (+ 1 (vector-ref t 0)))
                    (loop (- i 1) tr))
                  ((vector? (vector-ref t c))
                    (loop (- i 1) (vector-ref t c)))
                  (else
                    (let ((tn   (trie-new)))
                      (vector-set! tn 0 (vector-ref t c))
                      (vector-set! t c tn)
                      (loop (- i 1) tn)))))))))

(define (words-read f)
  (with-input-from-file f
    (lambda ()
      (let loop ((l    (read-line))
                 (tr   (trie-new)))
        (if (eof-object? l)
            tr
            (loop (read-line) (trie-insert tr l)))))))

(define idx-list
  (let loop ((i   1)
             (r   '()))
    (if (= i 256)
        r
        (loop (+ 1 i) (cons i r)))))

(define char-list
  (map integer->char idx-list))

(define (sort-count a b)
  (if (= (cdr a) (cdr b))
      (string<? (car a) (car b))
      (> (cdr a) (cdr b))))

(define (trie->wordlist tr)
  (vector-set! tr 0 0)    ; remove repeated spaces
  (let ((r   '()))
    (let loop ((b   '())
               (t   tr))
      (for-each
        (lambda (i c)
          (let ((e   (vector-ref t i)))
            (if (vector? e)
                (loop (cons c b) e)
               (or (= 0 e)
                    (set! r (cons (cons (list->string (cons c b)) e) r))))))
          idx-list char-list)
      (or (= 0 (vector-ref t 0))
          (set! r (cons (cons (list->string b) (vector-ref t 0)) r))))
    (sort r sort-count)))

(trie->wordlist (read-words "kjvbible.txt"))