programmation

kekkonen.scm

@@ -102,7 +102,7 @@
 		  (prompt-yn str))))))
 
 (define +articles-prepositions+
-  '(a an the into on to at))
+  '(a an the into on to at as))
 
 (define (adventure-prompt)
   (let ((result (parse (completely-parse parse-statement) (prompt "> "))))
@@ -378,21 +378,20 @@
 	    (create-object tag name description)
 	    (move-object tag (get-container 'you))))))
 
-(define (do-command-rename tag name)
-  (if (not (and (symbol? tag) (string? name)))
+(define (define-setter-command tag value type? setter)
+  (if (not (and (symbol? tag) (type? value)))
       (show "I didn't quite understand that.")
-      (if (not (object-exists? tag))
-	  (show "That object doesn't exist.")
-	  (begin
-	    (set-name tag name)))))
+      (let ((object (match-object tag (visible-objects 'you))))
+	(if (not object)
+	    (show "You can't see that here.")
+	    (begin
+	      (setter tag value))))))
+
+(define (do-command-rename tag name)
+  (define-setter-command tag name string? set-name))
 
 (define (do-command-describe tag description)
-  (if (not (and (symbol? tag) (string? description)))
-      (show "I didn't quite understand that.")
-      (if (not (object-exists? tag))
-	  (show "That object doesn't exist.")
-	  (begin
-	    (set-description tag description)))))
+  (define-setter-command tag description string? set-description))
 
 (define +cardinal-sets+
   '((north n)
@@ -423,7 +422,7 @@
     (if (null? directions)
 	#f
 	(if (member direction (car directions))
-	    (remove direction (car directions))
+	    (remove (cut eq? direction <>) (car directions))
 	    (loop (cdr directions))))))
 
 (define (cardinal-direction? direction)
@@ -441,18 +440,22 @@
 	    (loop (cdr directions))))))
 
 (define (do-command-dig direction destination)
-  (if (not (and (symbol? direction) (symbol? destination)
-		(member direction '(
-  (let ((exit-tag (compose-symbols 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)
-	  (add-alias exit-tag direction)
-	  (show "You create a passage.")))))
-
+  (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)
+		    (add-alias exit-tag canonical-direction)
+		    (map (cut add-alias exit-tag <>) (get-cardinal-aliases canonical-direction))
+		    (show "You create a passage."))))))))
+      
 (define (do-command-exit)
   (show "Goodbye, see you later...")
   (set! *exit-adventure* #t))
@@ -465,6 +468,9 @@
     (('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)