1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of Mudsync.
6 ;;; Mudsync is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or
9 ;;; (at your option) any later version.
11 ;;; Mudsync is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (mudsync player)
20 #:use-module (mudsync command)
21 #:use-module (mudsync gameobj)
22 #:use-module (mudsync game-master)
23 #:use-module (mudsync parser)
24 #:use-module (8sync systems actors)
25 #:use-module (8sync agenda)
26 #:use-module (ice-9 control)
27 #:use-module (ice-9 format)
28 #:use-module (ice-9 match)
29 #:use-module (oop goops)
30 #:use-module (srfi srfi-1)
31 #:use-module (srfi srfi-9)
33 player-self-commands))
38 (define player-actions
40 (init (wrap-apply player-init))
41 (handle-input (wrap-apply player-handle-input))
42 (tell (wrap-apply player-tell))
43 (disconnect-self-destruct (wrap-apply player-disconnect-self-destruct))
44 (cmd-inventory (wrap-apply player-cmd-inventory))))
46 (define player-actions*
47 (append player-actions
50 (define player-dispatcher
51 (simple-dispatcher player-actions*))
53 (define player-self-commands
55 (empty-command "inventory" 'cmd-inventory)
57 ;; @@: Should use an "alias" system for common aliases?
58 (empty-command "inv" 'cmd-inventory)
59 (empty-command "i" 'cmd-inventory)))
61 (define-class <player> (<gameobj>)
62 (username #:init-keyword #:username
63 #:getter player-username)
65 (self-commands #:init-value player-self-commands)
69 (wrap-apply player-dispatcher)))
72 ;;; player message handlers
74 (define-mhandler (player-init player message)
75 ;; Look around the room we're in
76 (<- player (gameobj-loc player) 'look-room))
79 (define-mhandler (player-handle-input player message input)
80 (define split-input (split-verb-and-rest input))
81 (define input-verb (car split-input))
82 (define input-rest (cdr split-input))
84 (define command-candidates
85 (player-gather-command-handlers player input-verb))
88 (find-command-winner command-candidates input-rest))
91 ((cmd-action winner-id message-args)
92 (apply send-message player winner-id cmd-action message-args))
94 (<- player (gameobj-gm player) 'write-home
97 (define-mhandler (player-tell player message text)
98 (<- player (gameobj-gm player) 'write-home
101 (define-mhandler (player-disconnect-self-destruct player message)
102 "Action routine for being told to disconnect and self destruct."
103 (define loc (gameobj-loc player))
105 (<- player loc 'tell-room
106 #:exclude (actor-id player)
107 #:text (format #f "~a disappears in a puff of entropy!\n"
108 (slot-ref player 'name))))
109 (gameobj-self-destruct player))
111 (define-mhandler (player-cmd-inventory player message)
112 "Display the inventory for the player"
116 (message-ref (<-wait player inv-item 'get-name)
118 (gameobj-occupants player)))
120 (if (eq? inv-names '())
121 "You aren't carrying anything.\n"
123 "You are carrying:\n"
124 (map (lambda (item-name)
125 (string-append " * " item-name "\n"))
127 (<- player (actor-id player) 'tell #:text text-to-show))
133 ;; @@: Hard to know whether this should be in player.scm or here...
134 ;; @@: This could be more efficient as a stream...!?
135 (define (player-gather-command-handlers player verb)
137 (let ((result (gameobj-loc player)))
140 (throw 'player-has-no-location
141 "Player ~a has no location! How'd that happen?\n"
142 #:player-id (actor-id player)))))
144 ;; Ask the room for its commands
145 (define room-commands
146 ;; TODO: Map room id and sort
148 (<-wait player player-loc
149 'get-container-commands
153 ;; All the co-occupants of the room (not including ourself)
156 (lambda (x) (equal? x (actor-id player)))
158 (<-wait player player-loc 'get-occupants)
161 ;; @@: There's a race condition here if someone leaves the room
162 ;; during this, heh...
163 ;; I'm not sure it can be solved, but "lag" on the race can be
166 ;; Get all the co-occupants' commands
167 (define co-occupant-commands
169 (lambda (co-occupant prev)
170 (let* ((result (<-wait player co-occupant 'get-commands
172 (commands (message-ref result 'commands))
173 (goes-by (message-ref result 'goes-by)))
175 (map (lambda (command)
176 (list command goes-by co-occupant))
182 ;; Append our own command handlers
186 (equal? (command-verbs cmd) verb))
188 (slot-ref player 'self-commands))))
190 ;; Append our inventory's relevant command handlers
192 (gameobj-occupants player))
193 (define inv-item-commands
195 (lambda (inv-item prev)
196 (let* ((result (<-wait player inv-item
197 'get-contained-commands
199 (commands (message-ref result 'commands))
200 (goes-by (message-ref result 'goes-by)))
202 (map (lambda (command)
203 (list command goes-by inv-item))
209 ;; Now return a big ol sorted list of ((actor-id . command))
211 (sort-commands-append-actor room-commands
212 player-loc '()) ; room doesn't go by anything
213 (sort-commands-multi-actors co-occupant-commands)
214 (sort-commands-append-actor our-commands
215 (actor-id player) '()) ; nor does player
216 (sort-commands-multi-actors inv-item-commands)))
218 (define (sort-commands-append-actor commands actor-id goes-by)
219 (sort-commands-multi-actors
220 (map (lambda (command) (list command goes-by actor-id)) commands)))
222 (define (sort-commands-multi-actors actors-and-commands)
226 (> (command-priority (car x))
227 (command-priority (car y))))))
230 (define (find-command-winner sorted-candidates line)
231 "Find a command winner from a sorted list of candidates"
232 ;; A cache of results from matchers we've already seen
233 ;; TODO: fill in this cache. This is a *critical* optimization!
234 (define matcher-cache '())
239 ((command actor-goes-by actor-id)
240 (let* ((matcher (command-matcher command))
241 (matched (matcher line)))
243 ;; Great, it matched, but does it also pass
245 (apply (command-should-handle command)
247 matched)) ; matched is kwargs if truthy
248 (return (list (command-action command)