|
|
@@ -1,4 +1,3 @@ |
|
|
|
(import comparse) |
|
|
|
(import srfi-1) |
|
|
|
(import srfi-14) |
|
|
|
(import (chicken io)) |
|
|
@@ -13,73 +12,7 @@ |
|
|
|
(import ncurses) |
|
|
|
(import util) |
|
|
|
(import lisp) |
|
|
|
|
|
|
|
(define (lift fn parser) |
|
|
|
(bind parser (compose result fn))) |
|
|
|
|
|
|
|
(define (is-not x) |
|
|
|
(satisfies (lambda (y) |
|
|
|
(not (eqv? x y))))) |
|
|
|
|
|
|
|
(define parse-whitespace |
|
|
|
(one-or-more (is #\space))) |
|
|
|
|
|
|
|
(define skip-whitespace |
|
|
|
(skip (zero-or-more (is #\space)))) |
|
|
|
|
|
|
|
(define +letter-char-set+ |
|
|
|
(string->char-set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVwXYZ")) |
|
|
|
|
|
|
|
(define +symbol-char-set+ |
|
|
|
(char-set-union +letter-char-set+ (string->char-set "-0123456789"))) |
|
|
|
|
|
|
|
(define parse-symbol |
|
|
|
(lift (compose string->symbol string-downcase list->string (applied append)) |
|
|
|
(sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+))))) |
|
|
|
|
|
|
|
(define parse-number |
|
|
|
(lift (compose string->number list->string) (one-or-more (in char-set:digit)))) |
|
|
|
|
|
|
|
(define parse-string |
|
|
|
(lift list->string (enclosed-by (is #\") (one-or-more (is-not #\")) (is #\")))) |
|
|
|
|
|
|
|
(define (followed-by-consuming parser separator) |
|
|
|
(sequence* ((value parser) (_ separator)) |
|
|
|
(result value))) |
|
|
|
|
|
|
|
(define (separated-by separator parser) |
|
|
|
(one-or-more (any-of (followed-by-consuming parser separator) parser))) |
|
|
|
|
|
|
|
(define parse-symbol-or-number-or-string |
|
|
|
(any-of parse-number parse-symbol parse-string)) |
|
|
|
|
|
|
|
(define (completely-parse parser) |
|
|
|
(followed-by parser end-of-input)) |
|
|
|
|
|
|
|
(define parse-statement |
|
|
|
(all-of skip-whitespace (separated-by parse-whitespace parse-symbol-or-number-or-string))) |
|
|
|
|
|
|
|
(define (just fn) |
|
|
|
(lambda args |
|
|
|
(fn))) |
|
|
|
|
|
|
|
(define (perhaps fn arg) |
|
|
|
(if arg |
|
|
|
(fn arg) |
|
|
|
arg)) |
|
|
|
|
|
|
|
(define display-newline |
|
|
|
(compose (just newline) display)) |
|
|
|
|
|
|
|
(define (display-lines ln) |
|
|
|
(perhaps (curry map display-newline) ln)) |
|
|
|
|
|
|
|
(define (parse-input) |
|
|
|
(parse (completely-parse parse-statement) (read-line))) |
|
|
|
|
|
|
|
(define parse-formatter |
|
|
|
(recursive-parser (one-or-more (any-of (followed-by-consuming (char-seq "<b>") (lift fmt-bold parser)) |
|
|
|
(is-not #\<))))) |
|
|
|
(import parse) |
|
|
|
|
|
|
|
(define (type-of elem) |
|
|
|
(cond ((pair? elem) 'pair) |
|
|
@@ -123,7 +56,7 @@ |
|
|
|
'(a an the into on to at as)) |
|
|
|
|
|
|
|
(define (adventure-prompt) |
|
|
|
(let ((result (parse (completely-parse parse-statement) (prompt "> ")))) |
|
|
|
(let ((result (parse-line (prompt "> ")))) |
|
|
|
(if result |
|
|
|
(let ((grug-result (filter (compose not (cut member <> +articles-prepositions+)) result))) |
|
|
|
(if (not (null? grug-result)) |
|
|
|