From ab0b4b7c0e5b136c926befa1642965a354c7d1e1 Mon Sep 17 00:00:00 2001 From: Victor Fors Date: Tue, 30 Nov 2021 16:22:15 +0100 Subject: [PATCH] parse test and fucky wucky --- Makefile | 17 +++ io.scm | 66 +++++++++ parse.scm | 55 ++++++++ test-parse.scm | 11 ++ world.scm | 429 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 578 insertions(+) create mode 100644 Makefile create mode 100644 io.scm create mode 100644 parse.scm create mode 100644 test-parse.scm create mode 100644 world.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..2b47443 --- /dev/null +++ b/Makefile @@ -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." diff --git a/io.scm b/io.scm new file mode 100644 index 0000000..701ce1f --- /dev/null +++ b/io.scm @@ -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 "") (lift fmt-bold parser)) +; (is-not #\<)))))) diff --git a/parse.scm b/parse.scm new file mode 100644 index 0000000..ef0aaa8 --- /dev/null +++ b/parse.scm @@ -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))) diff --git a/test-parse.scm b/test-parse.scm new file mode 100644 index 0000000..d231c68 --- /dev/null +++ b/test-parse.scm @@ -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"))) diff --git a/world.scm b/world.scm new file mode 100644 index 0000000..654e8fc --- /dev/null +++ b/world.scm @@ -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))))))