parse test and fucky wucky

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."

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 "<b>") (lift fmt-bold parser))
+; 					   (is-not #\<))))))

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)))

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")))

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))))))