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