From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Tue, 3 May 2016 14:45:23 +0000 (-0500)
Subject: Many steps towards handling input (but not there yet...)
X-Git-Tag: fosdem-2017~193
X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=136ce3b725c83af0b7e8be632e943de6b07b65c5

Many steps towards handling input (but not there yet...)
---

diff --git a/Makefile.am b/Makefile.am
index a9c186f..bccc808 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -45,6 +45,7 @@ moddir=$(prefix)/share/guile/site/2.0
 godir=$(libdir)/guile/2.0/ccache
 
 SOURCES =  \
+	mudsync/command.scm \
 	mudsync/game-master.scm \
 	mudsync/gameobj.scm \
 	mudsync/networking.scm \
diff --git a/mudsync.scm b/mudsync.scm
index 84cb6d0..31caf48 100644
--- a/mudsync.scm
+++ b/mudsync.scm
@@ -32,7 +32,7 @@
       '(game-master
         gameobj
         networking
-        parser
+        command
         player
         room
         run-game))
diff --git a/mudsync/command.scm b/mudsync/command.scm
new file mode 100644
index 0000000..28092fc
--- /dev/null
+++ b/mudsync/command.scm
@@ -0,0 +1,191 @@
+(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
+            indir-command
+            empty-command
+            direct-greedy-command
+            greedy-command
+            player-gather-command-handlers
+            find-command-winner))
+
+;;; Commands
+;;; ========
+
+(define %low-priority 0)
+(define %default-priority 1)
+(define %high-priority 2)
+
+(define-record-type <command>
+  (make-command verbs matcher should-handle action priority)
+  command?
+  (verbs command-verbs)
+  (matcher command-matcher)
+  (should-handle command-should-handle)
+  (action command-action)
+  (priority command-priority))
+
+
+(define (direct-command verbs action)
+  (make-command verbs
+                cmatch-direct-obj
+                ;; @@: Should we allow fancier matching than this?
+                ;;   Let the actor itself pass along this whole method?
+                (lambda* (goes-by #:key direct-obj)
+                  (member direct-obj goes-by))
+                action
+                %default-priority))
+
+(define* (indir-command verbs action #:optional prepositions)
+  (make-command verbs
+                cmatch-indir-obj
+                ;; @@: Should we allow fancier matching than this?
+                ;;   Let the actor itself pass along this whole method?
+                (lambda* (goes-by #:key direct-obj indir-obj preposition)
+                  (if prepositions
+                      (and
+                       (member indir-obj goes-by)
+                       (member preposition prepositions))
+                      (member indir-obj goes-by)))
+                action
+                %high-priority))
+
+(define (empty-command verbs action)
+  (make-command verbs
+                cmatch-empty
+                (const #t)
+                action
+                %low-priority))
+
+(define (greedy-command verbs action)
+  (make-command verbs
+                cmatch-greedy
+                (const #t)
+                action
+                %low-priority))
+
+(define (direct-greedy-command verbs action)
+  "greedy commands but which match the direct object"
+  (make-command verbs
+                cmatch-direct-obj-greedy
+                (lambda* (goes-by #:key direct-obj rest)
+                  (member direct-obj goes-by))
+                action
+                %low-priority))
+
+;; @@: We should probably ONLY allow these to go to users!
+(define* (custom-command verbs matcher should-handle action
+                         #: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/gameobj.scm b/mudsync/gameobj.scm
index 9651140..2c39706 100644
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -57,11 +57,10 @@
            #:init-value '())
 
   ;; Commands we can handle
-  (dirobj-commands #:init-value '())
-  (indirobj-commands #:init-value '())
+  (commands #:init-value '())
 
   ;; Commands we can handle by being something's container
-  (contain-commands #:init-value #f))
+  (contain-commands #:init-value '()))
 
 
 (define (gameobj-simple-name-f gameobj)
diff --git a/mudsync/parser.scm b/mudsync/parser.scm
index 3ad5b73..305f43d 100644
--- a/mudsync/parser.scm
+++ b/mudsync/parser.scm
@@ -19,28 +19,40 @@
 (define-module (mudsync parser)
   #:use-module (rx irregex)
   #:use-module (ice-9 match)
-  #:use-module (srfi srfi-9))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
 
+  #:export (match-to-kwargs
+            split-verb-and-rest
+            article preposition
+
+            cmatch-indir-obj
+            cmatch-direct-obj
+            cmatch-direct-obj-greedy
+            cmatch-empty
+            cmatch-greedy))
 
 (define (match-to-kwargs irx string)
   (let ((rx-match (irregex-match irx string)))
     (if rx-match
-        (map (match-lambda
-               ((match-part . idx)
-                (cons match-part
-                      (irregex-match-substring
-                       rx-match idx))))
-             (irregex-match-names rx-match))
+        (fold
+         (match-lambda*
+           (((match-part . idx) prev)
+            (cons (symbol->keyword match-part)
+                  (cons (irregex-match-substring
+                         rx-match idx)
+                        prev))))
+         '()
+         (irregex-match-names rx-match))
         #f)))
 
 (define (split-verb-and-rest string)
   (let* ((trimmed (string-trim-both string))
          (first-space (string-index trimmed #\space)))
     (if first-space
-        `((verb . ,(substring trimmed 0 first-space))
-          (rest . ,(substring trimmed (+ 1 first-space))))
-        `((verb . ,trimmed)
-          (rest . "")))))
+        (cons (substring trimmed 0 first-space)
+              (substring trimmed (+ 1 first-space)))
+        (cons trimmed ""))))
 
 ;; @@: Not currently used
 ;; Borrowed from irregex.scm
@@ -55,36 +67,42 @@
   (sre->irregex
    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
        (? (: ,article (+ space)))      ; possibly an article (ignored)
-       (=> direct-object (* any))      ; direct object (kept)
+       (=> direct-obj (* any))      ; direct object (kept)
        (+ space)
        (=> preposition ,preposition)   ; main preposition (kept)
        (+ space)
        (? (: ,article (+ space)))      ; possibly an article (ignored)
-       (=> indirect-object (+ any))))) ; indirect object (kept)
+       (=> indir-obj (+ any))))) ; indirect object (kept)
 
-(define (indirect-matcher phrase)
+(define (cmatch-indir-obj phrase)
   (match-to-kwargs indirect-irx phrase))
 
 (define direct-irx
   (sre->irregex
    `(: (? (: ,preposition (+ space)))  ; possibly a preposition (ignored)
        (? (: ,article (+ space)))     ; possibly an article (ignored)
-       (=> direct-object (* any)))))  ; direct object (kept)
+       (=> direct-obj (* any)))))  ; direct object (kept)
 
-(define (direct-matcher phrase)
+(define (cmatch-direct-obj phrase)
   (match-to-kwargs direct-irx phrase))
 
-(define say-example "say I really need to get going.")
-(define attack-sword-example "hit goblin with sword")
-(define attack-simple-example "hit goblin")
-(define put-book-on-desk "put the book on the desk")
+(define (cmatch-empty phrase)
+  (if (equal? (string-trim phrase) ")")
+      '()
+      #f))
 
-(define-record-type <command-handler>
-  (make-command-handler matcher should-handle action)
-  command-handler?
-  (matcher command-handler-matcher)
-  (should-handle command-handler-should-handle?)
-  (action command-handler-action))
+(define (cmatch-direct-obj-greedy phrase)
+  ;; Turns out this uses the same semantics as splitting verb/rest
+  (match (split-verb-and-rest string)
+    ((direct-obj . rest)
+     (list #:direct-obj direct-obj
+           #:rest rest))
+    (#f #f)))
 
-(define command-handler make-command-handler)
+(define (cmatch-greedy phrase)
+  `((line . ,phrase)))
 
+;; (define say-example "say I really need to get going.")
+;; (define attack-sword-example "hit goblin with sword")
+;; (define attack-simple-example "hit goblin")
+;; (define put-book-on-desk "put the book on the desk")
diff --git a/mudsync/player.scm b/mudsync/player.scm
index 340fa3d..fece716 100644
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -17,13 +17,17 @@
 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (mudsync player)
+  #:use-module (mudsync command)
   #:use-module (mudsync gameobj)
   #:use-module (mudsync game-master)
+  #:use-module (mudsync parser)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (ice-9 format)
   #:use-module (oop goops)
-  #:export (<player>))
+  #:use-module (srfi srfi-1)
+  #:export (<player>
+            player-self-commands))
 
 ;;; Players
 ;;; =======
@@ -58,6 +62,17 @@
 
 
 (define-mhandler (player-handle-input player message input)
+  (define split-input (split-verb-and-rest input))
+  (define input-verb (pk 'input-verb (car split-input)))
+  (define input-rest (pk 'input-rest (cdr split-input)))
+
+  (define command-candidates
+    (pk 'candidates
+        (player-gather-command-handlers player input-verb)))
+
+  (define winner
+    (pk 'winner (find-command-winner command-candidates input-rest)))
+
   (<- player (gameobj-gm player) 'write-home
       #:text
       (format #f "<~a>: ~s\n"
@@ -80,3 +95,6 @@
     (format #f "**~a**\n~a\n" room-name room-desc))
 
   (<- player (gameobj-gm player) 'write-home #:text message-text))
+
+
+