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 actors)
25 #:use-module (8sync agenda)
26 #:use-module (8sync rmeta-slot)
27 #:use-module (ice-9 control)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 match)
30 #:use-module (oop goops)
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-9)
38 (define-class <player> (<gameobj>)
39 (username #:init-keyword #:username
40 #:getter player-username)
42 (self-commands #:allocation #:each-subclass
45 (("inventory" "inv" "i") ((empty-command cmd-inventory)))
46 ("help" ((empty-command cmd-help)))))
48 (actions #:allocation #:each-subclass
52 (handle-input player-handle-input)
54 (disconnect-self-destruct player-disconnect-self-destruct)
55 (cmd-inventory player-cmd-inventory)
56 (cmd-help player-cmd-help))))
59 ;;; player message handlers
61 (define (player-init player message)
62 ;; Look around the room we're in
63 (<- (gameobj-loc player) 'look-room))
66 (define* (player-handle-input player message #:key input)
67 (define split-input (split-verb-and-rest input))
68 (define input-verb (car split-input))
69 (define input-rest (cdr split-input))
71 (define command-candidates
72 (player-gather-command-handlers player input-verb))
75 (find-command-winner command-candidates input-rest))
78 ((cmd-action winner-id message-args)
79 (apply <- winner-id cmd-action message-args))
81 (<- (gameobj-gm player) 'write-home
82 #:text "Sorry, I didn't understand that? (type \"help\" for common commands)\n"))))
84 (define* (player-tell player message #:key text)
85 (<- (gameobj-gm player) 'write-home
88 (define (player-disconnect-self-destruct player message)
89 "Action routine for being told to disconnect and self destruct."
90 (define loc (gameobj-loc player))
93 #:exclude (actor-id player)
94 #:text (format #f "~a disappears in a puff of entropy!\n"
95 (slot-ref player 'name))))
96 (gameobj-self-destruct player))
98 (define (player-cmd-inventory player message)
99 "Display the inventory for the player"
103 (mbody-val (<-wait inv-item 'get-name)))
104 (gameobj-occupants player)))
106 (if (eq? inv-names '())
107 "You aren't carrying anything.\n"
108 `((p "You are carrying:")
109 (ul ,(map (lambda (item-name)
112 (<- (actor-id player) 'tell #:text text-to-show))
114 (define (player-cmd-help player message)
115 (<- (actor-id player) 'tell
116 #:text '((strong "** Mudsync Help **")(br)
117 (p "You're playing Mudsync, a multiplayer text-adventure. "
118 "Type different commands to interact with your surroundings "
119 "and other players.")
120 (p "Some common commands:"
121 (ul (li (strong "say <message>") " -- "
122 "Chat with other players in the same room. "
123 "(Also aliased to the " (b "\"") " character.)")
124 (li (strong "look") " -- "
125 "Look around the room you're in.")
126 (li (strong "look [at] <object>") " -- "
127 "Examine a particular object.")
128 (li (strong "go <exit>") " -- "
129 "Move to another room in <exit> direction.")))
130 (p "Different objects can be interacted with in different ways. "
131 "For example, if there's a bell in the same room as you, "
132 "you might try typing " (em "ring bell")
133 " and see what happens."))))
139 ;; @@: Hard to know whether this should be in player.scm or here...
140 ;; @@: This could be more efficient as a stream...!?
141 (define (player-gather-command-handlers player verb)
143 (let ((result (gameobj-loc player)))
146 (throw 'player-has-no-location
147 "Player ~a has no location! How'd that happen?\n"
148 #:player-id (actor-id player)))))
150 ;; Ask the room for its commands
151 (define room-dom-commands
152 ;; TODO: Map room id and sort
153 (mbody-receive (_ #:key commands)
154 (<-wait player-loc 'get-container-dom-commands
158 (define room-sub-commands
159 ;; TODO: Map room id and sort
160 (mbody-receive (_ #:key commands)
161 (<-wait player-loc 'get-container-sub-commands
165 ;; All the co-occupants of the room (not including ourself)
168 (lambda (x) (equal? x (actor-id player)))
169 (mbody-val (<-wait player-loc 'get-occupants))))
171 ;; @@: There's a race condition here if someone leaves the room
172 ;; during this, heh...
173 ;; I'm not sure it can be solved, but "lag" on the race can be
176 ;; Get all the co-occupants' commands
177 (define co-occupant-commands
179 (lambda (co-occupant prev)
180 (mbody-receive (_ #:key commands goes-by)
181 (<-wait co-occupant 'get-commands
184 (map (lambda (command)
185 (list command goes-by co-occupant))
191 ;; Append our own command handlers
193 (class-rmeta-ref (class-of player) 'self-commands verb
196 ;; Append our inventory's relevant command handlers
198 (gameobj-occupants player))
199 (define inv-item-commands
201 (lambda (inv-item prev)
202 (mbody-receive (_ #:key commands goes-by)
203 (<-wait inv-item 'get-contained-commands
206 (map (lambda (command)
207 (list command goes-by inv-item))
213 ;; Now return a big ol sorted list of ((actor-id . command))
215 (sort-commands-append-actor room-dom-commands
216 player-loc '()) ; room doesn't go by anything
217 (sort-commands-multi-actors co-occupant-commands)
218 (sort-commands-append-actor our-commands
219 (actor-id player) '()) ; nor does player
220 (sort-commands-multi-actors inv-item-commands)
221 (sort-commands-append-actor room-sub-commands
224 (define (sort-commands-append-actor commands actor-id goes-by)
225 (sort-commands-multi-actors
226 (map (lambda (command) (list command goes-by actor-id)) commands)))
228 (define (sort-commands-multi-actors actors-and-commands)
232 (> (command-priority (car x))
233 (command-priority (car y))))))
236 (define (find-command-winner sorted-candidates line)
237 "Find a command winner from a sorted list of candidates"
238 ;; A cache of results from matchers we've already seen
239 ;; TODO: fill in this cache. This is a *critical* optimization!
240 (define matcher-cache '())
245 ((command actor-goes-by actor-id)
246 (let* ((matcher (command-matcher command))
247 (matched (matcher line)))
249 ;; Great, it matched, but does it also pass
251 (apply (command-should-handle command)
253 matched)) ; matched is kwargs if truthy
254 (return (list (command-action command)