67 lines
1.7 KiB
Scheme
67 lines
1.7 KiB
Scheme
|
(module io (display-newline display-lines show adventure-prompt prompt prompt-default prompt-yn)
|
||
|
|
(import scheme)
|
||
|
|
(import chicken.base)
|
||
|
|
(import srfi-1)
|
||
|
|
(import srfi-13)
|
||
|
|
(import fmt)
|
||
|
|
(import fmt-color)
|
||
|
|
(import breadline)
|
||
|
|
(import ncurses)
|
||
|
|
(import util)
|
||
|
|
(import comparse)
|
||
|
|
(import parse)
|
||
|
|
|
||
|
|
(define display-newline
|
||
|
|
(compose (just newline) display))
|
||
|
|
|
||
|
|
(define (display-lines ln)
|
||
|
|
(perhaps (curry map display-newline) ln))
|
||
|
|
|
||
|
|
(define (show str)
|
||
|
|
(fmt #t (dsp (wrap-lines str))))
|
||
|
|
|
||
|
|
(define (prompt str)
|
||
|
|
(newline)
|
||
|
|
(let ((result (readline str)))
|
||
|
|
(if (equal? "" result)
|
||
|
|
(prompt str)
|
||
|
|
(begin
|
||
|
|
(add-history! result)
|
||
|
|
result))))
|
||
|
|
|
||
|
|
(define (prompt-yn str)
|
||
|
|
(newline)
|
||
|
|
(let ((result (string-downcase (readline str))))
|
||
|
|
(cond ((equal? "yes" result) #t)
|
||
|
|
((equal? "no" result) #f)
|
||
|
|
(else (begin
|
||
|
|
(newline)
|
||
|
|
(display "Please answer yes or no.")
|
||
|
|
(prompt-yn str))))))
|
||
|
|
|
||
|
|
(define (prompt-default str default)
|
||
|
|
(map stuff-char (string->list default))
|
||
|
|
(let loop ()
|
||
|
|
(let ((result (readline str)))
|
||
|
|
(if (equal? "" result)
|
||
|
|
(loop)
|
||
|
|
result))))
|
||
|
|
|
||
|
|
(define +articles-prepositions+
|
||
|
|
'(a an the into on to at as))
|
||
|
|
|
||
|
|
(define (adventure-prompt)
|
||
|
|
(let ((result (parse-line (prompt "> "))))
|
||
|
|
(if result
|
||
|
|
(let ((grug-result (filter (compose not (cut member <> +articles-prepositions+)) result)))
|
||
|
|
(if (not (null? grug-result))
|
||
|
|
grug-result
|
||
|
|
(begin (display "I didn't quite understand that.")
|
||
|
|
(adventure-prompt))))
|
||
|
|
(begin (display "I didn't quite understand that.")
|
||
|
|
(adventure-prompt))))))
|
||
|
|
|
||
|
|
; (define parse-formatter
|
||
|
|
; (recursive-parser (one-or-more (any-of (followed-by-consuming (char-seq "<b>") (lift fmt-bold parser))
|
||
|
|
; (is-not #\<))))))
|