From: Christopher Allan Webber Date: Wed, 4 May 2016 02:16:57 +0000 (-0500) Subject: commands finally dispatch X-Git-Tag: fosdem-2017~189 X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=8a2341e98f75a5df295f49c08485eb6339dda19e commands finally dispatch --- diff --git a/mudsync/command.scm b/mudsync/command.scm index 28092fc..b09873a 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -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 @@ -22,6 +30,17 @@ (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 (make-command verbs matcher should-handle action priority) command? @@ -42,11 +61,19 @@ 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 @@ -56,6 +83,14 @@ 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 @@ -84,108 +119,3 @@ #: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 - (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 0daebc9..3583f95 100644 --- 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) - (make + (make (@@ (mudsync room) ) #: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 - #: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 diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index ba0d829..351abe7 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -20,8 +20,10 @@ ;;; ========== (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-simple-name-f @@ -101,11 +103,24 @@ (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) diff --git a/mudsync/player.scm b/mudsync/player.scm index feb14f8..63af65e 100644 --- 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 (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-self-commands)) @@ -41,6 +44,9 @@ (append player-actions gameobj-actions)) +(define player-dispatcher + (simple-dispatcher player-actions*)) + (define-class () (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 @@ -75,11 +81,12 @@ (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 @@ -99,4 +106,102 @@ (<- 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 09ebdcb..1a898cc 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -17,6 +17,7 @@ ;;; along with Mudsync. If not, see . (define-module (mudsync room) + #:use-module (mudsync command) #: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)) - -;; 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 () @@ -90,7 +72,7 @@ (exits #:init-value '() #:getter room-exits) - (contain-commands + (container-commands #:init-value %room-contain-commands) (message-handler