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)
10 #:export (direct-command
15 player-gather-command-handlers
21 (define %low-priority 0)
22 (define %default-priority 1)
23 (define %high-priority 2)
25 (define-record-type <command>
26 (make-command verbs matcher should-handle action priority)
29 (matcher command-matcher)
30 (should-handle command-should-handle)
31 (action command-action)
32 (priority command-priority))
35 (define (direct-command verbs action)
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))
45 (define* (indir-command verbs action #:optional prepositions)
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)
53 (member indir-obj goes-by)
54 (member preposition prepositions))
55 (member indir-obj goes-by)))
59 (define (empty-command verbs action)
66 (define (greedy-command verbs action)
73 (define (direct-greedy-command verbs action)
74 "greedy commands but which match the direct object"
76 cmatch-direct-obj-greedy
77 (lambda* (goes-by #:key direct-obj rest)
78 (member direct-obj goes-by))
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))
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)
97 (let ((result (gameobj-loc player)))
100 (throw 'player-has-no-location
101 "Player ~a has no location! How'd that happen?\n"
102 #:player-id (actor-id player)))))
104 ;; Ask the room for its commands
105 (define room-commands
106 ;; TODO: Map room id and sort
108 (<-wait player player-loc
109 'get-container-commands
113 ;; All the co-occupants of the room (not including ourself)
116 (lambda (x) (equal? x (actor-id player)))
118 (<-wait player player-loc 'get-occupants)
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
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
131 (lambda (co-occupant)
132 (let ((result (<-wait player co-occupant 'get-commands
135 (message-ref result 'commands)
136 (message-ref result 'goes-by)
140 ;; Append our own command handlers
142 ((@@ (mudsync player) player-self-commands) player))
144 ;; TODO: Append our inventory's relevant command handlers
146 ;; Now return a big ol sorted list of ((actor-id . command))
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
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)))
158 (define (sort-commands-multi-actors actors-and-commands)
162 (> (command-priority (cdr x))
163 (command-priority (cdr y))))))
166 (define-record-type <command-winner>
167 (make-command-winner action actor-id)
169 (action command-winner-action)
170 (actor-id command-winner-action-id))
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 '())
179 ((command actor-id actor-goes-by)
181 (let* ((matcher (command-matcher command))
182 (matched (matcher line)))
184 ;; Great, it matched, but does it also pass
186 (apply (command-should-handle command)
188 matched)) ; matched is kwargs if truthy