whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

remove database warnings

Browse Source
This commit is contained in:
Victor Fors 2021-12-09 17:17:11 +01:00
parent 9f9ad35f7e
commit 011e7a34a1
3 changed files with 52 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

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

24
test-database.scm
View File

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

45
world.scm
View File

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