mudsync.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)
  20   #:use-module (8sync systems actors)
  21   #:use-module (8sync agenda)
  22   #:use-module (ice-9 format)
  23   #:use-module (ice-9 match)
  24   #:use-module (oop goops))
  25
  26 \f
  27 ; (ez-run-hive hive (list (bootstrap-message hive (actor-id nm) 'start-listening)))
  28
  29
  30 ;; (define-method (nm-close-port (nm <network-manager>)))
  31
  32
  33 \f
  34 ;;; The game master!  Runs the world.
  35 ;;; =================================
  36
  37 ;; @@: We could call this a "world builder" instead...
  38 ;;   I kinda like calling it a GM though.
  39
  40 (define-class <game-master> (<actor>)
  41   ;; Directory of "special" objects.
  42   (special-dir #:init-thunk make-hash-table
  43                #:getter gm-special-dir)
  44
  45   ;; Room directory.  Room symbols to locations.
  46   (room-dir #:init-thunk make-hash-table
  47             #:getter gm-room-dir)
  48
  49   ;; A mapping of client ids to in-game actors
  50   ;; and a reverse ;p
  51   (client-dir #:init-thunk make-hash-table
  52               #:getter gm-client-dir)
  53   (reverse-client-dir #:init-thunk make-hash-table
  54                       #:getter gm-reverse-client-dir)
  55
  56   ;; Network manager
  57   (network-manager #:accessor gm-network-manager
  58                    #:init-value #f)
  59
  60   ;; How we get a new connection acclimated to the system
  61   (new-conn-handler #:accessor gm-new-conn-handler
  62                     #:init-keyword #:new-conn-handler)
  63
  64   (message-handler
  65    #:init-value
  66    (make-action-dispatch
  67     (init-world (wrap-apply gm-init-world))
  68     (client-input (wrap-apply gm-handle-client-input))
  69     (lookup-room (wrap-apply gm-lookup-room))
  70     (new-client (wrap-apply gm-new-client))
  71     (write-home (wrap-apply gm-write-home)))))
  72
  73
  74 ;;; .. begin world init stuff ..
  75
  76 (define (gm-init-world gm message)
  77   ;; Load database
  78   ;;  TODO
  79
  80   ;; Init basic rooms / structure
  81   (gm-init-rooms gm (message-ref message 'room-spec))
  82
  83   ;; Restore database-based actors
  84   ;;  TODO
  85
  86   ;; Set up the network
  87   (gm-setup-network gm))
  88
  89 (define (gm-init-rooms gm rooms-spec)
  90   "Initialize the prebuilt rooms"
  91   ;; @@: Would it be nicer to just allow passing in
  92   ;;     #:exits to the room spec itself?
  93   (define (exit-from-spec exit-spec)
  94     "Take room exits syntax from the spec, turn it into exits"
  95     (match exit-spec
  96       ((name to-symbol desc)
  97        (make <exit>
  98          #:name name
  99          #:to-symbol to-symbol
 100          #:desc desc))))
 101
 102   (define rooms
 103     (map
 104      (match-lambda
 105        ((room-symbol room-class
 106                      room-args ...
 107                      (room-exits ...))
 108         ;; initialize the room
 109         (let ((room
 110                (apply create-actor* gm room-class "room"
 111                       #:gm (actor-id gm)
 112                       #:exits (map exit-from-spec room-exits)
 113                       room-args)))
 114           ;; register the room
 115           (hash-set! (gm-room-dir gm) room-symbol room)
 116           ;; pass it back to the map
 117           room)))
 118      rooms-spec))
 119
 120   ;; now wire up all the exits
 121   (for-each
 122    (lambda (room)
 123      (format #t "Wiring up ~s...\n" (address->string room))
 124      (<-wait gm room 'wire-exits!))
 125    rooms))
 126
 127
 128 (define (gm-setup-network gm)
 129   ;; Create a default network manager if none available
 130   (set! (gm-network-manager gm)
 131         (create-actor* gm <network-manager> "netman"
 132                        #:send-input-to (actor-id gm)))
 133
 134   ;; TODO: Add host and port options
 135   (<-wait gm (gm-network-manager gm) 'start-listening))
 136
 137 (define (gm-setup-database gm)
 138   'TODO)
 139
 140 ;;; .. end world init stuff ...
 141
 142 (define-mhandler (gm-new-client actor message client)
 143   ;; @@: Maybe more indirection than needed for this
 144   ((gm-new-conn-handler actor) actor client))
 145
 146
 147 (define (gm-handle-client-input actor message)
 148   "Handle input from a client."
 149   (define client-id (message-ref message 'client))
 150   (define input (message-ref message 'data))
 151   (format #t "From ~s: ~s\n" client-id input)
 152   (<- actor (gm-network-manager actor) 'send-to-client
 153       #:client client-id
 154       #:data "Thanks, we got it!\n"))
 155
 156 (define-mhandler (gm-lookup-room actor message symbol)
 157   (define room-id
 158     (slot-ref (gm-room-dir actor) symbol))
 159   (<-reply actor message room-id))
 160
 161 (define-mhandler (gm-write-home actor message text)
 162   (define client-id (hash-ref (gm-reverse-client-dir actor)
 163                               (message-from message)))
 164   (<- actor (gm-network-manager actor) 'send-to-client
 165       #:client client-id
 166       #:data text))
 167
 168
 169 ;;; GM utilities
 170
 171 (define (gm-register-client! gm client-id player)
 172   (hash-set! (gm-client-dir gm) client-id player)
 173   (hash-set! (gm-reverse-client-dir gm) player client-id))
 174
 175 (define (gm-unregister-client! gm client-id)
 176   "Remove a connection/player combo and ask them to self destruct"
 177   (match (hash-remove! (gm-client-dir gm) client-id)  ; Remove from our client dir
 178     ((_ . player-id)
 179      ;; Remove from reverse table too
 180      (hash-remove! (gm-reverse-client-dir gm) client-id)
 181      ;; Destroy player
 182      (<- gm player-id 'destroy-self))
 183     (#f (throw 'no-client-to-unregister
 184                "Can't unregister a client that doesn't exist?"
 185                client-id))))
 186
 187 ;;; An easy default
 188
 189 (define (make-default-room-conn-handler default-room)
 190   "Make a handler for a GM that dumps people in a default room
 191 with an anonymous persona"
 192   (let ((count 0))
 193     (lambda (gm client-id)
 194       (define guest-name (string-append "Guest-"
 195                                         (number->string count)))
 196       (define room-id
 197         (hash-ref (gm-room-dir gm) default-room))
 198       ;; create and register the player
 199       (define player
 200         (create-actor* gm <player> "player"
 201                        #:username guest-name
 202                        #:gm (actor-id gm)
 203                        #:client client-id))
 204
 205       ;; Register the player in our database of players -> connections
 206       (gm-register-client! gm client-id player)
 207       ;; Dump the player into the default room
 208       (<-wait gm player 'set-loc! #:id room-id)
 209       ;; Initialize the player
 210       (<- gm player 'init))))
 211
 212
 213 ;;; Game actor
 214 ;;; ==========
 215
 216 ;;; *all* game components that talk to players should somehow
 217 ;;; derive from this class.
 218 ;;; And all of them need a GM!
 219
 220 (define-class <gameobj> (<actor>)
 221   ;; location id
 222   (loc #:init-value #f
 223        #:accessor gameobj-loc)
 224   ;; game master id
 225   (gm #:init-keyword #:gm
 226       #:getter gameobj-gm)
 227   ;; a name to be known by
 228   (name #:init-keyword #:name
 229         #:accessor gameobj-name)
 230
 231   ;; how to print our name
 232   (name-f #:init-keyword #:name-f
 233           #:getter gameobj-name-f
 234           #:init-value (wrap gameobj-simple-name-f))
 235
 236   ;; Name aliases
 237   (aliases #:init-keyword #:aliases
 238            #:init-value '())
 239
 240   ;; Commands we can handle
 241   (dirobj-commands #:init-value '())
 242   (indirobj-commands #:init-value '())
 243
 244   ;; Commands we can handle by being something's container
 245   (contain-commands #:init-value #f))
 246
 247
 248 (define (gameobj-simple-name-f gameobj)
 249   "Simplest version: return ourselves for our name."
 250   (gameobj-name gameobj))
 251
 252
 253 \f
 254 ;;; Rooms
 255 ;;; =====
 256
 257 ;; @@: Maybe make this into a record type when this congeals a bit?
 258 ;;   I dunno?
 259
 260 (define-class <exit> ()
 261   ;; Used for wiring
 262   (to-symbol #:accessor exit-to-symbol
 263              #:init-keyword #:to-symbol)
 264   ;; The actual address we use
 265   (to-address #:accessor exit-to-address
 266               #:init-keyword #:address)
 267   ;; Name of the room (@@: Should this be names?)
 268   (name #:accessor exit-name
 269         #:init-keyword #:name)
 270   (desc #:accessor exit-desc
 271                #:init-keyword #:desc)
 272
 273   ;; *Note*: These two methods have an extra layer of indirection, but
 274   ;;   it's for a good reason.
 275   (visible-check #:init-value (const #t)
 276                  #:init-keyword #:visible-check)
 277   ;; By default all exits can be traversed
 278   (traverse-check #:init-value (const #t)
 279                   #:init-keyword #:traverse-check))
 280
 281 (define* (exit-can-traverse? exit actor
 282                              #:optional (target-actor (actor-id actor)))
 283   ((slot-ref exit 'traverse-check) exit actor target-actor))
 284
 285 (define* (exit-is-visible? exit actor
 286                            #:optional (target-actor (actor-id actor)))
 287   ((slot-ref exit 'traverse-check) exit actor target-actor))
 288
 289
 290 ;; Kind of a useful utility, maybe?
 291 (define (simple-slot-getter slot)
 292   (lambda (actor message)
 293     (reply-message actor message
 294                    #:val (slot-ref actor slot))))
 295
 296 (define always (const #t))
 297
 298 ;; TODO: remove hack
 299 (define full-command list)
 300
 301 ;; TODO: fill these in
 302 (define cmatch-just-verb #f)
 303 (define cmatch-direct-verb #f)
 304 (define cmatch-direct-obj #f)
 305
 306 (define %room-contain-commands
 307   (list
 308    (full-command "look" cmatch-just-verb always 'look-room)
 309    (full-command "look" cmatch-direct-obj always 'look-member)
 310    (full-command "go" cmatch-just-verb always 'go-where)
 311    (full-command "go" cmatch-direct-obj always 'go-exit)))
 312
 313 ;; TODO: Subclass from container?
 314 (define-class <room> (<gameobj>)
 315   (desc #:init-value ""
 316         #:init-keyword #:desc)
 317   ;; TODO: Switch this to be loc based
 318   ;; Uses a hash table like a set (values ignored)
 319   (occupants #:init-thunk make-hash-table)
 320   ;; A list of <exit>
 321   (exits #:init-value '()
 322          #:getter room-exits)
 323   ;; @@: Maybe eventually <room> will inherit from some more general
 324   ;;  game object class
 325
 326   (contain-commands
 327    #:init-value %room-contain-commands)
 328
 329   (message-handler
 330    #:allocation #:each-subclass
 331    #:init-value
 332    (make-action-dispatch
 333     ;; desc == description
 334     (get-desc
 335      (simple-slot-getter 'desc))
 336     (get-name
 337      (simple-slot-getter 'name))
 338     ((register-occupant! actor message who)
 339      "Register an actor as being a occupant of this room"
 340      (hash-set! (slot-ref actor 'occupants) who #t))
 341     ((evict-occupant! actor message who)
 342      "De-register an occupant removed from the room"
 343      (hash-remove! (slot-ref actor 'occupants) who))
 344     (wire-exits! (wrap-apply room-wire-exits!)))))
 345
 346 (define (room-wire-exits! room message)
 347   "Actually hook up the rooms' exit addresses to the rooms they
 348 claim to point to."
 349   (for-each
 350    (lambda (exit)
 351      (define new-exit
 352        (<-wait room (gameobj-gm room) 'lookup-room
 353                #:symbol (exit-to-symbol exit)))
 354
 355      (set! (exit-to-address exit) new-exit))
 356
 357    (room-exits room)))
 358
 359
 360 \f
 361 ;;; Players
 362 ;;; =======
 363
 364 (define-class <player> (<gameobj>)
 365   (username #:init-keyword #:username
 366             #:accessor player-username)
 367   ;; Connection id
 368   (client #:accessor player-client)
 369
 370   (self-commands
 371    #:init-value '()
 372    #:accessor player-self-commands)
 373
 374   (message-handler
 375    #:init-value
 376    (make-action-dispatch
 377     (set-loc! (wrap-apply player-set-loc!))
 378     (init (wrap-apply player-init!)))))
 379
 380 ;;; player message handlers
 381
 382 (define-mhandler (player-set-loc! player message id)
 383   (format #t "DEBUG: Location set to ~s for player ~s\n"
 384           id (actor-id-actor player))
 385   (set! (gameobj-loc player) id))
 386
 387 (define-mhandler (player-init! player message)
 388   (player-look-around player))
 389
 390 ;;; player methods
 391
 392 (define (player-look-around player)
 393   (define room-name
 394     (message-ref
 395      (<-wait player (gameobj-loc player) 'get-name)
 396      'val))
 397   (define room-desc
 398     (message-ref
 399      (<-wait player (gameobj-loc player) 'get-desc)
 400      'val))
 401   (define message-text
 402     (format #f "**~a**\n~a\n" room-name room-desc))
 403
 404   (<- player (gameobj-gm player) 'write-home #:text message-text))
 405
 406 \f
 407 ;;; Debugging stuff
 408 ;;; ===============
 409
 410 (define %test-gm #f)
 411
 412 (define (run-demo db-path room-spec default-room)
 413   (define hive (make-hive))
 414   (define new-conn-handler
 415     (make-default-room-conn-handler default-room))
 416   (define gm
 417     (hive-create-actor-gimmie* hive <game-master> "gm"
 418                                #:new-conn-handler new-conn-handler))
 419   (set! %test-gm gm)
 420   ;; @@: Boy, wouldn't it be nice if the agenda could do things
 421   ;;   on interrupt :P
 422   (ez-run-hive hive
 423                (list (bootstrap-message hive (actor-id gm) 'init-world
 424                                         #:room-spec room-spec))))