Can FINALLY interact with objects! Woohoo!

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index a418cf0c1566b38622dd61d74264f389605c5458..bb4c8520628ba0a0b4dcb56f9babfb86564b9a64 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -51,7 +51,8 @@
    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
    (set-loc! (wrap-apply gameobj-set-loc!))
    (get-name (wrap-apply gameobj-get-name))
    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
    (set-loc! (wrap-apply gameobj-set-loc!))
    (get-name (wrap-apply gameobj-get-name))

-   (get-desc (wrap-apply gameobj-get-desc))))
+   (get-desc (wrap-apply gameobj-get-desc))
+   (goes-by (wrap-apply gameobj-goes-by))))

 
 ;;; *all* game components that talk to players should somehow
 ;;; derive from this class.
 
 ;;; *all* game components that talk to players should somehow
 ;;; derive from this class.


@@ -71,7 +72,9 @@
       #:getter gameobj-gm)
   ;; a name to be known by
   (name #:init-keyword #:name
       #:getter gameobj-gm)
   ;; a name to be known by
   (name #:init-keyword #:name

-        #:accessor gameobj-name)
+        #:init-value #f)
+  (goes-by #:init-keyword #:goes-by
+           #:init-value #f)

 
   (desc #:init-value ""
         #:init-keyword #:desc)
 
   (desc #:init-value ""
         #:init-keyword #:desc)


@@ -81,10 +84,6 @@
           #:getter gameobj-name-f
           #:init-value (wrap gameobj-simple-name-f))
 
           #:getter gameobj-name-f
           #:init-value (wrap gameobj-simple-name-f))
 

-  ;; Name aliases
-  (aliases #:init-keyword #:aliases
-           #:init-value '())
-

   ;; Commands we can handle
   (commands #:init-value '())
 
   ;; Commands we can handle
   (commands #:init-value '())
 


@@ -111,6 +110,15 @@
   "Your most basic game object init procedure.  Does nothing."
   #f)
 
   "Your most basic game object init procedure.  Does nothing."
   #f)
 

+(define (gameobj-goes-by gameobj)
+  "Find the name we go by.  Defaults to #:name if nothing else provided."
+  (cond ((slot-ref gameobj 'goes-by) =>
+         identity)
+        ((slot-ref gameobj 'name) =>
+         (lambda (name)
+           (list name)))
+        (else '())))
+

 (define (val-or-run val-or-proc)
   "Evaluate if a procedure, or just return otherwise"
   (if (procedure? val-or-proc)
 (define (val-or-run val-or-proc)
   "Evaluate if a procedure, or just return otherwise"
   (if (procedure? val-or-proc)


@@ -128,7 +136,9 @@
   (define filtered-commands
     (filter-commands (val-or-run (slot-ref actor 'commands))
                      verb))
   (define filtered-commands
     (filter-commands (val-or-run (slot-ref actor 'commands))
                      verb))

-  (<-reply actor message #:commands filtered-commands))
+  (<-reply actor message
+           #:commands filtered-commands
+           #:goes-by (gameobj-goes-by actor)))

 
 (define-mhandler (gameobj-get-container-commands actor message verb)
   (define filtered-commands
 
 (define-mhandler (gameobj-get-container-commands actor message verb)
   (define filtered-commands


@@ -170,5 +180,3 @@
 (define (gameobj-simple-name-f gameobj)
   "Simplest version: return ourselves for our name."
   (gameobj-name gameobj))
 (define (gameobj-simple-name-f gameobj)
   "Simplest version: return ourselves for our name."
   (gameobj-name gameobj))

-
-

diff --git a/mudsync/parser.scm b/mudsync/parser.scm
index 3d84195206cce90e0923c7fb40420691d3574f5a..e9c4096c1b3a298cb1ce1683e366d4eda8b1d2f9 100644 (file)
--- a/mudsync/parser.scm
+++ b/mudsync/parser.scm
@@ -93,7 +93,7 @@
 
 (define (cmatch-direct-obj-greedy phrase)
   ;; Turns out this uses the same semantics as splitting verb/rest
 
 (define (cmatch-direct-obj-greedy phrase)
   ;; Turns out this uses the same semantics as splitting verb/rest

-  (match (split-verb-and-rest string)
+  (match (split-verb-and-rest phrase)

     ((direct-obj . rest)
      (list #:direct-obj direct-obj
            #:rest rest))
     ((direct-obj . rest)
      (list #:direct-obj direct-obj
            #:rest rest))

diff --git a/mudsync/player.scm b/mudsync/player.scm
index bf19a16a6b0e1a0a4716f70333cddaec2a757b8e..00b28edde4cbeab67239e2266dd462d06469c9d6 100644 (file)
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -37,11 +37,9 @@
 
 (define player-actions
   (build-actions
 
 (define player-actions
   (build-actions

-   (init (wrap-apply player-init!))
+   (init (wrap-apply player-init))

    (handle-input (wrap-apply player-handle-input))
    (handle-input (wrap-apply player-handle-input))

-   (tell (wrap-apply player-tell))
-   ;; @@: We really need to unify / make sensible this look stuff
-   (look-room (wrap-apply player-look-room))))
+   (tell (wrap-apply player-tell))))

 
 (define player-actions*
   (append player-actions
 
 (define player-actions*
   (append player-actions


@@ -68,8 +66,9 @@
 
 ;;; player message handlers
 
 
 ;;; player message handlers
 

-(define-mhandler (player-init! player message)
-  (player-look-around player))
+(define-mhandler (player-init player message)
+  ;; Look around the room we're in
+  (<- player (gameobj-loc player) 'look-room))

 
 
 (define-mhandler (player-handle-input player message input)
 
 
 (define-mhandler (player-handle-input player message input)


@@ -95,26 +94,6 @@
   (<- player (gameobj-gm player) 'write-home
       #:text text))
 
   (<- player (gameobj-gm player) 'write-home
       #:text text))
 

-(define-mhandler (player-look-room player message)
-  (player-look-around player))
-
-
-;;; player methods
-
-(define (player-look-around player)
-  (define room-name
-    (message-ref
-     (<-wait player (gameobj-loc player) 'get-name)
-     'val))
-  (define room-desc
-    (message-ref
-     (<-wait player (gameobj-loc player) 'get-desc)
-     'val))
-  (define message-text
-    (format #f "**~a**\n~a\n" room-name room-desc))
-
-  (<- player (gameobj-gm player) 'write-home #:text message-text))
-

 
 ;;; Command handling
 ;;; ================
 
 ;;; Command handling
 ;;; ================


@@ -156,14 +135,20 @@
   (define co-occupant-commands
     ;; TODO: Switch this to a fold.  Ignore a result if it
     ;;   returns false for in the command response
   (define co-occupant-commands
     ;; TODO: Switch this to a fold.  Ignore a result if it
     ;;   returns false for in the command response

-    (map
-     (lambda (co-occupant)
-       (let ((result (<-wait player co-occupant 'get-commands
-                             #:verb verb)))
-         (list
-          (message-ref result 'commands)
-          (message-ref result 'goes-by)
-          co-occupant)))
+    (fold
+     (lambda (co-occupant prev)
+       (display "pre-message\n")
+       (let* ((result (<-wait player co-occupant 'get-commands
+                              #:verb verb))
+              (commands (message-ref result 'commands))
+              (goes-by (message-ref result 'goes-by)))
+         (display "post-message\n")
+         (append
+          (map (lambda (command)
+                 (list command goes-by co-occupant))
+               commands)
+          prev)))
+     '()

      co-occupants))
 
   ;; Append our own command handlers
      co-occupants))
 
   ;; Append our own command handlers


@@ -188,8 +173,10 @@
   (sort
    actors-and-commands
    (lambda (x y)
   (sort
    actors-and-commands
    (lambda (x y)

-     (> (command-priority (car (pk 'x x)))
-        (command-priority (car (pk 'y y)))))))
+     (pk 'x x)
+     (pk 'y y)
+     (> (command-priority (car x))
+        (command-priority (car y))))))

 
 
 (define (find-command-winner sorted-candidates line)
 
 
 (define (find-command-winner sorted-candidates line)

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 56c5a5922751a71bb209e92bef8a8f8e9ff3ee1f..aee0636ab4c817c6e9c985d18c6bee1ef2b888e9 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -79,7 +79,10 @@
    (wire-exits! (wrap-apply room-wire-exits!))
    (cmd-go (wrap-apply room-cmd-go))
    (cmd-go-where (wrap-apply room-cmd-go-where))
    (wire-exits! (wrap-apply room-wire-exits!))
    (cmd-go (wrap-apply room-cmd-go))
    (cmd-go-where (wrap-apply room-cmd-go-where))

-   (cmd-look-room (wrap-apply room-cmd-look-room))))
+   (look-room (wrap-apply room-look-room))
+   ;; in this case the command is the same version as the normal
+   ;; look-room version
+   (cmd-look-room (wrap-apply room-look-room))))

 
 (define room-actions*
   (append room-actions gameobj-actions))
 
 (define room-actions*
   (append room-actions gameobj-actions))


@@ -128,9 +131,12 @@ claim to point to."
      (room-exits room)))
   (cond
    (exit
      (room-exits room)))
   (cond
    (exit

+    ;; Set the player's new location

     (<-wait room (message-from message) 'set-loc!
             #:loc (slot-ref exit 'to-address))
     (<-wait room (message-from message) 'set-loc!
             #:loc (slot-ref exit 'to-address))

-    (<- room (message-from message) 'look-room))
+    ;; Have the new room update the player to the new location
+    (<- room (slot-ref exit 'to-address) 'look-room
+        #:to-id (message-from message)))

    (else
     (<- room (message-from message) 'tell
         #:text "You don't see any way to go there.\n"))))
    (else
     (<- room (message-from message) 'tell
         #:text "You don't see any way to go there.\n"))))


@@ -139,5 +145,22 @@ claim to point to."
   (<- room (message-from message) 'tell
       #:text "Go where?\n"))
 
   (<- room (message-from message) 'tell
       #:text "Go where?\n"))
 

-(define-mhandler (room-cmd-look-room room message)
-  (<- room (message-from message) 'look-room))
+;;; look commands
+
+(define (room-player-looks-around room player-id)
+  "Handle looking around the room"
+  (define room-text
+    (format #f "**~a**\n~a\n"
+            (slot-ref room 'name)
+            (slot-ref room 'desc)))
+  (<- room player-id 'tell
+      #:text room-text))
+
+(define-mhandler (room-look-room room message)
+  "Command: Player asks to look around the room"
+  (room-player-looks-around
+   room
+   ;; Either send it to the #:to-id of the message, or to the
+   ;; sender of the message
+   (message-ref message 'to-id
+                (message-from message))))

diff --git a/worlds/goblin-hq.scm b/worlds/goblin-hq.scm
index 34b430d372def445e64fb70543ad959934c71398..bd79b800e0734d0d3c5f2f52496c7b0b36dface6 100644 (file)
--- a/worlds/goblin-hq.scm
+++ b/worlds/goblin-hq.scm
@@ -28,9 +28,9 @@
 ;;; ----------
 
 (define-class <fridge> (<gameobj>)
 ;;; ----------
 
 (define-class <fridge> (<gameobj>)

-  #:name "fridge"
-  #:desc "The refrigerator is humming.  To you?  To itself?
-Only the universe knows.")
+  (name #:init-value "fridge")
+  (desc #:init-value "The refrigerator is humming.  To you?  To itself?
+Only the universe knows."))

 
 
 ;;; The typewriter
 
 
 ;;; The typewriter


@@ -69,7 +69,7 @@ You type some gibberish on the typewriter.\n"))
 (define (type-thing actor message type-text)
   (<- actor (message-from message) 'tell
       #:text
 (define (type-thing actor message type-text)
   (<- actor (message-from message) 'tell
       #:text

-      (format #f "You type out a note.\nThe note says: ~s"
+      (format #f "You type out a note.\nThe note says: ~s\n"

               type-text)))
 
 (define-mhandler (typewriter-cmd-type-something
               type-text)))
 
 (define-mhandler (typewriter-cmd-type-something