mudsync/command.scm

   1 (define-module (mudsync command)
   2   #:use-module (mudsync parser)
   3   #:use-module (8sync systems actors)
   4   #:use-module (srfi srfi-1)
   5   #:use-module (srfi srfi-9)
   6   #:use-module (ice-9 control)
   7   #:use-module (ice-9 match)
   8
   9   #:export (command?
  10             command-verbs
  11             command-matcher
  12             command-should-handle
  13             command-action
  14             command-priority
  15
  16             direct-command
  17             indir-command
  18             loose-direct-command
  19             loose-indir-command
  20             empty-command
  21             direct-greedy-command
  22             greedy-command
  23             player-gather-command-handlers
  24             find-command-winner))
  25
  26 ;;; Commands
  27 ;;; ========
  28
  29 (define %low-priority 0)
  30 (define %default-priority 1)
  31 (define %high-priority 2)
  32
  33 ;; ;;; Avoiding some annoying issues crossing the continuation barrier
  34 ;; ;;; and the "@@" special form
  35 ;; (define (make-command verbs matcher should-handle action priority)
  36 ;;   (list '*command* verbs matcher should-handle action priority))
  37
  38 ;; (define command-verbs second)
  39 ;; (define command-matcher third)
  40 ;; (define command-should-handle fourth)
  41 ;; (define command-action fifth)
  42 ;; (define command-priority sixth)
  43
  44 (define-record-type <command>
  45   (make-command verbs matcher should-handle action priority)
  46   command?
  47   (verbs command-verbs)
  48   (matcher command-matcher)
  49   (should-handle command-should-handle)
  50   (action command-action)
  51   (priority command-priority))
  52
  53
  54 (define (direct-command verbs action)
  55   (make-command verbs
  56                 cmatch-direct-obj
  57                 ;; @@: Should we allow fancier matching than this?
  58                 ;;   Let the actor itself pass along this whole method?
  59                 (lambda* (goes-by #:key direct-obj)
  60                   (member direct-obj goes-by))
  61                 action
  62                 %default-priority))
  63
  64 (define (loose-direct-command verbs action)
  65   (make-command verbs
  66                 cmatch-direct-obj
  67                 ;; @@: Should we allow fancier matching than this?
  68                 ;;   Let the actor itself pass along this whole method?
  69                 (const #t)
  70                 action
  71                 %default-priority))
  72
  73
  74 (define* (indir-command verbs action #:optional prepositions)
  75   (make-command verbs
  76                 cmatch-indir-obj
  77                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
  78                   (if prepositions
  79                       (and
  80                        (member indir-obj goes-by)
  81                        (member preposition prepositions))
  82                       (member indir-obj goes-by)))
  83                 action
  84                 %high-priority))
  85
  86 (define* (loose-indir-command verbs action #:optional prepositions)
  87   (make-command verbs
  88                 cmatch-indir-obj
  89                 (const #t)
  90                 action
  91                 %high-priority))
  92
  93
  94 (define (empty-command verbs action)
  95   (make-command verbs
  96                 cmatch-empty
  97                 (const #t)
  98                 action
  99                 %low-priority))
 100
 101 (define (greedy-command verbs action)
 102   (make-command verbs
 103                 cmatch-greedy
 104                 (const #t)
 105                 action
 106                 %low-priority))
 107
 108 (define (direct-greedy-command verbs action)
 109   "greedy commands but which match the direct object"
 110   (make-command verbs
 111                 cmatch-direct-obj-greedy
 112                 (lambda* (goes-by #:key direct-obj rest)
 113                   (member direct-obj goes-by))
 114                 action
 115                 %low-priority))
 116
 117 ;; @@: We should probably ONLY allow these to go to users!
 118 (define* (custom-command verbs matcher should-handle action
 119                          #:optional (priority %default-priority))
 120   "Full-grained customizable command."
 121   (make-command verbs matcher should-handle action priority))