Updating mudsync for 8sync suspendable-ports refactor

[mudsync.git] / mudsync / room.scm

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 11920e2d04100b2420226eae915893a519725d24..c4305233672755dad1f35c50057de342ec40ae33 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -35,10 +35,7 @@
 ;;; =====
 
 (define-class <exit> ()
-  ;; Used for wiring
-  (to-symbol #:init-keyword #:to-symbol)
-  ;; The actual address we use
-  (to-address #:init-keyword #:address)
+  (to #:init-keyword #:to)
   ;; Name of the room (@@: Should this be names?)
   (name #:getter exit-name
         #:init-keyword #:name)
@@ -72,13 +69,11 @@
    (empty-command "look" 'cmd-look-room)
    (empty-command "go" 'cmd-go-where)
    (loose-direct-command "go" 'cmd-go)
-   (greedy-command "say" 'cmd-say)))
+   (greedy-command "say" 'cmd-say)
+   (greedy-command "emote" 'cmd-emote)))
 
 (define room-actions
   (build-actions
-   ;; desc == description
-   (init (wrap-apply room-init))
-   (wire-exits! (wrap-apply room-wire-exits!))
    (cmd-go (wrap-apply room-cmd-go))
    (cmd-go-where (wrap-apply room-cmd-go-where))
    (announce-entrance (wrap-apply room-announce-entrance))
@@ -88,7 +83,8 @@
    ;; look-room version
    (cmd-look-room (wrap-apply room-look-room))
    (cmd-look-at (wrap-apply room-look-at))
-   (cmd-say (wrap-apply room-cmd-say))))
+   (cmd-say (wrap-apply room-cmd-say))
+   (cmd-emote (wrap-apply room-cmd-emote))))
 
 (define room-actions*
   (append room-actions gameobj-actions))
@@ -111,31 +107,17 @@
    ;; @@: Can remove this indirection once things settle
    #:init-value (wrap-apply room-action-dispatch)))
 
-(define (room-init room message)
-  (room-wire-exits! room))
-
-(define (room-wire-exits! room)
-  "Actually hook up the rooms' exit addresses to the rooms they
-claim to point to."
-  (for-each
-   (lambda (exit)
-     (define new-exit
-       (message-ref
-        (<-wait room (gameobj-gm room) 'lookup-special
-                #:symbol (slot-ref exit 'to-symbol))
-        'room-id))
-
-     (slot-set! exit 'to-address new-exit))
-
-   (room-exits room)))
-
 (define-mhandler (room-cmd-go room message direct-obj)
   (define exit
     (find
      (lambda (exit)
        (equal? (exit-name exit) direct-obj))
      (room-exits room)))
-  (define to-address (slot-ref exit 'to-address))
+  (define to-address (if exit
+                         ;; Get the exit, but resolve it dynamically
+                         ;; in case it's a special
+                         (dyn-ref room (slot-ref exit 'to))
+                         #f))
   (define player-name
     (message-ref (<-wait room (message-from message)
                          'get-name) 'val))
@@ -152,7 +134,7 @@ claim to point to."
     (<- room to-address 'announce-entrance
         #:who-entered (message-from message))
     ;; Have the new room update the player to the new location
-    (<- room (slot-ref exit 'to-address) 'look-room
+    (<- room to-address 'look-room
         #:to-id (message-from message)))
    (else
     (<- room (message-from message) 'tell
@@ -301,6 +283,15 @@ claim to point to."
     (format #f "~a says: ~a\n" player-name phrase))
   (room-tell-room room message-to-send))
 
+(define-mhandler (room-cmd-emote room message phrase)
+  "Command: Say something to room participants."
+  (define player-name
+    (message-ref (<-wait room (message-from message)
+                         'get-name) 'val))
+  (define message-to-send
+    (format #f "* ~a ~a\n" player-name phrase))
+  (room-tell-room room message-to-send))
+
 (define-mhandler (room-announce-entrance room message who-entered)
   (define player-name
     (message-ref (<-wait room who-entered 'get-name)