From 136ce3b725c83af0b7e8be632e943de6b07b65c5 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 3 May 2016 09:45:23 -0500 Subject: [PATCH] Many steps towards handling input (but not there yet...) --- Makefile.am | 1 + mudsync.scm | 2 +- mudsync/command.scm | 191 ++++++++++++++++++++++++++++++++++++++++++++ mudsync/gameobj.scm | 5 +- mudsync/parser.scm | 72 ++++++++++------- mudsync/player.scm | 20 ++++- 6 files changed, 259 insertions(+), 32 deletions(-) create mode 100644 mudsync/command.scm 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 + (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 + (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 - (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 . (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 ()) + #:use-module (srfi srfi-1) + #:export ( + 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)) + + + -- 2.31.1