commands finally dispatch
authorChristopher Allan Webber <cwebber@dustycloud.org>
Wed, 4 May 2016 02:16:57 +0000 (21:16 -0500)
committerChristopher Allan Webber <cwebber@dustycloud.org>
Wed, 4 May 2016 02:16:57 +0000 (21:16 -0500)
mudsync/command.scm
mudsync/game-master.scm
mudsync/gameobj.scm
mudsync/player.scm
mudsync/room.scm

index 28092fcf43cf0f7b1939ba0910a411c6c3ae1ba5..b09873a06f416f8133c6dde8eea37dd8e37f3fdd 100644 (file)
@@ -1,14 +1,22 @@
 (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)
 
-  #:export (direct-command
+  #:export (command?
+            command-verbs
+            command-matcher
+            command-should-handle
+            command-action
+            command-priority
+
+            direct-command
             indir-command
+            loose-direct-command
+            loose-indir-command
             empty-command
             direct-greedy-command
             greedy-command
 (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?
                 action
                 %default-priority))
 
-(define* (indir-command verbs action #:optional prepositions)
+(define (loose-direct-command verbs action)
   (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?
+                (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
                 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
                          #: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))
index 0daebc978a5bc7e8b705cad79c9fe0b171b22dd2..3583f95662cc68a25abb72f8ddeaa4d82f689d9b 100644 (file)
@@ -85,7 +85,7 @@
     "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))))
   (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
index ba0d8291b3ddcbbfcf4871ec1616ade69e94d6d1..351abe7c22a9094f0666938b73620f7669406ca9 100644 (file)
 ;;; ==========
 
 (define-module (mudsync gameobj)
+  #:use-module (mudsync command)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
+  #:use-module (srfi srfi-1)
   #:use-module (oop goops)
   #:export (<gameobj>
             gameobj-simple-name-f
     (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)
-  (<-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)
-  (<-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)
index feb14f80a2375e9b67a4d6b4728ab558226c0c12..63af65e77a8f84071f5780cfd486f6a5fb183717 100644 (file)
   #: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 match)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:export (<player>
             player-self-commands))
 
@@ -41,6 +44,9 @@
   (append player-actions
           gameobj-actions))
 
+(define player-dispatcher
+  (simple-dispatcher player-actions*))
+
 (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?
-   (simple-dispatcher player-actions*)))
+   (wrap-apply player-dispatcher)))
 
 
 ;;; player message handlers
   (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 (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)))
index 09ebdcbc0db8531802edf22e6e56d69ea702befa..1a898cc5262347c485487556dca357135a5a6d8a 100644 (file)
@@ -17,6 +17,7 @@
 ;;; 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)
                            #: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
-   (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>)
@@ -90,7 +72,7 @@
   (exits #:init-value '()
          #:getter room-exits)
 
-  (contain-commands
+  (container-commands
    #:init-value %room-contain-commands)
 
   (message-handler