mudsync/player.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 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 (mudsync receive-star)
  25   #:use-module (8sync actors)
  26   #:use-module (8sync agenda)
  27   #:use-module (8sync rmeta-slot)
  28   #:use-module (ice-9 control)
  29   #:use-module (ice-9 format)
  30   #:use-module (ice-9 match)
  31   #:use-module (oop goops)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-9)
  34   #:export (<player>))
  35
  36 ;;; Players
  37 ;;; =======
  38
  39 (define-class <player> (<gameobj>)
  40   (username #:init-keyword #:username
  41             #:getter player-username)
  42
  43   (self-commands #:allocation #:each-subclass
  44                  #:init-thunk
  45                  (build-commands
  46                   (("inventory" "inv" "i") ((empty-command cmd-inventory)))
  47                   ("help" ((empty-command cmd-help)))))
  48
  49   (actions #:allocation #:each-subclass
  50            #:init-thunk
  51            (build-actions
  52             (init player-init)
  53             (handle-input player-handle-input)
  54             (tell player-tell)
  55             (disconnect-self-destruct player-disconnect-self-destruct)
  56             (cmd-inventory player-cmd-inventory)
  57             (cmd-help player-cmd-help))))
  58
  59
  60 ;;; player message handlers
  61
  62 (define (player-init player message)
  63   ;; Look around the room we're in
  64   (<- (gameobj-loc player) 'look-room))
  65
  66
  67 (define* (player-handle-input player message #:key input)
  68   (define split-input (split-verb-and-rest input))
  69   (define input-verb (car split-input))
  70   (define input-rest (cdr split-input))
  71
  72   (define command-candidates
  73     (player-gather-command-handlers player input-verb))
  74
  75   (define winner
  76     (find-command-winner command-candidates input-rest))
  77
  78   (match winner
  79     ((cmd-action winner-id message-args)
  80      (apply <- winner-id cmd-action message-args))
  81     (#f
  82      (<- (gameobj-gm player) 'write-home
  83          #:text "Sorry, I didn't understand that? (type \"help\" for common commands)\n"))))
  84
  85 (define* (player-tell player message #:key text)
  86   (<- (gameobj-gm player) 'write-home
  87       #:text text))
  88
  89 (define (player-disconnect-self-destruct player message)
  90   "Action routine for being told to disconnect and self destruct."
  91   (define loc (gameobj-loc player))
  92   (when loc
  93     (<- loc 'tell-room
  94         #:exclude (actor-id player)
  95         #:text (format #f "~a disappears in a puff of entropy!\n"
  96                        (slot-ref player 'name))))
  97   (gameobj-self-destruct player))
  98
  99 (define (player-cmd-inventory player message)
 100   "Display the inventory for the player"
 101   (define inv-names
 102     (map
 103      (lambda (inv-item)
 104        (<-wait inv-item 'get-name))
 105      (gameobj-occupants player)))
 106   (define text-to-show
 107     (if (eq? inv-names '())
 108         "You aren't carrying anything.\n"
 109         `((p "You are carrying:")
 110           (ul ,(map (lambda (item-name)
 111                       `(li ,item-name))
 112                     inv-names)))))
 113   (<- (actor-id player) 'tell #:text text-to-show))
 114
 115 (define (player-cmd-help player message)
 116   (<- (actor-id player) 'tell
 117       #:text '((strong "** Mudsync Help **")(br)
 118                (p "You're playing Mudsync, a multiplayer text-adventure. "
 119                   "Type different commands to interact with your surroundings "
 120                   "and other players.")
 121                (p "Some common commands:"
 122                   (ul (li (strong "say <message>") " -- "
 123                           "Chat with other players in the same room. "
 124                           "(Also aliased to the " (b "\"") " character.)")
 125                       (li (strong "look") " -- "
 126                           "Look around the room you're in.")
 127                       (li (strong "look [at] <object>") " -- "
 128                           "Examine a particular object.")
 129                       (li (strong "go <exit>") " -- "
 130                           "Move to another room in <exit> direction.")))
 131                (p "Different objects can be interacted with in different ways. "
 132                   "For example, if there's a bell in the same room as you, "
 133                   "you might try typing " (em "ring bell")
 134                   " and see what happens."))))
 135
 136
 137 ;;; Command handling
 138 ;;; ================
 139
 140 ;; @@: Hard to know whether this should be in player.scm or here...
 141 ;; @@: This could be more efficient as a stream...!?
 142 (define (player-gather-command-handlers player verb)
 143   (define player-loc
 144     (let ((result (gameobj-loc player)))
 145       (if result
 146           result
 147           (throw 'player-has-no-location
 148                  "Player ~a has no location!  How'd that happen?\n"
 149                  #:player-id (actor-id player)))))
 150
 151   ;; Ask the room for its commands
 152   (define room-dom-commands
 153     ;; TODO: Map room id and sort
 154     (receive* (#:key commands)
 155         (<-wait player-loc 'get-container-dom-commands
 156                 #:verb verb)
 157       commands))
 158
 159   (define room-sub-commands
 160     ;; TODO: Map room id and sort
 161     (receive* (#:key commands)
 162         (<-wait player-loc 'get-container-sub-commands
 163                 #:verb verb)
 164       commands))
 165
 166   ;; All the co-occupants of the room (not including ourself)
 167   (define co-occupants
 168     (remove
 169      (lambda (x) (equal? x (actor-id player)))
 170      (<-wait player-loc 'get-occupants)))
 171
 172   ;; @@: There's a race condition here if someone leaves the room
 173   ;;   during this, heh...
 174   ;;   I'm not sure it can be solved, but "lag" on the race can be
 175   ;;   reduced maybe?
 176
 177   ;; Get all the co-occupants' commands
 178   (define co-occupant-commands
 179     (fold
 180      (lambda (co-occupant prev)
 181        (receive* (#:key commands goes-by)
 182            (<-wait co-occupant 'get-commands
 183                    #:verb verb)
 184          (append
 185           (map (lambda (command)
 186                  (list command goes-by co-occupant))
 187                commands)
 188           prev)))
 189      '()
 190      co-occupants))
 191
 192   ;; Append our own command handlers
 193   (define our-commands
 194     (class-rmeta-ref (class-of player) 'self-commands verb
 195                      #:dflt '()))
 196
 197   ;; Append our inventory's relevant command handlers
 198   (define inv-items
 199     (gameobj-occupants player))
 200   (define inv-item-commands
 201     (fold
 202      (lambda (inv-item prev)
 203        (receive* (#:key commands goes-by)
 204            (<-wait inv-item 'get-contained-commands
 205                    #:verb verb)
 206          (append
 207           (map (lambda (command)
 208                  (list command goes-by inv-item))
 209                commands)
 210           prev)))
 211      '()
 212      inv-items))
 213
 214   ;; Now return a big ol sorted list of ((actor-id . command))
 215   (append
 216    (sort-commands-append-actor room-dom-commands
 217                                player-loc '()) ; room doesn't go by anything
 218    (sort-commands-multi-actors co-occupant-commands)
 219    (sort-commands-append-actor our-commands
 220                                (actor-id player) '()) ; nor does player
 221    (sort-commands-multi-actors inv-item-commands)
 222    (sort-commands-append-actor room-sub-commands
 223                                player-loc '())))
 224
 225 (define (sort-commands-append-actor commands actor-id goes-by)
 226   (sort-commands-multi-actors
 227    (map (lambda (command) (list command goes-by actor-id)) commands)))
 228
 229 (define (sort-commands-multi-actors actors-and-commands)
 230   (sort
 231    actors-and-commands
 232    (lambda (x y)
 233      (> (command-priority (car x))
 234         (command-priority (car y))))))
 235
 236
 237 (define (find-command-winner sorted-candidates line)
 238   "Find a command winner from a sorted list of candidates"
 239   ;; A cache of results from matchers we've already seen
 240   ;; TODO: fill in this cache.  This is a *critical* optimization!
 241   (define matcher-cache '())
 242   (call/ec
 243    (lambda (return)
 244      (for-each
 245       (match-lambda
 246         ((command actor-goes-by actor-id)
 247          (let* ((matcher (command-matcher command))
 248                 (matched (matcher line)))
 249            (if (and matched
 250                     ;; Great, it matched, but does it also pass
 251                     ;; should-handle?
 252                     (apply (command-should-handle command)
 253                            actor-goes-by
 254                            matched))  ; matched is kwargs if truthy
 255                (return (list (command-action command)
 256                              actor-id matched))
 257                #f))))
 258       sorted-candidates)
 259      #f)))