+;;; Mudsync --- Live hackable MUD
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
(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
+ indir-as-direct-command
+ loose-direct-command
+ loose-indir-command
empty-command
direct-greedy-command
greedy-command
(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 <command>
(make-command verbs matcher should-handle action priority)
command?
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
action
%high-priority))
+(define* (indir-as-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-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
#: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))
projects / mudsync.git / blobdiff