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