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