X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fcommand.scm;h=c8cf3624e3b24c5d9e63d5401551cd1b70e0b2b4;hp=28092fcf43cf0f7b1939ba0910a411c6c3ae1ba5;hb=72bb4674c8058ada141da9f62a866e06381a8228;hpb=136ce3b725c83af0b7e8be632e943de6b07b65c5 diff --git a/mudsync/command.scm b/mudsync/command.scm index 28092fc..c8cf362 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -1,14 +1,45 @@ +;;; 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 (mudsync utils) + #:use-module (8sync actors) + #:use-module (8sync rmeta-slot) #: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 + + build-commands + + direct-command + prep-indir-command + prep-direct-command + loose-direct-command + loose-prep-command empty-command direct-greedy-command greedy-command @@ -22,170 +53,140 @@ (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) + (make-command verbs matcher should-handle action priority obvious?) command? (verbs command-verbs) (matcher command-matcher) (should-handle command-should-handle) (action command-action) - (priority command-priority)) - - -(define (direct-command verbs action) + (priority command-priority) + (obvious? command-obvious?)) + +(define-syntax %build-command + (syntax-rules () + ((_ (verb ...) ((cmd-proc action-sym args ...) ...)) + (list (cons verb + (list (cmd-proc (list verb ...) + (quote action-sym) + args ...) + ...)) + ...)) + ((_ verb ((cmd-proc action-sym args ...) ...)) + (list (cons verb + (list (cmd-proc (list verb) + (quote action-sym) + args ...) + ...)))))) + +(define-syntax-rule (build-commands (verb-or-verbs cmd-defs ...) ...) + (wrap-rmeta-slot + (append (%build-command verb-or-verbs cmd-defs ...) ...))) + + +(define* (direct-command verbs action #:key (obvious? #t)) (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)) + (ci-member direct-obj goes-by)) action - %default-priority)) + %default-priority + obvious?)) -(define* (indir-command verbs action #:optional prepositions) +(define* (loose-direct-command verbs action #:key (obvious? #t)) (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 + obvious?)) + + +(define* (prep-indir-command verbs action #:optional prepositions + #:key (obvious? #t)) + (make-command verbs + cmatch-indir-obj + (lambda* (goes-by #:key direct-obj indir-obj preposition) + (if prepositions + (and + (ci-member indir-obj goes-by) + (ci-member preposition prepositions)) + (ci-member indir-obj goes-by))) + action + %high-priority + obvious?)) + +(define* (prep-direct-command verbs action #:optional prepositions + #:key (obvious? #t)) + (make-command verbs + cmatch-indir-obj (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))) + (ci-member direct-obj goes-by) + (ci-member preposition prepositions)) + (ci-member direct-obj goes-by))) action - %high-priority)) + %high-priority + obvious?)) + +(define* (loose-prep-command verbs action #:optional prepositions + #:key (obvious? #t)) + (make-command verbs + cmatch-indir-obj + (const #t) + action + %high-priority + obvious?)) + -(define (empty-command verbs action) +(define* (empty-command verbs action + #:key (obvious? #t)) (make-command verbs cmatch-empty (const #t) action - %low-priority)) + %low-priority + obvious?)) -(define (greedy-command verbs action) +(define* (greedy-command verbs action + #:key (obvious? #t)) (make-command verbs cmatch-greedy (const #t) action - %low-priority)) + %low-priority + obvious?)) -(define (direct-greedy-command verbs action) +(define* (direct-greedy-command verbs action + #:key (obvious? #t)) "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)) + (ci-member direct-obj goes-by)) action - %low-priority)) + %low-priority + obvious?)) ;; @@: We should probably ONLY allow these to go to users! (define* (custom-command verbs matcher should-handle action - #:optional (priority %default-priority)) + #:optional (priority %default-priority) + #:key (obvious? #t)) "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)) + (make-command verbs matcher should-handle action priority obvious?))