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
  45 (define player-actions*
  46   (append player-actions
  47           gameobj-actions))
  48
  49 (define player-dispatcher
  50   (simple-dispatcher player-actions*))
  51
  52 (define-class <player> (<gameobj>)
  53   (username #:init-keyword #:username
  54             #:getter player-username)
  55
  56   (self-commands
  57    #:init-value '()
  58    #:getter player-self-commands)
  59
  60   (message-handler
  61    #:init-value
  62    ;; @@: We're gonna need action inheritance real awful soon, huh?
  63    (wrap-apply player-dispatcher)))
  64
  65
  66 ;;; player message handlers
  67
  68 (define-mhandler (player-init player message)
  69   ;; Look around the room we're in
  70   (<- player (gameobj-loc player) 'look-room))
  71
  72
  73 (define-mhandler (player-handle-input player message input)
  74   (define split-input (split-verb-and-rest input))
  75   (define input-verb (car split-input))
  76   (define input-rest (cdr split-input))
  77
  78   (define command-candidates
  79     (player-gather-command-handlers player input-verb))
  80
  81   (define winner
  82     (find-command-winner command-candidates input-rest))
  83
  84   (match winner
  85     ((cmd-action winner-id message-args)
  86      (apply send-message player winner-id cmd-action message-args))
  87     (#f
  88      (<- player (gameobj-gm player) 'write-home
  89          #:text "Huh?\n"))))
  90
  91 (define-mhandler (player-tell player message text)
  92   (<- player (gameobj-gm player) 'write-home
  93       #:text text))
  94
  95 (define-mhandler (player-disconnect-self-destruct player message)
  96   "Action routine for being told to disconnect and self destruct."
  97   (define loc (gameobj-loc player))
  98   (when loc
  99     (<- player loc 'tell-room
 100         #:exclude (actor-id player)
 101         #:text (format #f "~a disappears in a puff of entropy!\n"
 102                        (slot-ref player 'name))))
 103   (gameobj-self-destruct player))
 104
 105
 106 ;;; Command handling
 107 ;;; ================
 108
 109 ;; @@: Hard to know whether this should be in player.scm or here...
 110 ;; @@: This could be more efficient as a stream...!?
 111 (define (player-gather-command-handlers player verb)
 112   (define player-loc
 113     (let ((result (gameobj-loc player)))
 114       (if result
 115           result
 116           (throw 'player-has-no-location
 117                  "Player ~a has no location!  How'd that happen?\n"
 118                  #:player-id (actor-id player)))))
 119
 120   ;; Ask the room for its commands
 121   (define room-commands
 122     ;; TODO: Map room id and sort
 123     (message-ref
 124      (<-wait player player-loc
 125              'get-container-commands
 126              #:verb verb)
 127      'commands))
 128
 129   ;; All the co-occupants of the room (not including ourself)
 130   (define co-occupants
 131     (remove
 132      (lambda (x) (equal? x (actor-id player)))
 133      (message-ref
 134       (<-wait player player-loc 'get-occupants)
 135       'occupants)))
 136
 137   ;; @@: There's a race condition here if someone leaves the room
 138   ;;   during this, heh...
 139   ;;   I'm not sure it can be solved, but "lag" on the race can be
 140   ;;   reduced maybe?
 141
 142   ;; Get all the co-occupants' commands
 143   (define co-occupant-commands
 144     ;; TODO: Switch this to a fold.  Ignore a result if it
 145     ;;   returns false for in the command response
 146     (fold
 147      (lambda (co-occupant prev)
 148        (let* ((result (<-wait player co-occupant 'get-commands
 149                               #:verb verb))
 150               (commands (message-ref result 'commands))
 151               (goes-by (message-ref result 'goes-by)))
 152          (append
 153           (map (lambda (command)
 154                  (list command goes-by co-occupant))
 155                commands)
 156           prev)))
 157      '()
 158      co-occupants))
 159
 160   ;; Append our own command handlers
 161   (define our-commands
 162     (player-self-commands player))
 163
 164   ;; TODO: Append our inventory's relevant command handlers
 165
 166   ;; Now return a big ol sorted list of ((actor-id . command))
 167   (append
 168    (sort-commands-append-actor room-commands
 169                                player-loc '()) ; room doesn't go by anything
 170    (sort-commands-multi-actors co-occupant-commands)
 171    (sort-commands-append-actor our-commands
 172                                (actor-id player) '()))) ; nor does player
 173
 174 (define (sort-commands-append-actor commands actor-id goes-by)
 175   (sort-commands-multi-actors
 176    (map (lambda (command) (list command goes-by actor-id)) commands)))
 177
 178 (define (sort-commands-multi-actors actors-and-commands)
 179   (sort
 180    actors-and-commands
 181    (lambda (x y)
 182      (> (command-priority (car x))
 183         (command-priority (car y))))))
 184
 185
 186 (define (find-command-winner sorted-candidates line)
 187   "Find a command winner from a sorted list of candidates"
 188   ;; A cache of results from matchers we've already seen
 189   ;; TODO: fill in this cache.  This is a *critical* optimization!
 190   (define matcher-cache '())
 191   (call/ec
 192    (lambda (return)
 193      (for-each
 194       (match-lambda
 195         ((command actor-goes-by actor-id)
 196          (let* ((matcher (command-matcher command))
 197                 (matched (matcher line)))
 198            (if (and matched
 199                     ;; Great, it matched, but does it also pass
 200                     ;; should-handle?
 201                     (apply (command-should-handle command)
 202                            actor-goes-by
 203                            matched))  ; matched is kwargs if truthy
 204                (return (list (command-action command)
 205                              actor-id matched))
 206                #f))))
 207       sorted-candidates)
 208      #f)))