(module landon

  mzscheme

  (require (lib "mred.ss" "mred"))

  (require (lib "class.ss"))

  

  (define dict '())

  (define num-lines -1)

  (define filename #f)

  

  (define (lookup-word w l)

    (if (pair? l)

        (if (string-ci=? w (caar l))

            (car l)

            (lookup-word w (cdr l)))

        '()))

  

  (define (add-word w f l)

    (define (add-follow d ac)

      (if (pair? d)

          (if (string? (car d))

              (add-follow (cdr d) (list (car d)))

              (if (string-ci=? f (caar d))

                  (append ac (list (list f (+ (cadar d) 1))) (cdr d))

                  (add-follow (cdr d) (append ac (list (car d))))))

          (append ac (list (list f 1)))))

    (define (aw-helper l accum)

      (if (pair? l)

          (if (string-ci=? w (caar l))

              (append accum (list (add-follow (car l) '())) (cdr l))

              (aw-helper (cdr l) (append accum (list (car l)))))

          '()))

    (if (eq? l '())

        (list (list w (list f 1)))

        (if (eq? (lookup-word w l) '())

            (append l (list (list w (list f 1))))

            (aw-helper l '()))))

  

  (define (cleanup word)

    (define cl (string->list word))

    (define (cu-helper l)

      (if (pair? l)

          (if (char-alphabetic? (car l))

              (cons (car l) (cleanup (cdr l))))

          '()))

    (list->string (cu-helper cl)))

  

  (define (char-word? ch)

    (or (char-alphabetic? ch)

        (char=? #\' ch)))

  

  (define (first-word l)

    (if (pair? l)

        (if (char-word? (car l))

            (cons (car l) (first-word (cdr l)))

            '())

        '()))

  

  (define (strip-junk l)

    (if (pair? l)

        (if (and (not (char-word? (car l)))

                 (not (char=? (car l) #\.)))

            (strip-junk (cdr l))

            l)

        '()))

  

  (define (strip-first l)

    (if (pair? l)

        (if (char-word? (car l))

            (strip-first (cdr l))

            (list->string (strip-junk l)))

        ""))

  

  (define (wordify s)

    (define cl (string->list s))

    (if (pair? cl)

        (if (char=? (car cl) #\.)

            (cons "." (wordify (list->string (strip-junk (cdr cl)))))

            (cons (list->string (first-word cl)) (wordify (strip-first cl))))

        '()))

  

  (define (add-sentence s l)

    (define wl (cons "." (wordify s)))

    (define (as-helper sl l)

      (if (pair? sl)

          (if (pair? (cdr sl))

              (as-helper (cdr sl) (add-word (car sl) (cadr sl) l))

              (if (not (string=? (car sl) "."))

                  (add-word (car sl) "." l)

                  l))

          l))

    (if (pair? (cdr wl))

        (as-helper wl l)

        l))

  

  (define (assemble-sentence l)

    (if (pair? l)

        (if (pair? (cdr l))

            (string-append (car l) " " (assemble-sentence (cdr l)))

            (car l))

        ""))

  

  (define (assoc-sum l)

    (apply + (map cadr l)))

  

  (define (assoc-ref l n)

    (if (and (pair? l) (>= n 0))

        (if (> (cadar l) n)

            (car l)

            (assoc-ref (cdr l) (- n (cadar l))))

        '()))

  

  (define (unstack l)

    (define (us-helper l n)

      (define r (assoc-ref l n))

      (if (pair? r)

          (cons (car r) (us-helper l (+ n 1)))

          '()))

    (us-helper l 0))

  

  ; ASSERTION: (assoc-ref l n) == (list-ref (unstack l) n)

  

  (define (generate-sentence l)

    (define (gs-helper i)

      (define wl (cdr (lookup-word i l)))

      (define rn (random (assoc-sum wl)))

      (define nw (assoc-ref wl rn))

      (if (equal? "." (car nw))

          '()

          (cons (car nw) (gs-helper (car nw)))))

    (if (not (pair? l))

        "** No dictionary present **"

        (string-append (assemble-sentence (gs-helper ".")) ".")))

  

  (define (main dict)

    (define rl (read-line))

    (define new-dict 

      (if (not (eof-object? rl))

          (add-sentence rl dict)

          #f))

    (if (not (eq? new-dict #f))

        (begin

          (display "<Landon> ")

          (display (generate-sentence new-dict))

          (newline)

          (display "<User> ")

          (main new-dict))))

  

  ;(display "<User> ")

  ;(main '())

  

  (define (evt-new obj id)

    (set! dict '()))

  

  (define (evt-open obj id)

    (define newfn (get-file "Open Dictionary" main-frame #f #f "lan" '()

                            '(("Landon Dictionary Files (*.lan)" "*.lan") 

                              ("All Files" "*.*"))))

    (if (not (eq? newfn #f))

        (if (file-exists? newfn)

            (let ((new-dict (call-with-input-file newfn read)))

              (if (list? new-dict)

                  (begin

                    (set! dict new-dict)

                    (set! filename newfn))

                  (message-box "Landon Error"

                               "The selected file is not a valid dictionary."

                               #f '(ok stop)))))))

  

  (define (evt-save obj id)

    (if (not filename)

        (evt-saveas obj id)

        (begin

          (if (file-exists? filename)

              (delete-file filename))

          (call-with-output-file filename (lambda (port) (write dict port))))))

  

  (define (evt-saveas obj id)

    (define newfn (put-file "Save Dictionary" main-frame #f #f "lan" '()

                            '(("Landon Dictionary Files (*.lan)" "*.lan") 

                              ("All Files" "*.*"))))

    (if (not (eq? newfn #f))

        (begin

          (set! filename newfn)

          (evt-save obj id))))

  

  (define (evt-exit obj id)

    (exit))

  

  (define (evt-copy obj id)

    (send the-clipboard set-clipboard-string

          (apply string-append

                 (map (lambda (s) (string-append s "\r\n"))

                      (map (lambda (i) (send lst-log get-string i))

                           (send lst-log get-selections)))) 0))

  

  (define (get-all-strings n)

    (if (<= n num-lines)

        (cons (send lst-log get-string n) (get-all-strings (+ n 1)))

        '()))

  

  (define (evt-savelog obj id)

    (define newfn (put-file "Save Log" main-frame #f #f "txt" '()

                            '(("Text Files (*.txt)" "*.txt") 

                              ("All Files" "*.*"))))

    (if (not (eq? newfn #f))

        (begin

          (if (file-exists? newfn)

              (delete-file newfn))

          (call-with-output-file newfn

            (lambda (port)

              (display (apply string-append

                              (map (lambda (s) (string-append s "\r\n"))

                                   (get-all-strings 0))) port))))))

  

  

  (define (evt-clear obj id)

    (set! num-lines -1)

    (send lst-log set '()))

  

  (define (evt-send obj id)

    (set! dict (add-sentence (send txt-input get-value) dict))

    (send lst-log append (string-append "<User> " (send txt-input get-value)))

    (send lst-log append (string-append "<Landon> " (generate-sentence dict)))

    (set! num-lines (+ num-lines 2))

    (send lst-log set-first-visible-item num-lines)

    (send txt-input set-value ""))

  

  (define main-frame (make-object frame% "Landon" #f 320 200))

  (define menu-bar (make-object menu-bar% main-frame))

  (define mnu-file (make-object menu% "&File" menu-bar))

  (define cmd-new (make-object menu-item% "&New Dictionary" mnu-file evt-new))

  (define cmd-open (make-object menu-item% "&Open Dictionary..." mnu-file 

                     evt-open))

  (define cmd-save (make-object menu-item% "&Save Dictionary" mnu-file evt-save))

  (define cmd-saveas (make-object menu-item% "Save Dictionary &As..." mnu-file

                       evt-saveas))

  (define bar-file (make-object separator-menu-item% mnu-file))

  (define cmd-exit (make-object menu-item% "E&xit" mnu-file evt-exit))

  (define mnu-edit (make-object menu% "&Log" menu-bar))

  (define cmd-copy (make-object menu-item% "&Copy Selection" mnu-edit evt-copy))

  (define bar-edit (make-object separator-menu-item% mnu-edit))

  (define cmd-savelog (make-object menu-item% "&Save Log..." mnu-edit 

                        evt-savelog))

  (define cmd-clear (make-object menu-item% "Clear Log" mnu-edit evt-clear))

  (define lst-log (make-object list-box% #f '() main-frame void '(multiple)))

  (define pnl-horiz (make-object horizontal-panel% main-frame null #t 0 0 0 0

                      '(left center) 0 0 #t #f))

  (define txt-input (make-object text-field% #f pnl-horiz void))

  (define cmd-send (make-object button% "&Send" pnl-horiz evt-send '(border)))

  

  (send main-frame show #t)

  

  )