rendered paste body(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)
)