From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Mon, 30 Jan 2017 22:44:30 +0000 (-0600)
Subject: Whee, movement shorthands!
X-Git-Tag: fosdem-2017~26
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=b91e6c2bc7153e68f5c4dff61c63aec16b80662f;p=mudsync.git

Whee, movement shorthands!
---

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 8f1e0a3..1667b10 100644
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -60,6 +60,10 @@
 ;;; Rooms
 ;;; =====
 
+(define (exit-shorthand name)
+  (lambda (room message)
+    (room-cmd-go room message #:direct-obj name)))
+
 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)
   ;; A list of <exit>
@@ -75,7 +79,18 @@
     ("go" ((empty-command cmd-go-where)
            (loose-direct-command cmd-go)))
     (("say" "\"" "'") ((greedy-command cmd-say)))
-    (("emote" "/me") ((greedy-command cmd-emote)))))
+    (("emote" "/me") ((greedy-command cmd-emote)))
+    ;; movement aliases
+    (("n" "north") ((empty-command go-north)))
+    (("ne" "northeast") ((empty-command go-northeast)))
+    (("e" "east") ((empty-command go-east)))
+    (("se" "southeast") ((empty-command go-southeast)))
+    (("s" "south") ((empty-command go-south)))
+    (("sw" "southwest") ((empty-command go-southwest)))
+    (("w" "west") ((empty-command go-west)))
+    (("nw" "northwest") ((empty-command go-northwest)))
+    (("u" "up") ((empty-command go-up)))
+    (("d" "down") ((empty-command go-down)))))
 
   (container-sub-commands
    #:allocation #:each-subclass
@@ -96,13 +111,40 @@
             (cmd-look-room room-look-room)
             (cmd-look-at-from-room room-look-dont-see-it)
             (cmd-say room-cmd-say)
-            (cmd-emote room-cmd-emote))))
+            (cmd-emote room-cmd-emote)
+            ;; movement aliases
+            (go-north (exit-shorthand "north"))
+            (go-northeast (exit-shorthand "northeast"))
+            (go-east (exit-shorthand "east"))
+            (go-southeast (exit-shorthand "southeast"))
+            (go-south (exit-shorthand "south"))
+            (go-southwest (exit-shorthand "southwest"))
+            (go-west (exit-shorthand "west"))
+            (go-northwest (exit-shorthand "northwest"))
+            (go-up (exit-shorthand "up"))
+            (go-down (exit-shorthand "down")))))
+
+(define common-exit-aliases
+  '(("n" . "north")
+    ("ne" . "northeast")
+    ("e" . "east")
+    ("se" . "southeast")
+    ("s" . "south")
+    ("sw" . "southwest")
+    ("w" . "west")
+    ("nw" . "northwest")
+    ("u" . "up")
+    ("d" . "down")))
+
+(define (dealias-exit-name exit-name)
+  (or (assoc-ref common-exit-aliases exit-name)
+      exit-name))
 
 (define* (room-cmd-go room message #:key direct-obj)
   (define exit
     (find
      (lambda (exit)
-       (equal? (exit-name exit) direct-obj))
+       (equal? (exit-name exit) (dealias-exit-name direct-obj)))
      (room-exits room)))
   (define to-address (if exit
                          ;; Get the exit, but resolve it dynamically
@@ -161,7 +203,7 @@
   ;; Get the room text
   (define room-text
     `((strong "=> " ,(slot-ref room 'name) " <=")
-      (p ,(slot-ref room 'desc))))
+      (p ,(gameobj-desc room))))
 
   ;; Get a list of other things the player would see in the room
   (define occupant-names-all