up, down, all around

kekkonen.scm

@@ -394,7 +394,55 @@
 	  (begin
 	    (set-description tag description)))))
 
+(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 (get-cardinal-aliases direction)
+  (let loop ((directions +cardinal-sets+))
+    (if (null? directions)
+	#f
+	(if (member direction (car directions))
+	    (remove direction (car directions))
+	    (loop (cdr directions))))))
+
+(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)
+  (let loop ((directions +cardinal-sets+))
+    (if (null? directions)
+	#f
+	(if (member direction (car directions))
+	    (caar directions)
+	    (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.")