commands finally dispatch
[mudsync.git] / mudsync / game-master.scm
1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
3 ;;;
4 ;;; This file is part of Mudsync.
5 ;;;
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.
10 ;;;
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.
15 ;;;
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/>.
18
19 (define-module (mudsync game-master)
20   #:use-module (mudsync networking)
21   #:use-module (8sync systems actors)
22   #:use-module (8sync agenda)
23   #:use-module (oop goops)
24   #:use-module (ice-9 match)
25   #:export (<game-master>
26             make-default-room-conn-handler))
27
28 ;;; The game master!  Runs the world.
29 ;;; =================================
30
31 (define-class <game-master> (<actor>)
32   ;; Directory of "special" objects.
33   (special-dir #:init-thunk make-hash-table
34                #:getter gm-special-dir)
35
36   ;; Room directory.  Room symbols to locations.
37   (room-dir #:init-thunk make-hash-table
38             #:getter gm-room-dir)
39
40   ;; A mapping of client ids to in-game actors
41   ;; and a reverse ;p
42   (client-dir #:init-thunk make-hash-table
43               #:getter gm-client-dir)
44   (reverse-client-dir #:init-thunk make-hash-table
45                       #:getter gm-reverse-client-dir)
46
47   ;; Network manager
48   (network-manager #:accessor gm-network-manager
49                    #:init-value #f)
50
51   ;; How we get a new connection acclimated to the system
52   (new-conn-handler #:accessor gm-new-conn-handler
53                     #:init-keyword #:new-conn-handler)
54
55   (message-handler
56    #:init-value
57    (make-action-dispatch
58     (init-world (wrap-apply gm-init-world))
59     (client-input (wrap-apply gm-handle-client-input))
60     (lookup-room (wrap-apply gm-lookup-room))
61     (new-client (wrap-apply gm-new-client))
62     (write-home (wrap-apply gm-write-home)))))
63
64
65 ;;; .. begin world init stuff ..
66
67 (define (gm-init-world gm message)
68   ;; Load database
69   ;;  TODO
70
71   ;; Init basic rooms / structure
72   (gm-init-rooms gm (message-ref message 'room-spec))
73
74   ;; Restore database-based actors
75   ;;  TODO
76
77   ;; Set up the network
78   (gm-setup-network gm))
79
80 (define (gm-init-rooms gm rooms-spec)
81   "Initialize the prebuilt rooms"
82   ;; @@: Would it be nicer to just allow passing in
83   ;;     #:exits to the room spec itself?
84   (define (exit-from-spec exit-spec)
85     "Take room exits syntax from the spec, turn it into exits"
86     (match exit-spec
87       ((name to-symbol desc)
88        (make (@@ (mudsync room) <exit>)
89          #:name name
90          #:to-symbol to-symbol
91          #:desc desc))))
92
93   (define rooms
94     (map
95      (match-lambda
96        ((room-symbol room-class
97                      room-args ...
98                      (room-exits ...))
99         ;; initialize the room
100         (let ((room
101                (apply create-actor* gm room-class "room"
102                       #:gm (actor-id gm)
103                       #:exits (map exit-from-spec room-exits)
104                       room-args)))
105           ;; register the room
106           (hash-set! (gm-room-dir gm) room-symbol room)
107           ;; pass it back to the map
108           room)))
109      rooms-spec))
110
111   ;; now wire up all the exits
112   (for-each
113    (lambda (room)
114      (format #t "Wiring up ~s...\n" (address->string room))
115      (<-wait gm room 'wire-exits!))
116    rooms))
117
118
119 (define (gm-setup-network gm)
120   ;; Create a default network manager if none available
121   (set! (gm-network-manager gm)
122         (create-actor* gm <network-manager> "netman"
123                        #:send-input-to (actor-id gm)))
124
125   ;; TODO: Add host and port options
126   (<-wait gm (gm-network-manager gm) 'start-listening))
127
128 (define (gm-setup-database gm)
129   'TODO)
130
131 ;;; .. end world init stuff ...
132
133 (define-mhandler (gm-new-client actor message client)
134   ;; @@: Maybe more indirection than needed for this
135   ((gm-new-conn-handler actor) actor client))
136
137
138 (define (gm-handle-client-input actor message)
139   "Handle input from a client."
140   (define client-id (message-ref message 'client))
141   (define input (message-ref message 'data))
142   ;; Look up player
143   (define player (hash-ref (gm-client-dir actor) client-id))
144
145   ;; debugging
146   (format #t "DEBUG: From ~s: ~s\n" client-id input)
147
148   (<- actor player 'handle-input
149       #:input input))
150
151 (define-mhandler (gm-lookup-room actor message symbol)
152   (define room-id
153     (slot-ref (gm-room-dir actor) symbol))
154   (<-reply actor message room-id))
155
156 (define-mhandler (gm-write-home actor message text)
157   (define client-id (hash-ref (gm-reverse-client-dir actor)
158                               (message-from message)))
159   (<- actor (gm-network-manager actor) 'send-to-client
160       #:client client-id
161       #:data text))
162
163
164 ;;; GM utilities
165
166 (define (gm-register-client! gm client-id player)
167   (hash-set! (gm-client-dir gm) client-id player)
168   (hash-set! (gm-reverse-client-dir gm) player client-id))
169
170 (define (gm-unregister-client! gm client-id)
171   "Remove a connection/player combo and ask them to self destruct"
172   (match (hash-remove! (gm-client-dir gm) client-id)  ; Remove from our client dir
173     ((_ . player-id)
174      ;; Remove from reverse table too
175      (hash-remove! (gm-reverse-client-dir gm) client-id)
176      ;; Destroy player 
177      (<- gm player-id 'destroy-self))
178     (#f (throw 'no-client-to-unregister
179                "Can't unregister a client that doesn't exist?"
180                client-id))))
181
182 ;;; An easy default
183
184 (define (make-default-room-conn-handler default-room)
185   "Make a handler for a GM that dumps people in a default room
186 with an anonymous persona"
187   (let ((count 0))
188     (lambda (gm client-id)
189       (set! count (+ count 1))
190       (let* ((guest-name (string-append "Guest-"
191                                         (number->string count)))
192              (room-id
193               (hash-ref (gm-room-dir gm) default-room))
194              ;; create and register the player
195              (player
196               (create-actor* gm (@@ (mudsync player) <player>) "player"
197                              #:username guest-name
198                              #:gm (actor-id gm)
199                              #:client client-id)))
200         ;; Register the player in our database of players -> connections
201         (gm-register-client! gm client-id player)
202         ;; Dump the player into the default room
203         (<-wait gm player 'set-loc! #:loc room-id)
204         ;; Initialize the player
205         (<- gm player 'init)))))
206