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 ;; @@: We really need to unify / make sensible this look stuff
44 (look-room (wrap-apply player-look-room))))
46 (define player-actions*
47 (append player-actions
50 (define player-dispatcher
51 (simple-dispatcher player-actions*))
53 (define-class <player> (<gameobj>)
54 (username #:init-keyword #:username
55 #:accessor player-username)
57 (client #:accessor player-client)
61 #:accessor player-self-commands)
65 ;; @@: We're gonna need action inheritance real awful soon, huh?
66 (wrap-apply player-dispatcher)))
69 ;;; player message handlers
71 (define-mhandler (player-init! player message)
72 (player-look-around player))
75 (define-mhandler (player-handle-input player message input)
76 (define split-input (split-verb-and-rest input))
77 (define input-verb (pk 'input-verb (car split-input)))
78 (define input-rest (pk 'input-rest (cdr split-input)))
80 (define command-candidates
82 (player-gather-command-handlers player input-verb)))
85 (pk 'winner (find-command-winner command-candidates input-rest)))
88 ((cmd-action winner-id message-args)
89 (apply send-message player (pk 'winner-id winner-id) (pk 'cmd-action cmd-action) (pk 'message-args message-args)))
91 (<- player (gameobj-gm player) 'write-home
94 (define-mhandler (player-tell player message text)
95 (<- player (gameobj-gm player) 'write-home
98 (define-mhandler (player-look-room player message)
99 (player-look-around player))
104 (define (player-look-around player)
107 (<-wait player (gameobj-loc player) 'get-name)
111 (<-wait player (gameobj-loc player) 'get-desc)
114 (format #f "**~a**\n~a\n" room-name room-desc))
116 (<- player (gameobj-gm player) 'write-home #:text message-text))
122 ;; @@: Hard to know whether this should be in player.scm or here...
123 ;; @@: This could be more efficient as a stream...!?
124 (define (player-gather-command-handlers player verb)
126 (let ((result (gameobj-loc player)))
129 (throw 'player-has-no-location
130 "Player ~a has no location! How'd that happen?\n"
131 #:player-id (actor-id player)))))
133 ;; Ask the room for its commands
134 (define room-commands
135 ;; TODO: Map room id and sort
137 (<-wait player player-loc
138 'get-container-commands
142 ;; All the co-occupants of the room (not including ourself)
145 (lambda (x) (equal? x (actor-id player)))
147 (<-wait player player-loc 'get-occupants)
150 ;; @@: There's a race condition here if someone leaves the room
151 ;; during this, heh...
152 ;; I'm not sure it can be solved, but "lag" on the race can be
155 ;; Get all the co-occupants' commands
156 (define co-occupant-commands
157 ;; TODO: Switch this to a fold. Ignore a result if it
158 ;; returns false for in the command response
160 (lambda (co-occupant)
161 (let ((result (<-wait player co-occupant 'get-commands
164 (message-ref result 'commands)
165 (message-ref result 'goes-by)
169 ;; Append our own command handlers
171 (player-self-commands player))
173 ;; TODO: Append our inventory's relevant command handlers
175 ;; Now return a big ol sorted list of ((actor-id . command))
177 (sort-commands-append-actor (pk 'room-commands room-commands)
178 player-loc '()) ; room doesn't go by anything
179 (sort-commands-multi-actors co-occupant-commands)
180 (sort-commands-append-actor our-commands
181 (actor-id player) '()))) ; nor does player
183 (define (sort-commands-append-actor commands actor-id goes-by)
184 (sort-commands-multi-actors
185 (map (lambda (command) (list command goes-by actor-id)) commands)))
187 (define (sort-commands-multi-actors actors-and-commands)
191 (> (command-priority (car (pk 'x x)))
192 (command-priority (car (pk 'y y)))))))
195 (define (find-command-winner sorted-candidates line)
196 "Find a command winner from a sorted list of candidates"
197 ;; A cache of results from matchers we've already seen
198 ;; TODO: fill this in
199 (define matcher-cache '())
204 ((command actor-goes-by actor-id)
205 (let* ((matcher (command-matcher command))
206 (matched (matcher line)))
208 ;; Great, it matched, but does it also pass
210 (apply (command-should-handle command)
212 matched)) ; matched is kwargs if truthy
213 (return (list (command-action command)
214 (pk 'earlier-actor-id actor-id) matched))