mudsync/command.scm

   1 (define-module (mudsync command)
   2   #:use-module (mudsync parser)
   3   #:use-module (mudsync gameobj)
   4   #:use-module (8sync systems actors)
   5   #:use-module (srfi srfi-1)
   6   #:use-module (srfi srfi-9)
   7   #:use-module (ice-9 control)
   8   #:use-module (ice-9 match)
   9
  10   #:export (direct-command
  11             indir-command
  12             empty-command
  13             direct-greedy-command
  14             greedy-command
  15             player-gather-command-handlers
  16             find-command-winner))
  17
  18 ;;; Commands
  19 ;;; ========
  20
  21 (define %low-priority 0)
  22 (define %default-priority 1)
  23 (define %high-priority 2)
  24
  25 (define-record-type <command>
  26   (make-command verbs matcher should-handle action priority)
  27   command?
  28   (verbs command-verbs)
  29   (matcher command-matcher)
  30   (should-handle command-should-handle)
  31   (action command-action)
  32   (priority command-priority))
  33
  34
  35 (define (direct-command verbs action)
  36   (make-command verbs
  37                 cmatch-direct-obj
  38                 ;; @@: Should we allow fancier matching than this?
  39                 ;;   Let the actor itself pass along this whole method?
  40                 (lambda* (goes-by #:key direct-obj)
  41                   (member direct-obj goes-by))
  42                 action
  43                 %default-priority))
  44
  45 (define* (indir-command verbs action #:optional prepositions)
  46   (make-command verbs
  47                 cmatch-indir-obj
  48                 ;; @@: Should we allow fancier matching than this?
  49                 ;;   Let the actor itself pass along this whole method?
  50                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
  51                   (if prepositions
  52                       (and
  53                        (member indir-obj goes-by)
  54                        (member preposition prepositions))
  55                       (member indir-obj goes-by)))
  56                 action
  57                 %high-priority))
  58
  59 (define (empty-command verbs action)
  60   (make-command verbs
  61                 cmatch-empty
  62                 (const #t)
  63                 action
  64                 %low-priority))
  65
  66 (define (greedy-command verbs action)
  67   (make-command verbs
  68                 cmatch-greedy
  69                 (const #t)
  70                 action
  71                 %low-priority))
  72
  73 (define (direct-greedy-command verbs action)
  74   "greedy commands but which match the direct object"
  75   (make-command verbs
  76                 cmatch-direct-obj-greedy
  77                 (lambda* (goes-by #:key direct-obj rest)
  78                   (member direct-obj goes-by))
  79                 action
  80                 %low-priority))
  81
  82 ;; @@: We should probably ONLY allow these to go to users!
  83 (define* (custom-command verbs matcher should-handle action
  84                          #:optional (priority %default-priority))
  85   "Full-grained customizable command."
  86   (make-command verbs matcher should-handle action priority))
  87
  88
  89 ;;; Command handling
  90 ;;; ================
  91
  92 ;; @@: Hard to know whether this should be in player.scm or here...
  93 ;; @@: This could be more efficient as a stream...!?
  94 (define (player-gather-command-handlers player verb)
  95
  96   (define player-loc
  97     (let ((result (gameobj-loc player)))
  98       (if result
  99           result
 100           (throw 'player-has-no-location
 101                  "Player ~a has no location!  How'd that happen?\n"
 102                  #:player-id (actor-id player)))))
 103
 104   ;; Ask the room for its commands
 105   (define room-commands
 106     ;; TODO: Map room id and sort
 107     (message-ref
 108      (<-wait player player-loc
 109              'get-container-commands
 110              #:verb verb)
 111      'commands))
 112
 113   ;; All the co-occupants of the room (not including ourself)
 114   (define co-occupants
 115     (remove
 116      (lambda (x) (equal? x (actor-id player)))
 117      (message-ref
 118       (<-wait player player-loc 'get-occupants)
 119       'occupants)))
 120
 121   ;; @@: There's a race condition here if someone leaves the room
 122   ;;   during this, heh...
 123   ;;   I'm not sure it can be solved, but "lag" on the race can be
 124   ;;   reduced maybe?
 125
 126   ;; Get all the co-occupants' commands
 127   (define co-occupant-commands
 128     ;; TODO: Switch this to a fold.  Ignore a result if it
 129     ;;   returns false for in the command response
 130     (map
 131      (lambda (co-occupant)
 132        (let ((result (<-wait player co-occupant 'get-commands
 133                              #:verb verb)))
 134          (list
 135           (message-ref result 'commands)
 136           (message-ref result 'goes-by)
 137           co-occupant)))
 138      co-occupants))
 139
 140   ;; Append our own command handlers
 141   (define our-commands
 142     ((@@ (mudsync player) player-self-commands) player))
 143
 144   ;; TODO: Append our inventory's relevant command handlers
 145
 146   ;; Now return a big ol sorted list of ((actor-id . command))
 147   (append
 148    (sort-commands-append-actor room-commands
 149                                player-loc '()) ; room doesn't go by anything
 150    (sort-commands-multi-actors co-occupant-commands)
 151    (sort-commands-append-actor our-commands
 152                                (actor-id player) '()))) ; nor does player
 153
 154 (define (sort-commands-append-actor commands actor-id goes-by)
 155   (sort-commands-multi-actors
 156    (map (lambda (command) (list command actor-id)) commands)))
 157
 158 (define (sort-commands-multi-actors actors-and-commands)
 159   (sort
 160    actors-and-commands
 161    (lambda (x y)
 162      (> (command-priority (cdr x))
 163         (command-priority (cdr y))))))
 164
 165
 166 (define-record-type <command-winner>
 167   (make-command-winner action actor-id)
 168   command-winner?
 169   (action command-winner-action)
 170   (actor-id command-winner-action-id))
 171
 172
 173 (define (find-command-winner sorted-candidates line)
 174   "Find a command winner from a sorted list of candidates"
 175   ;; A cache of results from matchers we've already seen
 176   (define matcher-cache '())
 177   (find
 178    (match-lambda
 179      ((command actor-id actor-goes-by)
 180
 181       (let* ((matcher (command-matcher command))
 182              (matched (matcher line)))
 183         (if (and matched
 184                  ;; Great, it matched, but does it also pass
 185                  ;; should-handle?
 186                  (apply (command-should-handle command)
 187                         actor-goes-by
 188                         matched))  ; matched is kwargs if truthy
 189             actor-id
 190             #f))))
 191    sorted-candidates))