From a528be6545cedc8b360aab70492bc3d128e45b49 Mon Sep 17 00:00:00 2001 From: Victor Fors Date: Tue, 29 Sep 2020 14:59:45 +0200 Subject: [PATCH] a --- kekkonen.scm | 430 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 430 insertions(+) create mode 100644 kekkonen.scm diff --git a/kekkonen.scm b/kekkonen.scm new file mode 100644 index 0000000..9b31897 --- /dev/null +++ b/kekkonen.scm @@ -0,0 +1,430 @@ +(import comparse) +(import srfi-1) +(import srfi-14) +(import (chicken io)) +(import srfi-13) +(import matchable) +(import fmt) +(import ansi-escape-sequences) +(import (chicken file)) + +; (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) (one-or-more (in char-set:letter)))) + +(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 (cut map display-newline <>) ln)) + +(define (parse-input) + (parse (completely-parse parse-statement) (read-line))) + +(define (type-of elem) + (cond ((pair? elem) 'pair) + ((symbol? elem) 'symbol) + ((number? elem) 'number) + ((char? elem) 'char) + ((string? elem) 'string) + ((boolean? elem) 'boolean))) + +(define (show str) + (fmt #t (dsp (wrap-lines str)))) + +(define (prompt str) + (newline) + (display str) + (let ((result (read-line))) + (if (equal? "" result) + (prompt str) + result))) + +(define (prompt-yn str) + (newline) + (display str) + (let ((result (string-downcase (read-line)))) + (cond ((equal? "yes" result) #t) + ((equal? "no" result) #t) + (else (begin + (newline) + (display "Please answer yes or no.") + (prompt-yn str)))))) + +(define +articles-prepositions+ + '(a an the into on to at)) + +(define (adventure-prompt) + (let ((result (parse (completely-parse parse-statement) (prompt "> ")))) + (if result + (let ((grug-result (filter (lambda (n) (not (member n +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 *database* '()) + +(define (database-set name key value) + (set! *database* (let loop ((kv *database*)) + (if (null? kv) + (list (cons name (list (cons key value)))) + (if (equal? name (caar kv)) + (cons (cons name (let loop ((kv (cdar kv))) + (if (null? kv) + (list (cons key value)) + (if (equal? key (caar kv)) + (cons (cons key value) (cdr kv)) + (cons (car kv) (loop (cdr kv))))))) (cdr kv)) + (cons (car kv) (loop (cdr kv)))))))) + +(define (database-get name key default) + (let loop ((kv *database*)) + (if (null? kv) + default + (if (equal? name (caar kv)) + (let loop ((kv (cdar kv))) + (if (null? kv) + default + (if (equal? key (caar kv)) + (cdar kv) + (loop (cdr kv))))) + (loop (cdr kv)))))) + +(define (database-save filename) + (with-output-to-file filename (cut write *database*))) + +(define (database-load filename) + (with-input-from-file filename (lambda () (set! *database* (car (read-list)))))) + +(define (get-all-objects) + (map car *database*)) + +(define (object-exists? object) + (member object (get-all-objects))) + +(define (has-property? object property) + (database-get object property #f)) + +(define (toggle-flag object flag) + (if (has-property? object flag) + (database-set object flag #f) + (database-set object flag #t))) + +(define (get-location object) + (database-get object 'location #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 (cut eq? alias <>) aliases))))) + +;; 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 (cut 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 (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 (print-room-description room) + (newline) + (display (set-text '(bold) (get-name room))) + (newline) + (display " ") + (fmt #t (dsp (wrap-lines (get-description room)))) + (newline) + (display "You see: ") + (map (lambda (n) (display n) (display " ")) (map get-name (remove (cut eq? 'you <>) (get-contents room)))) + (newline)) + +(define (do-command-save) + (let ((save-name (prompt "Enter save name: "))) + (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 "Enter save file name to load: "))) + (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 (if (devmode-enabled?) + (get-all-objects) + (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-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-command-rename tag name) + (if (not (and (symbol? tag) (string? name))) + (show "I didn't quite understand that.") + (if (not (object-exists? tag)) + (show "That object doesn't exist.") + (begin + (set-name tag name))))) + +(define (do-command-describe tag description) + (if (not (and (symbol? tag) (string? description))) + (show "I didn't quite understand that.") + (if (not (object-exists? tag)) + (show "That object doesn't exist.") + (begin + (set-description tag description))))) + +;;(define (do-command-dig direction destination) +;; ( + +(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)) + (_ 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)) + (_ (set! success #f))) + (set! success #f)))) + success)) + +(create-object 'garden "A Well-Kept Garden" "A french-style garden with topiary in the shape of various animals. A fountain gurgles happily in the middle.") +(create-object 'unicorn "a frolicking unicorn" "A white unicorn, with a long spiral horn.") +(create-object 'forest "A Foreboding Forest" "Tall trees bunch around a winding path.") +(create-object 'trail "a trail" "A winding trail.") +(add-alias 'trail 'winding) +(set-enter-message 'trail "You walk along the winding trail...") +(move-object 'you 'garden) +(move-object 'trail 'garden) +(toggle-fixed 'trail) +(set-destination 'trail 'forest) +(move-object 'unicorn 'garden) + +(define *exit-adventure* #f) + +(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* + (display *database*) + (adventure))))) + +(print-room-description (get-container 'you)) +(adventure)