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