mudsync/mudsync/command.scm

;;; 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 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 (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
            player-gather-command-handlers
            find-command-winner))

;;; Commands
;;; ========

(define %low-priority 0)
(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 obvious?)
  command?
  (verbs command-verbs)
  (matcher command-matcher)
  (should-handle command-should-handle)
  (action command-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 ...) ...)
  (build-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)
                  (ci-member direct-obj goes-by))
                action
                %default-priority
                obvious?))

(define* (loose-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?
                (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
                       (ci-member  direct-obj goes-by)
                       (ci-member preposition prepositions))
                      (ci-member direct-obj goes-by)))
                action
                %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
                        #:key (obvious? #t))
  (make-command verbs
                cmatch-empty
                (const #t)
                action
                %low-priority
                obvious?))

(define* (greedy-command verbs action
                         #:key (obvious? #t))
  (make-command verbs
                cmatch-greedy
                (const #t)
                action
                %low-priority
                obvious?))

(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)
                  (ci-member direct-obj goes-by))
                action
                %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)
                         #:key (obvious? #t))
  "Full-grained customizable command."
  (make-command verbs matcher should-handle action priority obvious?))