a

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)