diff --git a/kekkonen.scm b/kekkonen.scm index fc21422..eda7a44 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -235,6 +235,12 @@ (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.")) @@ -329,9 +335,7 @@ (print-room-description (get-container 'you))) (define (do-command-examine tag) - (let ((object (match-object tag (if (devmode-enabled?) - (get-all-objects) - (visible-objects 'you))))) + (let ((object (match-object tag (visible-objects 'you)))) (if (not object) (show "You cannot see that here.") (show (get-description object))))) @@ -403,6 +407,61 @@ (define (do-command-describe tag description) (do-setter-command tag description string? set-description)) +(define +object-flags+ + '(fixed hidden)) + +(define (do-command-flag tag flag) + (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+))) + (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)))))))) + +(define (do-command-unflag tag flag) + (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+))) + (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)))))))) + +(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-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 +cardinal-sets+ '((north n) (northeast ne north-east) @@ -495,6 +554,11 @@ (('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)) + (('message x y z) (do-command-message x y z)) (_ (set! success #f))) (set! success #f)))) success))