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