commands finally dispatch

diff --git a/mudsync/command.scm b/mudsync/command.scm
index 28092fcf43cf0f7b1939ba0910a411c6c3ae1ba5..b09873a06f416f8133c6dde8eea37dd8e37f3fdd 100644 (file)
--- a/mudsync/command.scm
+++ b/mudsync/command.scm
@@ -1,14 +1,22 @@
 (define-module (mudsync command)
   #:use-module (mudsync parser)
 (define-module (mudsync command)
   #:use-module (mudsync parser)

-  #:use-module (mudsync gameobj)

   #:use-module (8sync systems actors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
 
   #:use-module (8sync systems actors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
 

-  #:export (direct-command
+  #:export (command?
+            command-verbs
+            command-matcher
+            command-should-handle
+            command-action
+            command-priority
+
+            direct-command

             indir-command
             indir-command

+            loose-direct-command
+            loose-indir-command

             empty-command
             direct-greedy-command
             greedy-command
             empty-command
             direct-greedy-command
             greedy-command


@@ -22,6 +30,17 @@
 (define %default-priority 1)
 (define %high-priority 2)
 
 (define %default-priority 1)
 (define %high-priority 2)
 

+;; ;;; Avoiding some annoying issues crossing the continuation barrier
+;; ;;; and the "@@" special form
+;; (define (make-command verbs matcher should-handle action priority)
+;;   (list '*command* verbs matcher should-handle action priority))
+
+;; (define command-verbs second)
+;; (define command-matcher third)
+;; (define command-should-handle fourth)
+;; (define command-action fifth)
+;; (define command-priority sixth)
+

 (define-record-type <command>
   (make-command verbs matcher should-handle action priority)
   command?
 (define-record-type <command>
   (make-command verbs matcher should-handle action priority)
   command?


@@ -42,11 +61,19 @@
                 action
                 %default-priority))
 
                 action
                 %default-priority))
 

-(define* (indir-command verbs action #:optional prepositions)
+(define (loose-direct-command verbs action)

   (make-command verbs
   (make-command verbs

-                cmatch-indir-obj
+                cmatch-direct-obj

                 ;; @@: Should we allow fancier matching than this?
                 ;;   Let the actor itself pass along this whole method?
                 ;; @@: Should we allow fancier matching than this?
                 ;;   Let the actor itself pass along this whole method?

+                (const #t)
+                action
+                %default-priority))
+
+
+(define* (indir-command verbs action #:optional prepositions)
+  (make-command verbs
+                cmatch-indir-obj

                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
                   (if prepositions
                       (and
                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
                   (if prepositions
                       (and


@@ -56,6 +83,14 @@
                 action
                 %high-priority))
 
                 action
                 %high-priority))
 

+(define* (loose-indir-command verbs action #:optional prepositions)
+  (make-command verbs
+                cmatch-indir-obj
+                (const #t)
+                action
+                %high-priority))
+
+

 (define (empty-command verbs action)
   (make-command verbs
                 cmatch-empty
 (define (empty-command verbs action)
   (make-command verbs
                 cmatch-empty


@@ -84,108 +119,3 @@
                          #:optional (priority %default-priority))
   "Full-grained customizable command."
   (make-command verbs matcher should-handle action priority))
                          #:optional (priority %default-priority))
   "Full-grained customizable command."
   (make-command verbs matcher should-handle action priority))

-
-
-;;; Command handling
-;;; ================
-
-;; @@: Hard to know whether this should be in player.scm or here...
-;; @@: This could be more efficient as a stream...!?
-(define (player-gather-command-handlers player verb)
-
-  (define player-loc
-    (let ((result (gameobj-loc player)))
-      (if result
-          result
-          (throw 'player-has-no-location
-                 "Player ~a has no location!  How'd that happen?\n"
-                 #:player-id (actor-id player)))))
-
-  ;; Ask the room for its commands
-  (define room-commands
-    ;; TODO: Map room id and sort
-    (message-ref
-     (<-wait player player-loc
-             'get-container-commands
-             #:verb verb)
-     'commands))
-
-  ;; All the co-occupants of the room (not including ourself)
-  (define co-occupants
-    (remove
-     (lambda (x) (equal? x (actor-id player)))
-     (message-ref
-      (<-wait player player-loc 'get-occupants)
-      'occupants)))
-
-  ;; @@: There's a race condition here if someone leaves the room
-  ;;   during this, heh...
-  ;;   I'm not sure it can be solved, but "lag" on the race can be
-  ;;   reduced maybe?
-
-  ;; Get all the co-occupants' commands
-  (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)))
-     co-occupants))
-
-  ;; Append our own command handlers
-  (define our-commands
-    ((@@ (mudsync player) player-self-commands) player))
-
-  ;; TODO: Append our inventory's relevant command handlers
-
-  ;; Now return a big ol sorted list of ((actor-id . command))
-  (append
-   (sort-commands-append-actor room-commands
-                               player-loc '()) ; room doesn't go by anything
-   (sort-commands-multi-actors co-occupant-commands)
-   (sort-commands-append-actor our-commands
-                               (actor-id player) '()))) ; nor does player
-
-(define (sort-commands-append-actor commands actor-id goes-by)
-  (sort-commands-multi-actors
-   (map (lambda (command) (list command actor-id)) commands)))
-
-(define (sort-commands-multi-actors actors-and-commands)
-  (sort
-   actors-and-commands
-   (lambda (x y)
-     (> (command-priority (cdr x))
-        (command-priority (cdr y))))))
-
-
-(define-record-type <command-winner>
-  (make-command-winner action actor-id)
-  command-winner?
-  (action command-winner-action)
-  (actor-id command-winner-action-id))
-
-
-(define (find-command-winner sorted-candidates line)
-  "Find a command winner from a sorted list of candidates"
-  ;; A cache of results from matchers we've already seen
-  (define matcher-cache '())
-  (find
-   (match-lambda
-     ((command actor-id actor-goes-by)
-      
-      (let* ((matcher (command-matcher command))
-             (matched (matcher line)))
-        (if (and matched
-                 ;; Great, it matched, but does it also pass
-                 ;; should-handle?
-                 (apply (command-should-handle command)
-                        actor-goes-by
-                        matched))  ; matched is kwargs if truthy
-            actor-id
-            #f))))
-   sorted-candidates))

diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm
index 0daebc978a5bc7e8b705cad79c9fe0b171b22dd2..3583f95662cc68a25abb72f8ddeaa4d82f689d9b 100644 (file)
--- a/mudsync/game-master.scm
+++ b/mudsync/game-master.scm
@@ -85,7 +85,7 @@
     "Take room exits syntax from the spec, turn it into exits"
     (match exit-spec
       ((name to-symbol desc)
     "Take room exits syntax from the spec, turn it into exits"
     (match exit-spec
       ((name to-symbol desc)

-       (make <exit>
+       (make (@@ (mudsync room) <exit>)

          #:name name
          #:to-symbol to-symbol
          #:desc desc))))
          #:name name
          #:to-symbol to-symbol
          #:desc desc))))


@@ -146,12 +146,7 @@
   (format #t "DEBUG: From ~s: ~s\n" client-id input)
 
   (<- actor player 'handle-input
   (format #t "DEBUG: From ~s: ~s\n" client-id input)
 
   (<- actor player 'handle-input

-      #:input input)
-
-  ;; TODO: Remove this shortly
-  (<- actor (gm-network-manager actor) 'send-to-client
-      #:client client-id
-      #:data "Thanks, we got it!\n"))
+      #:input input))

 
 (define-mhandler (gm-lookup-room actor message symbol)
   (define room-id
 
 (define-mhandler (gm-lookup-room actor message symbol)
   (define room-id

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index ba0d8291b3ddcbbfcf4871ec1616ade69e94d6d1..351abe7c22a9094f0666938b73620f7669406ca9 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -20,8 +20,10 @@
 ;;; ==========
 
 (define-module (mudsync gameobj)
 ;;; ==========
 
 (define-module (mudsync gameobj)

+  #:use-module (mudsync command)

   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)

+  #:use-module (srfi srfi-1)

   #:use-module (oop goops)
   #:export (<gameobj>
             gameobj-simple-name-f
   #:use-module (oop goops)
   #:export (<gameobj>
             gameobj-simple-name-f


@@ -101,11 +103,24 @@
     (reply-message actor message
                    #:val (slot-ref actor slot))))
 
     (reply-message actor message
                    #:val (slot-ref actor slot))))
 

+(define (filter-commands commands verb)
+  (filter
+   (lambda (cmd)
+     (equal? (command-verbs cmd)
+             verb))
+   commands))
+

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

-  (<-reply actor message #:commands (slot-ref actor 'commands)))
+  (define filtered-commands
+    (filter-commands (slot-ref actor 'commands)
+                     verb))
+  (<-reply actor message #:commands filtered-commands))

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

-  (<-reply actor message #:commands (slot-ref actor 'container-commands)))
+  (define filtered-commands
+    (filter-commands (slot-ref actor 'container-commands)
+                     verb))
+  (<-reply actor message #:commands filtered-commands))

 
 (define-mhandler (gameobj-add-occupant! actor message who)
   (hash-set! (slot-ref actor 'occupants)
 
 (define-mhandler (gameobj-add-occupant! actor message who)
   (hash-set! (slot-ref actor 'occupants)

diff --git a/mudsync/player.scm b/mudsync/player.scm
index feb14f80a2375e9b67a4d6b4728ab558226c0c12..63af65e77a8f84071f5780cfd486f6a5fb183717 100644 (file)
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -23,9 +23,12 @@
   #:use-module (mudsync parser)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (mudsync parser)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)

+  #:use-module (ice-9 control)

   #:use-module (ice-9 format)
   #:use-module (ice-9 format)

+  #:use-module (ice-9 match)

   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)

+  #:use-module (srfi srfi-9)

   #:export (<player>
             player-self-commands))
 
   #:export (<player>
             player-self-commands))
 


@@ -41,6 +44,9 @@
   (append player-actions
           gameobj-actions))
 
   (append player-actions
           gameobj-actions))
 

+(define player-dispatcher
+  (simple-dispatcher player-actions*))
+

 (define-class <player> (<gameobj>)
   (username #:init-keyword #:username
             #:accessor player-username)
 (define-class <player> (<gameobj>)
   (username #:init-keyword #:username
             #:accessor player-username)


@@ -54,7 +60,7 @@
   (message-handler
    #:init-value
    ;; @@: We're gonna need action inheritance real awful soon, huh?
   (message-handler
    #:init-value
    ;; @@: We're gonna need action inheritance real awful soon, huh?

-   (simple-dispatcher player-actions*)))
+   (wrap-apply player-dispatcher)))

 
 
 ;;; player message handlers
 
 
 ;;; player message handlers


@@ -75,11 +81,12 @@
   (define winner
     (pk 'winner (find-command-winner command-candidates input-rest)))
 
   (define winner
     (pk 'winner (find-command-winner command-candidates input-rest)))
 

-  (<- player (gameobj-gm player) 'write-home
-      #:text
-      (format #f "<~a>: ~s\n"
-              (player-username player)
-              input)))
+  (match winner
+    ((cmd-action winner-id message-args)
+     (apply send-message player (pk 'winner-id winner-id) (pk 'cmd-action cmd-action) (pk 'message-args message-args)))
+    (#f
+     (<- player (gameobj-gm player) 'write-home
+         #:text "Huh?\n"))))

 
 
 ;;; player methods
 
 
 ;;; player methods


@@ -99,4 +106,102 @@
   (<- player (gameobj-gm player) 'write-home #:text message-text))
 
 
   (<- player (gameobj-gm player) 'write-home #:text message-text))
 
 

+;;; Command handling
+;;; ================
+
+;; @@: Hard to know whether this should be in player.scm or here...
+;; @@: This could be more efficient as a stream...!?
+(define (player-gather-command-handlers player verb)
+  (define player-loc
+    (let ((result (gameobj-loc player)))
+      (if result
+          result
+          (throw 'player-has-no-location
+                 "Player ~a has no location!  How'd that happen?\n"
+                 #:player-id (actor-id player)))))

 
 

+  ;; Ask the room for its commands
+  (define room-commands
+    ;; TODO: Map room id and sort
+    (message-ref
+     (<-wait player player-loc
+             'get-container-commands
+             #:verb verb)
+     'commands))
+
+  ;; All the co-occupants of the room (not including ourself)
+  (define co-occupants
+    (remove
+     (lambda (x) (equal? x (actor-id player)))
+     (message-ref
+      (<-wait player player-loc 'get-occupants)
+      'occupants)))
+
+  ;; @@: There's a race condition here if someone leaves the room
+  ;;   during this, heh...
+  ;;   I'm not sure it can be solved, but "lag" on the race can be
+  ;;   reduced maybe?
+
+  ;; Get all the co-occupants' commands
+  (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)))
+     co-occupants))
+
+  ;; Append our own command handlers
+  (define our-commands
+    (player-self-commands player))
+
+  ;; TODO: Append our inventory's relevant command handlers
+
+  ;; Now return a big ol sorted list of ((actor-id . command))
+  (append
+   (sort-commands-append-actor (pk 'room-commands room-commands)
+                               player-loc '()) ; room doesn't go by anything
+   (sort-commands-multi-actors co-occupant-commands)
+   (sort-commands-append-actor our-commands
+                               (actor-id player) '()))) ; nor does player
+
+(define (sort-commands-append-actor commands actor-id goes-by)
+  (sort-commands-multi-actors
+   (map (lambda (command) (list command goes-by actor-id)) commands)))
+
+(define (sort-commands-multi-actors actors-and-commands)
+  (sort
+   actors-and-commands
+   (lambda (x y)
+     (> (command-priority (car (pk 'x x)))
+        (command-priority (car (pk 'y y)))))))
+
+
+(define (find-command-winner sorted-candidates line)
+  "Find a command winner from a sorted list of candidates"
+  ;; A cache of results from matchers we've already seen
+  ;; TODO: fill this in
+  (define matcher-cache '())
+  (call/ec
+   (lambda (return)
+     (for-each
+      (match-lambda
+        ((command actor-goes-by actor-id)
+         (let* ((matcher (command-matcher command))
+                (matched (matcher line)))
+           (if (and matched
+                    ;; Great, it matched, but does it also pass
+                    ;; should-handle?
+                    (apply (command-should-handle command)
+                           actor-goes-by
+                           matched))  ; matched is kwargs if truthy
+               (return (list (command-action command)
+                             (pk 'earlier-actor-id actor-id) matched))
+               #f))))
+      sorted-candidates)
+     #f)))

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 09ebdcbc0db8531802edf22e6e56d69ea702befa..1a898cc5262347c485487556dca357135a5a6d8a 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -17,6 +17,7 @@
 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (mudsync room)
 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (mudsync room)

+  #:use-module (mudsync command)

   #:use-module (mudsync gameobj)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (mudsync gameobj)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)


@@ -59,30 +60,11 @@
                            #:optional (target-actor (actor-id actor)))
   ((slot-ref exit 'traverse-check) exit actor target-actor))
 
                            #:optional (target-actor (actor-id actor)))
   ((slot-ref exit 'traverse-check) exit actor target-actor))
 

-
-;; Kind of a useful utility, maybe?
-(define (simple-slot-getter slot)
-  (lambda (actor message)
-    (reply-message actor message
-                   #:val (slot-ref actor slot))))
-
-(define always (const #t))
-
-;; TODO: remove hack
-(define full-command list)
-
-;; TODO: fill these in
-(define cmatch-just-verb #f)
-(define cmatch-direct-verb #f)
-(define cmatch-direct-obj #f)
-

 (define %room-contain-commands
   (list
 (define %room-contain-commands
   (list

-   (full-command "look" cmatch-just-verb always 'look-room)
-   (full-command "look" cmatch-direct-obj always 'look-member)
-   (full-command "go" cmatch-just-verb always 'go-where)
-   (full-command "go" cmatch-direct-obj always 'go-exit)))
-
+   (loose-direct-command "look" 'cmd-look-at)
+   (empty-command "look" 'cmd-look-room)
+   (loose-direct-command "go" 'cmd-go)))

 
 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)
 
 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)


@@ -90,7 +72,7 @@
   (exits #:init-value '()
          #:getter room-exits)
 
   (exits #:init-value '()
          #:getter room-exits)
 

-  (contain-commands
+  (container-commands

    #:init-value %room-contain-commands)
 
   (message-handler
    #:init-value %room-contain-commands)
 
   (message-handler