parse test and fucky wucky
This commit is contained in:
parent
30d293a574
commit
ab0b4b7c0e
17
Makefile
Normal file
17
Makefile
Normal file
@ -0,0 +1,17 @@
|
||||
all:
|
||||
csc -s -J util.scm
|
||||
csc -s -J lisp.scm
|
||||
csc -s -J parse.scm
|
||||
csc -s -J io.scm
|
||||
csc -s -J database.scm
|
||||
csc -s -J world.scm
|
||||
csc kekkonen.scm -o kekkonen
|
||||
|
||||
test:
|
||||
csc -s -J util.scm
|
||||
csc test-util.scm
|
||||
csc -s -J database.scm
|
||||
csc test-database.scm
|
||||
csc -s -J parse.scm
|
||||
csc test-parse.scm
|
||||
./test-util && ./test-database && ./test-parse && echo "All tests passed."
|
||||
66
io.scm
Normal file
66
io.scm
Normal file
@ -0,0 +1,66 @@
|
||||
(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 #\<))))))
|
||||
55
parse.scm
Normal file
55
parse.scm
Normal file
@ -0,0 +1,55 @@
|
||||
(module parse (parse-line lift followed-by-consuming is-not)
|
||||
(import scheme)
|
||||
(import chicken.base)
|
||||
(import srfi-13)
|
||||
(import srfi-14)
|
||||
(import util)
|
||||
(import comparse)
|
||||
|
||||
(define +letter-char-set+
|
||||
(string->char-set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVwXYZ"))
|
||||
|
||||
(define +symbol-char-set+
|
||||
(char-set-union +letter-char-set+ (string->char-set "-0123456789")))
|
||||
|
||||
(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 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 (parse-line line)
|
||||
(parse (completely-parse parse-statement) line)))
|
||||
11
test-parse.scm
Normal file
11
test-parse.scm
Normal file
@ -0,0 +1,11 @@
|
||||
(module test-parse ()
|
||||
(import scheme)
|
||||
(import (chicken base))
|
||||
(import (chicken syntax))
|
||||
(import srfi-1)
|
||||
(import test)
|
||||
(import comparse)
|
||||
(import srfi-14)
|
||||
(import parse)
|
||||
|
||||
(test "apple" (parse (lift list->string (one-or-more (in char-set:letter))) "apple")))
|
||||
429
world.scm
Normal file
429
world.scm
Normal file
@ -0,0 +1,429 @@
|
||||
(module world (adventure create-object move-object add-alias set-hidden toggle-fixed set-enter-message set-destination get-container print-room-description)
|
||||
(import scheme)
|
||||
(import chicken.base)
|
||||
(import chicken.file)
|
||||
(import srfi-1)
|
||||
(import matchable)
|
||||
(import fmt)
|
||||
(import ansi-escape-sequences)
|
||||
(import util)
|
||||
(import database)
|
||||
(import io)
|
||||
|
||||
(define +cardinal-sets+
|
||||
'((north n)
|
||||
(northeast ne north-east)
|
||||
(east e)
|
||||
(southeast se south-east)
|
||||
(south s)
|
||||
(southwest sw south-west)
|
||||
(west w)
|
||||
(northwest nw north-west)
|
||||
(up u)
|
||||
(down d)))
|
||||
|
||||
(define +cardinal-opposites+
|
||||
'((north . south)
|
||||
(northeast . southwest)
|
||||
(east . west)
|
||||
(southeast . northwest)
|
||||
(south . north)
|
||||
(southwest . northeast)
|
||||
(west . east)
|
||||
(northwest . southeast)
|
||||
(up . down)
|
||||
(down . up)))
|
||||
|
||||
(define *exit-adventure* #f)
|
||||
|
||||
(define (set-name object name)
|
||||
(database-set object 'name name))
|
||||
|
||||
(define (set-description object description)
|
||||
(database-set object 'description description))
|
||||
|
||||
(define (get-name object)
|
||||
(database-get object 'name (symbol->string object)))
|
||||
|
||||
(define (get-description object)
|
||||
(database-get object 'description "You see the swirling void of creation."))
|
||||
|
||||
(define (get-container object)
|
||||
(database-get object 'container #f))
|
||||
|
||||
(define (get-contents object)
|
||||
(database-get object 'contents '()))
|
||||
|
||||
(define (set-destination object destination)
|
||||
(database-set object 'destination destination))
|
||||
|
||||
(define (get-destination object)
|
||||
(database-get object 'destination #f))
|
||||
|
||||
(define (set-enter-message object msg)
|
||||
(database-set object 'enter-message msg))
|
||||
|
||||
(define (get-enter-message object)
|
||||
(database-get object 'enter-message #f))
|
||||
|
||||
(define (get-aliases object)
|
||||
(database-get object 'aliases '()))
|
||||
|
||||
(define (set-aliases object alias-list)
|
||||
(database-set object 'aliases alias-list))
|
||||
|
||||
(define (add-alias object alias)
|
||||
(let ((aliases (get-aliases object)))
|
||||
(if (not (member alias aliases))
|
||||
(set-aliases object (cons alias aliases)))))
|
||||
|
||||
(define (remove-alias object alias)
|
||||
(let ((aliases (get-aliases object)))
|
||||
(if (member alias aliases)
|
||||
(set-aliases object (remove (curry eq? alias) aliases)))))
|
||||
|
||||
(define (set-hidden object value)
|
||||
(database-set object 'hidden value))
|
||||
|
||||
(define (get-hidden object)
|
||||
(database-get object 'hidden #f))
|
||||
|
||||
(define (set-fixed object value)
|
||||
(database-set object 'fixed value))
|
||||
|
||||
(define (get-fixed object value)
|
||||
(database-get object 'hidden #f))
|
||||
|
||||
(define (get-put-message object)
|
||||
(database-get object 'put-message "You put the ~a into the ~a."))
|
||||
|
||||
;; Is development mode enabled?
|
||||
|
||||
(define (devmode-enabled?)
|
||||
(has-property? 'you 'devmode))
|
||||
|
||||
(define (toggle-devmode)
|
||||
(toggle-flag 'you 'devmode))
|
||||
|
||||
;; Is an object fixed in place (e.g. cannot be picked up?)
|
||||
|
||||
(define (fixed? object)
|
||||
(has-property? object 'fixed))
|
||||
|
||||
(define (toggle-fixed object)
|
||||
(toggle-flag object 'fixed))
|
||||
|
||||
;; Match a tag against a list of objects, checking for its tag and its aliases.
|
||||
|
||||
(define (match-object tag objects)
|
||||
(let loop ((objects objects))
|
||||
(if (null? objects)
|
||||
#f
|
||||
(let ((taglist (cons (car objects) (get-aliases (car objects)))))
|
||||
(if (member tag taglist)
|
||||
(car objects)
|
||||
(loop (cdr objects)))))))
|
||||
|
||||
(define (create-object tag name description)
|
||||
(set-name tag name)
|
||||
(set-description tag description))
|
||||
|
||||
(define (move-object object container)
|
||||
(let ((prev-container (get-container object)))
|
||||
(database-set object 'container container)
|
||||
(let ((contents (get-contents container)))
|
||||
(if (not (member object contents))
|
||||
(begin
|
||||
(database-set container 'contents (cons object contents))
|
||||
(database-set prev-container 'contents (remove (curry eq? object) (get-contents prev-container))))))))
|
||||
|
||||
;; Determine the objects visible to a source object, zork-style
|
||||
(define (visible-objects source)
|
||||
(let ((result (get-container source)))
|
||||
(if (and result (object-exists? result))
|
||||
(cons (get-container source) (get-contents (get-container source)))
|
||||
(error "Tried to determine visible objects for object without a container."))))
|
||||
|
||||
(define (print-room-description room)
|
||||
(newline)
|
||||
(display (set-text '(bold) (get-name room)))
|
||||
(if (devmode-enabled?) (display (set-text '(bold fg-green) (string-append " [" (symbol->string room) "]"))))
|
||||
(newline)
|
||||
(display " ")
|
||||
(fmt #t (dsp (wrap-lines (get-description room))))
|
||||
(newline)
|
||||
(display "You see: ")
|
||||
(map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ") (if (devmode-enabled?) (begin (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] ")))))))) (remove (curry eq? 'you) (get-contents room)))
|
||||
(newline))
|
||||
|
||||
(define (do-command-enter tag)
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You cannot go that way.")
|
||||
(let ((destination (get-destination object)))
|
||||
(if (not destination)
|
||||
(show "You cannot enter that.")
|
||||
(begin
|
||||
(move-object 'you destination)
|
||||
(perhaps show (get-enter-message object))
|
||||
(print-room-description (get-container 'you))))))))
|
||||
|
||||
(define (do-command-save)
|
||||
(let ((save-name (prompt-default "Enter save name: " "kekkonen.sav")))
|
||||
(if (or (not (file-exists? save-name)) (prompt-yn "That file already exists. Overwrite? "))
|
||||
(begin
|
||||
(show "Saving database, please wait...")
|
||||
(database-save save-name)
|
||||
(show "Done.")))))
|
||||
|
||||
(define (do-command-load)
|
||||
(let ((save-name (prompt-default "Enter save file name to load: " "kekkonen.sav")))
|
||||
(if (not (file-exists? save-name))
|
||||
(show "That file does not exist.")
|
||||
(begin
|
||||
(show "Loading database, please wait...")
|
||||
(database-load save-name)
|
||||
(show "Done.")))))
|
||||
|
||||
(define (do-command-look)
|
||||
(print-room-description (get-container 'you)))
|
||||
|
||||
(define (do-command-examine tag)
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You cannot see that here.")
|
||||
(show (get-description object)))))
|
||||
|
||||
(define (do-command-inventory)
|
||||
(map (compose show get-name) (get-contents 'you)))
|
||||
|
||||
(define (do-command-take tag)
|
||||
(if (not (symbol? tag))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (if (devmode-enabled?)
|
||||
(get-all-objects)
|
||||
(visible-objects 'you)))))
|
||||
(if (or (not object) (and (fixed? object) (not (devmode-enabled?))))
|
||||
(if object
|
||||
(show "That is fixed in place.")
|
||||
(show "You cannot see that here."))
|
||||
(begin
|
||||
(show (string-append "You get " (get-name object) "."))
|
||||
(move-object object 'you))))))
|
||||
|
||||
(define (do-command-drop tag)
|
||||
(if (not (symbol? tag))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (get-contents 'you))))
|
||||
(if (not object)
|
||||
(show "You are not carrying that.")
|
||||
(begin
|
||||
(show (string-append "You drop " (get-name object) "."))
|
||||
(move-object object (get-container 'you)))))))
|
||||
|
||||
(define (do-command-put tag destination-tag)
|
||||
(let ((object (match-object tag (get-contents 'you))))
|
||||
(if (not object)
|
||||
(show "You are not carrying that.")
|
||||
(let ((destination-object (match-object destination-tag (visible-objects 'you))))
|
||||
(if (not destination-object)
|
||||
(show "You cannot see that here.")
|
||||
(move-object object (get-destination destination-object)))))))
|
||||
|
||||
(define (do-command-devmode)
|
||||
(toggle-devmode)
|
||||
(if (devmode-enabled?)
|
||||
(show "Development mode enabled.")
|
||||
(show "Development mode disabled.")))
|
||||
|
||||
(define (do-command-create tag name description)
|
||||
(if (not (and (symbol? tag) (string? name) (string? description)))
|
||||
(show "I didn't quite understand that.")
|
||||
(if (object-exists? tag)
|
||||
(show "That object already exists.")
|
||||
(begin
|
||||
(create-object tag name description)
|
||||
(move-object tag (get-container 'you))))))
|
||||
|
||||
(define (do-setter-command tag value type? setter)
|
||||
(if (not (and (symbol? tag) (type? value)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(setter object value)
|
||||
(show "You set a value."))))))
|
||||
|
||||
(define (do-command-rename tag name)
|
||||
(do-setter-command tag name string? set-name))
|
||||
|
||||
(define (do-command-describe tag description)
|
||||
(do-setter-command tag description string? set-description))
|
||||
|
||||
(define (do-command-flag tag flag)
|
||||
(if (not (and (symbol? tag) (symbol? flag)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(case flag
|
||||
((fixed) (set-fixed object #t))
|
||||
((hidden) (set-hidden object #t))
|
||||
(else (show "Invalid flag name."))))))))
|
||||
|
||||
(define (do-command-unflag tag flag)
|
||||
(if (not (and (symbol? tag) (symbol? flag)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(case flag
|
||||
((fixed) (set-fixed object #f))
|
||||
((hidden) (set-hidden object #f))
|
||||
(else (show "Invalid flag name."))))))))
|
||||
|
||||
(define (do-command-alias tag alias)
|
||||
(if (not (and (symbol? tag) (symbol? alias)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(add-alias object alias)
|
||||
(show "You add an alias."))))))
|
||||
|
||||
(define (do-command-unalias tag alias)
|
||||
(if (not (and (symbol? tag) (symbol? alias)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(remove-alias object alias)
|
||||
(show "You remove an alias."))))))
|
||||
|
||||
(define (do-command-destroy tag)
|
||||
(if (not (symbol? tag))
|
||||
(show "I didn't quite understand that.")
|
||||
(database-remove tag)))
|
||||
|
||||
(define (do-command-aliases tag)
|
||||
(if (not (symbol? tag))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(begin
|
||||
(newline)
|
||||
(map (lambda (x) (display x) (display " ")) (get-aliases object))
|
||||
(newline))))))
|
||||
|
||||
(define (do-command-message tag message-tag message)
|
||||
(if (not (and (symbol? tag) (symbol? message-tag) (string? message)))
|
||||
(show "I didn't quite understand that.")
|
||||
(let ((object (match-object tag (visible-objects 'you))))
|
||||
(if (not object)
|
||||
(show "You can't see that here.")
|
||||
(case message-tag
|
||||
((enter) (set-enter-message object message))
|
||||
(else (show "Invalid message name.")))))))
|
||||
|
||||
(define (do-command-goto tag)
|
||||
(if (not (symbol? tag))
|
||||
(show "I didn't quite understand that.")
|
||||
(begin
|
||||
(move-object 'you tag)
|
||||
(print-room-description (get-container 'you)))))
|
||||
|
||||
(define (get-cardinal-set direction)
|
||||
(find (curry member direction) +cardinal-sets+))
|
||||
|
||||
(define (get-cardinal-aliases direction)
|
||||
(perhaps (curry remove (curry eq? direction)) (get-cardinal-set direction)))
|
||||
|
||||
(define (cardinal-direction? direction)
|
||||
(list? (member direction (flatten +cardinal-sets+))))
|
||||
|
||||
(define (get-inverse-direction direction)
|
||||
(perhaps cdr (assoc direction +cardinal-opposites+)))
|
||||
|
||||
(define (get-canonical-cardinal-direction-name direction)
|
||||
(perhaps car (get-cardinal-set direction)))
|
||||
|
||||
(define (do-command-dig direction destination)
|
||||
(if (not (and (symbol? direction) (symbol? destination)))
|
||||
(show "I didn't quite understand that.")
|
||||
(if (not (cardinal-direction? direction))
|
||||
(show "You must specify a compass rose direction or up and down.")
|
||||
(let ((canonical-direction (get-canonical-cardinal-direction-name direction)))
|
||||
(let ((exit-tag (compose-symbols canonical-direction (get-container 'you) destination)))
|
||||
(if (object-exists? exit-tag)
|
||||
(show "An exit like that already exists.")
|
||||
(begin
|
||||
(move-object exit-tag (get-container 'you))
|
||||
(set-hidden exit-tag #t)
|
||||
(set-destination exit-tag destination)
|
||||
(map (curry add-alias exit-tag) (get-cardinal-set direction))
|
||||
(show "You create a passage."))))))))
|
||||
|
||||
(define (do-command-exit)
|
||||
(show "Goodbye, see you later...")
|
||||
(set! *exit-adventure* #t))
|
||||
|
||||
(define (alias-transform input)
|
||||
(match input
|
||||
(('quit) '(exit))
|
||||
(('i) '(inventory))
|
||||
(('inv) '(inventory))
|
||||
(('look x) `(examine ,x))
|
||||
(('go x) `(enter ,x))
|
||||
(('get x) `(take ,x))
|
||||
((x) (if (cardinal-direction? x)
|
||||
`(enter ,x)
|
||||
input))
|
||||
(_ input)))
|
||||
|
||||
(define (dispatch-command input)
|
||||
(let ((success #t))
|
||||
(match input
|
||||
(('look) (do-command-look))
|
||||
(('save) (do-command-save))
|
||||
(('load) (do-command-load))
|
||||
(('devmode) (do-command-devmode))
|
||||
(('exit) (do-command-exit))
|
||||
(('enter x) (do-command-enter x))
|
||||
(('take x) (do-command-take x))
|
||||
(('drop x) (do-command-drop x))
|
||||
(('inventory) (do-command-inventory))
|
||||
(('examine x) (do-command-examine x))
|
||||
(('put x y) (do-command-put x y))
|
||||
(_ (if (devmode-enabled?)
|
||||
(match input
|
||||
(('create x y z) (do-command-create x y z))
|
||||
(('rename x y) (do-command-rename x y))
|
||||
(('describe x y) (do-command-describe x y))
|
||||
(('dig x y) (do-command-dig x y))
|
||||
(('flag x y) (do-command-flag x y))
|
||||
(('unflag x y) (do-command-unflag x y))
|
||||
(('alias x y) (do-command-alias x y))
|
||||
(('unalias x y) (do-command-unalias x y))
|
||||
(('destroy x) (do-command-destroy x))
|
||||
(('aliases x) (do-command-aliases x))
|
||||
(('message x y z) (do-command-message x y z))
|
||||
(('goto x) (do-command-goto x))
|
||||
(_ (set! success #f)))
|
||||
(set! success #f))))
|
||||
success))
|
||||
|
||||
(define (adventure)
|
||||
(let ((success (dispatch-command (alias-transform (adventure-prompt)))))
|
||||
(if (not success)
|
||||
(begin
|
||||
(show "I didn't quite understand that.")
|
||||
(adventure))
|
||||
(if *exit-adventure*
|
||||
(show "Exiting..."); (display *database*)
|
||||
(adventure))))))
|
||||
Loading…
Reference in New Issue
Block a user