diff --git a/Makefile b/Makefile index 2b47443..0fca6cc 100644 --- a/Makefile +++ b/Makefile @@ -14,4 +14,4 @@ test: csc test-database.scm csc -s -J parse.scm csc test-parse.scm - ./test-util && ./test-database && ./test-parse && echo "All tests passed." + ./test-util && ./test-database && ./test-parse diff --git a/test-database.scm b/test-database.scm index 5d6445a..9d32e65 100644 --- a/test-database.scm +++ b/test-database.scm @@ -6,43 +6,43 @@ (import database) (test-group "database" - (test '((test . ((test-key . 3)))) (begin (set! *database* '()) + (test '((test . ((test-key . 3)))) (begin (database-null) (database-set 'test 'test-key 3) *database*)) - (test 3 (begin (set! *database* '()) + (test 3 (begin (database-null) (database-set 'test 'test-key 3) (database-get 'test 'test-key #f))) - (test '((test . ((test-key . 3)))) (begin (set! *database* '()) + (test '((test . ((test-key . 3)))) (begin (database-null) (database-set 'test 'test-key 3) (database-save "test.sav") - (set! *database* '()) + (database-null) (database-load "test.sav"))) - (test '() (begin (set! *database* '()) + (test '() (begin (database-null) (database-set 'test 'test-key 3) (database-remove 'test) *database*)) - (test '(test) (begin (set! *database* '()) + (test '(test) (begin (database-null) (database-set 'test 'test-key 3) (get-all-objects))) (test-group "object-exists?" - (test #t (begin (set! *database* '()) + (test #t (begin (database-null) (database-set 'test 'test-key 3) (object-exists? 'test))) - (test #f (begin (set! *database* '()) + (test #f (begin (database-null) (object-exists? 'test)))) (test-group "has-property?" - (test #t (begin (set! *database* '()) + (test #t (begin (database-null) (database-set 'test 'test-key 3) (has-property? 'test 'test-key))) - (test #f (begin (set! *database* '()) + (test #f (begin (database-null) (database-set 'test 'test-key 3) (has-property? 'test 'nosuch-key)))) (test-group "toggle-flag" - (test #t (begin (set! *database* '()) + (test #t (begin (database-null) (database-set 'test 'test-key #f) (toggle-flag 'test 'test-key) (database-get 'test 'test-key #f))) - (test #f (begin (set! *database* '()) + (test #f (begin (database-null) (database-set 'test 'test-key #t) (toggle-flag 'test 'test-key) (database-get 'test 'test-key #t)))))) diff --git a/world.scm b/world.scm index 654e8fc..84148ea 100644 --- a/world.scm +++ b/world.scm @@ -1,3 +1,9 @@ +;;; Functions modeling a standard text adventure world. +;;; Location is modeled as containment, movement is modeled via passage nodes +;;; that hold properties and descriptions for a given exit. +;;; Global properties are held in the player object YOU, which also acts as +;;; the default avatar object. + (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) @@ -9,7 +15,10 @@ (import util) (import database) (import io) - + + + ;; The canonical name of a given cardinal direction + ;; and it's aliases. (define +cardinal-sets+ '((north n) (northeast ne north-east) @@ -22,6 +31,7 @@ (up u) (down d))) + ;; The mirror direction for a given direction. (define +cardinal-opposites+ '((north . south) (northeast . southwest) @@ -34,20 +44,37 @@ (up . down) (down . up))) + ;; Main game loop exit condition. (define *exit-adventure* #f) + (define-syntax get-set-define + (er-macro-transformer + (lambda (exp rename compare) + (let ((flag (car exp))) + (begin + `(define (,(string->symbol (string-append (symbol->string flag) "-get")) object value) + (database-get object ,flag value)) + `(define (,(string->symbol (string-append (symbol->string flag) "-set")) object value) + (database-set object ,flag value))))))) + + (get-set-define test-value) + + ;; Set the name of an object. (define (set-name object name) (database-set object 'name name)) + ;; Set the description of an object. (define (set-description object description) (database-set object 'description description)) + ;; Get the name of an object. (define (get-name object) (database-get object 'name (symbol->string object))) + ;; Get the description of an 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)) @@ -92,7 +119,7 @@ (database-set object 'fixed value)) (define (get-fixed object value) - (database-get object 'hidden #f)) + (database-get object 'fixed #f)) (define (get-put-message object) (database-get object 'put-message "You put the ~a into the ~a.")) @@ -100,7 +127,7 @@ ;; Is development mode enabled? (define (devmode-enabled?) - (has-property? 'you 'devmode)) + (database-get 'you 'devmode #f)) (define (toggle-devmode) (toggle-flag 'you 'devmode)) @@ -108,7 +135,7 @@ ;; Is an object fixed in place (e.g. cannot be picked up?) (define (fixed? object) - (has-property? object 'fixed)) + (database-get object 'fixed #f)) (define (toggle-fixed object) (toggle-flag object 'fixed)) @@ -153,7 +180,13 @@ (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))) + (map (lambda (n) + (if (not (get-hidden n)) + (begin + (display (get-name n)) + (display " ") + (if (devmode-enabled?) + (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] "))))))) (remove (curry eq? 'you) (get-contents room))) (newline)) (define (do-command-enter tag)