mudsync/mudsync/player.scm

;;; Mudsync --- Live hackable MUD
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Mudsync.
;;;
;;; Mudsync is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Mudsync is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.

(define-module (mudsync player)
  #:use-module (mudsync command)
  #:use-module (mudsync gameobj)
  #:use-module (mudsync game-master)
  #:use-module (mudsync parser)
  #:use-module (8sync actors)
  #:use-module (8sync agenda)
  #:use-module (8sync rmeta-slot)
  #:use-module (ice-9 control)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export (<player>))

;;; Players
;;; =======

(define-class <player> (<gameobj>)
  (username #:init-keyword #:username
            #:getter player-username)

  (self-commands #:allocation #:each-subclass
                 #:init-thunk
                 (build-commands
                  (("inventory" "inv" "i") ((empty-command cmd-inventory)))
                  ("help" ((empty-command cmd-help)))))

  (actions #:allocation #:each-subclass
           #:init-thunk
           (build-actions
            (init player-init)
            (handle-input player-handle-input)
            (tell player-tell)
            (disconnect-self-destruct player-disconnect-self-destruct)
            (cmd-inventory player-cmd-inventory)
            (cmd-help player-cmd-help))))


;;; player message handlers

(define (player-init player message)
  ;; Look around the room we're in
  (<- (gameobj-loc player) 'look-room))


(define* (player-handle-input player message #:key input)
  (define split-input (split-verb-and-rest input))
  (define input-verb (car split-input))
  (define input-rest (cdr split-input))

  (define command-candidates
    (player-gather-command-handlers player input-verb))

  (define winner
    (find-command-winner command-candidates input-rest))

  (match winner
    ((cmd-action winner-id message-args)
     (apply <- winner-id cmd-action message-args))
    (#f
     (<- (gameobj-gm player) 'write-home
         #:text "Sorry, I didn't understand that? (type \"help\" for common commands)\n"))))

(define* (player-tell player message #:key text)
  (<- (gameobj-gm player) 'write-home
      #:text text))

(define (player-disconnect-self-destruct player message)
  "Action routine for being told to disconnect and self destruct."
  (define loc (gameobj-loc player))
  (when loc
    (<- loc 'tell-room
        #:exclude (actor-id player)
        #:text (format #f "~a disappears in a puff of entropy!\n"
                       (slot-ref player 'name))))
  (gameobj-self-destruct player))

(define (player-cmd-inventory player message)
  "Display the inventory for the player"
  (define inv-names
    (map
     (lambda (inv-item)
       (mbody-val (<-wait inv-item 'get-name)))
     (gameobj-occupants player)))
  (define text-to-show
    (if (eq? inv-names '())
        "You aren't carrying anything.\n"
        `((p "You are carrying:")
          (ul ,(map (lambda (item-name)
                      `(li ,item-name))
                    inv-names)))))
  (<- (actor-id player) 'tell #:text text-to-show))

(define (player-cmd-help player message)
  (<- (actor-id player) 'tell
      #:text '((strong "** Mudsync Help **")(br)
               (p "You're playing Mudsync, a multiplayer text-adventure. "
                  "Type different commands to interact with your surroundings "
                  "and other players.")
               (p "Some common commands:"
                  (ul (li (strong "say <message>") " -- "
                          "Chat with other players in the same room. "
                          "(Also aliased to the " (b "\"") " character.)")
                      (li (strong "look") " -- "
                          "Look around the room you're in.")
                      (li (strong "look [at] <object>") " -- "
                          "Examine a particular object.")
                      (li (strong "go <exit>") " -- "
                          "Move to another room in <exit> direction.")))
               (p "Different objects can be interacted with in different ways. "
                  "For example, if there's a bell in the same room as you, "
                  "you might try typing " (em "ring bell")
                  " and see what happens."))))


;;; Command handling
;;; ================

;; @@: Hard to know whether this should be in player.scm or here...
;; @@: This could be more efficient as a stream...!?
(define (player-gather-command-handlers player verb)
  (define player-loc
    (let ((result (gameobj-loc player)))
      (if result
          result
          (throw 'player-has-no-location
                 "Player ~a has no location!  How'd that happen?\n"
                 #:player-id (actor-id player)))))

  ;; Ask the room for its commands
  (define room-dom-commands
    ;; TODO: Map room id and sort
    (mbody-receive (_ #:key commands)
        (<-wait player-loc 'get-container-dom-commands
                #:verb verb)
      commands))

  (define room-sub-commands
    ;; TODO: Map room id and sort
    (mbody-receive (_ #:key commands)
        (<-wait player-loc 'get-container-sub-commands
                #:verb verb)
      commands))

  ;; All the co-occupants of the room (not including ourself)
  (define co-occupants
    (remove
     (lambda (x) (equal? x (actor-id player)))
     (mbody-val (<-wait player-loc 'get-occupants))))

  ;; @@: There's a race condition here if someone leaves the room
  ;;   during this, heh...
  ;;   I'm not sure it can be solved, but "lag" on the race can be
  ;;   reduced maybe?

  ;; Get all the co-occupants' commands
  (define co-occupant-commands
    (fold
     (lambda (co-occupant prev)
       (mbody-receive (_ #:key commands goes-by)
           (<-wait co-occupant 'get-commands
                   #:verb verb)
         (append
          (map (lambda (command)
                 (list command goes-by co-occupant))
               commands)
          prev)))
     '()
     co-occupants))

  ;; Append our own command handlers
  (define our-commands
    (class-rmeta-ref (class-of player) 'self-commands verb
                     #:dflt '()))

  ;; Append our inventory's relevant command handlers
  (define inv-items
    (gameobj-occupants player))
  (define inv-item-commands
    (fold
     (lambda (inv-item prev)
       (mbody-receive (_ #:key commands goes-by)
           (<-wait inv-item 'get-contained-commands
                   #:verb verb)
         (append
          (map (lambda (command)
                 (list command goes-by inv-item))
               commands)
          prev)))
     '()
     inv-items))

  ;; Now return a big ol sorted list of ((actor-id . command))
  (append
   (sort-commands-append-actor room-dom-commands
                               player-loc '()) ; room doesn't go by anything
   (sort-commands-multi-actors co-occupant-commands)
   (sort-commands-append-actor our-commands
                               (actor-id player) '()) ; nor does player
   (sort-commands-multi-actors inv-item-commands)
   (sort-commands-append-actor room-sub-commands
                               player-loc '())))

(define (sort-commands-append-actor commands actor-id goes-by)
  (sort-commands-multi-actors
   (map (lambda (command) (list command goes-by actor-id)) commands)))

(define (sort-commands-multi-actors actors-and-commands)
  (sort
   actors-and-commands
   (lambda (x y)
     (> (command-priority (car x))
        (command-priority (car y))))))


(define (find-command-winner sorted-candidates line)
  "Find a command winner from a sorted list of candidates"
  ;; A cache of results from matchers we've already seen
  ;; TODO: fill in this cache.  This is a *critical* optimization!
  (define matcher-cache '())
  (call/ec
   (lambda (return)
     (for-each
      (match-lambda
        ((command actor-goes-by actor-id)
         (let* ((matcher (command-matcher command))
                (matched (matcher line)))
           (if (and matched
                    ;; Great, it matched, but does it also pass
                    ;; should-handle?
                    (apply (command-should-handle command)
                           actor-goes-by
                           matched))  ; matched is kwargs if truthy
               (return (list (command-action command)
                             actor-id matched))
               #f))))
      sorted-candidates)
     #f)))