X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fcommand.scm;h=765962ce28dcd88defa2efbfe814f029bb5440c9;hp=28092fcf43cf0f7b1939ba0910a411c6c3ae1ba5;hb=6f7c1d4f9a2043c16f83facef6b3216e45e14f40;hpb=136ce3b725c83af0b7e8be632e943de6b07b65c5 diff --git a/mudsync/command.scm b/mudsync/command.scm index 28092fc..765962c 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -1,14 +1,41 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 Christopher Allan Webber +;;; +;;; This file is part of Mudsync. +;;; +;;; Mudsync is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Mudsync is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mudsync. If not, see . + (define-module (mudsync command) #:use-module (mudsync parser) - #:use-module (mudsync gameobj) - #:use-module (8sync systems actors) + #:use-module (8sync 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 + #:export (command? + command-verbs + command-matcher + command-should-handle + command-action + command-priority + + direct-command + prep-indir-command + prep-direct-command + loose-direct-command + loose-prep-command empty-command direct-greedy-command greedy-command @@ -22,6 +49,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 +80,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* (prep-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 +102,26 @@ action %high-priority)) +(define* (prep-direct-command verbs action #:optional prepositions) + (make-command verbs + cmatch-indir-obj + (lambda* (goes-by #:key direct-obj indir-obj preposition) + (if prepositions + (and + (member direct-obj goes-by) + (member preposition prepositions)) + (member direct-obj goes-by))) + action + %high-priority)) + +(define* (loose-prep-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 +150,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))