more commands

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