;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                             Players                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Classes

;;; Player objects.
(defclass <player> (<listener> <command-able>)
  ;; always have the same description, this is actually never used...
  (description :initvalue   '("Human player."))
  ;; use an initializer so *initial-place* can change
  (location    :initializer (lambda (x) *initial-place*))
  ;; used to give a full name only the first time you get somehwere,
  ;; the first element is always the last you visited.
  (visited     :type        <list> ; (of <places>)
               :accessor    visited-places
               :initarg     :visited
               :initvalue   '())
  ;; holds the time of the last shout so players won't be too noisy
  (last-shout  :type        <number>
               :accessor    last-shout-time
               :initvalue   -1000))

;;; Single player, should not have more than one of these.
(defclass <single-player> (<player>)
  ;; repeated to give this initial value
  (description :initvalue '("Human player (single-player).")))

;;; This is one of several that are controlled in turn, so it must
;; accumulate output not to mix messages.
(defclass <multi-player> (<player>)
  ;; output accumulator
  (messages    :type        <queue>
               :accessor    messages
               ;; must use initializer to get different queues
               :initializer (lambda (x) (make <queue>)))
  (description :initvalue '("Human player (multi-player).")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Interface

;;; A predicate for players.
;;; (define (player? x) ...)

;;; Flush accumulated messages (does nothing for other players).
(defgeneric (flush-messages player))

;;; Checks if a player object is still active.
(defgeneric (player-exists? player))

;;; Read a player name and return one of the <player> objects.
;;; (define (make-single-player) ...)
;;; (define (make-multi-player) ...)

;;; Greets a player.
(defgeneric (greet player))

;;; Prompt for a command.
(defgeneric (command-prompt player))

;;; Get an input from a player.
(defgeneric (get-player-input player))

;;; Add a command to the player commands.
(defgeneric (add-player-command specs desc func))

;;; The delay between inputs, in seconds.
(define *input-interval* 1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Implementation

;;; A predicate for players.
(define (player? x)
  (instance-of? x <player>))

;;; Default tell method - simply print the string.
(defmethod (tell (p <player>) (s <string>))
  (echo s))

;;; A <multi-player> accumulates messages.
(defmethod (tell (p <multi-player>) (s <string>))
  (enqueue s (messages p)))

;;; Getting input is the same for all players - just read an expression.
(defmethod (get-player-input (p <player>))
  (echon "> ")
  (read-inp-line))

;;; Single-players need a clear separator.
(defmethod (get-player-input (p <multi-player>))
  (echon "----------")
  (flush-output) ; make sure that output shows
  (call-next-method))

;;; Multi-players need to see their name.
(defmethod (get-player-input (p <multi-player>))
  (echon "---" (name p) "---")
  (flush-output) ; make sure that output shows
  (call-next-method))

;;; Flush messages - nothing by default.
(defmethod (flush-messages (p <player>))
  #t)

(defmethod (flush-messages (p <multi-player>))
  (define (loop)
    (unless (empty-queue? (messages p))
      (echo (dequeue (messages p)))
      (loop)))
  ;; can actually call (flush-messages p), but this is faster
  (loop))

;;; Global list that hold player instances - used to make sure that we
;;; don't create invalid scenarios.
(define *players* '())

;;; A predicate that checks if a player object is still active.
(defmethod (player-exists? (p <player>))
  (memq p *players*))

;;; Destroying player objects - once this is called it won't be a good
;;; idea to refer to the object so must use the above predicate.
(defmethod (kill (p <player>))
  ;; drop all
  (call-next-method)
  (set! *players* (remq p *players*)))

;;; Creating player objects, the *players* global list is used to
;;; restrict instances.

(define (make-single-player)
  (if (null? *players*)
    (let ((nick+name (read-player-nick+name)))
      (make <single-player>
            :nick (first nick+name) :name (second nick+name)))
    (error '<single-player> "can only create one player.")))

(define (make-multi-player)
  (if (and (not (null? *players*))
           (instance-of? (first *players*) <single-player>))
    (error '<multi-player> "you already have a single player.")
    (begin
      (echo-ns "Player #" (add1 (length *players*)))
      (let ((nick+name (read-player-nick+name)))
        (make <multi-player>
              :nick (first nick+name) :name (second nick+name))))))

;;; Specialize the way that <player> objects are created.
(defmethod (initialize (p <player>) initargs)
  (call-next-method)                    ; must call this
  (greet p)
  (set! *players* (cons p *players*)))

;;; First player inputs immediately, later ones later.
(defmethod (start-time (a <player>))
  (* *input-interval* (length *players*)))

;;; Default time for the next input event.
(defmethod (next-event-time (p <player>))
  (* *input-interval* (length *players*)))

;;; Make this get and do the command for the player.
(defmethod (do-something (p <player>))
  (define (input-loop)
    ;; this is on every loop in case an immediate command said something
    ;; (for multi-players).
    (flush-messages p)
    (let ((inp (get-player-input p)))
      (if inp
        ;; try to do it
        (let ((result (do-command p inp)))
          (cond
           ((not result)
            ;; a #f result says that we're done and no need for more
            ;; events to be generated.
            #f)
           ((string? result)
            ;; a string output means that we should do another command
            ;; immediately, show the result and loop.  An empty string
            ;; is not said.
            (unless (equal? "" result) (tell p result))
            (input-loop))
           ((number? result)
            ;; a number result is the delay until next input
            result)
           (else
            ;; other results means that the next input is at the default
            ;; time delay.
            (next-event-time p))))
        ;; got an eof
        (kill p))))
  (when (player-exists? p)
    (command-prompt p)
    (input-loop)))

;;; Input/output management.

(defmethod (greet (p <player>))
  (tell p "")
  (tell
   p "England...  93^2 A.D...  Saturday afternoon, about tea time...")
  (tell p "  Type help for a list of commands.")
  (tell p ""))

;;; Say something to all people in the same place as the player.
;;; This is an example of specialization on a specific object.
(defmethod (say (p <player>) (s <string>))
  (tell p (echos "You say:" s))
  (call-next-method))

;;; Shout something to everyone, use a limit on frequency, also everyone
;;; in the game will hear it.
(defmethod (shout (p <player>) (s <string>))
  (define bell-char (as <char> 7))
  ;; enforce at least 20 secons between shouts
  (if (< (+ (last-shout-time p) 20) (current-time))
    (begin
      (tell p (echos "You shout:" s bell-char))
      ;; do a ormal shout
      (call-next-method)
      ;; save the time
      (set! (last-shout-time p) (current-time))
      ;; and make all other players get a shout
      (for-each (lambda (q)
                  (unless (memq q (contents (location p)))
                    (tell q (echos "You hear a distant shout:"
                                   s bell-char))))
                *players*))
    ;; can't shout too often...
    (tell p (random-elt '("You try to shout but your throat is sore."
                          "Don't be so noisy!"
                          "Be quiet for a while.")))))

;;; Prompt for a command.
(defmethod (command-prompt (p <player>))
  (describe-location (location p) p)
  ;; make sure that the first element is always the last place
  (set! (visited-places p)
        (cons (location p) (remq (location p) (visited-places p)))))

;;; A <multi-player> must see its accumulated output with a clear header
;;; before giving input.
(defmethod (command-prompt (p <multi-player>))
  (tell p "")
  (call-next-method)
  ;; this appears before other output
  (echo)
  (echo "**********" (name p) "**********")
  (echo))

;;; Command lists.

;;; Commands for <player>s.
(define *player-commands* '())

;;; Command additions are made so that most specific come first in the
;;; list.
(defmethod (add-player-command specs (desc <string>) (func <function>))
  (set! *player-commands*
        (append *player-commands*
                (list (make <command>
                            :specs specs
                            :desc  desc
                            :func  func)))))

(defmethod (commands (obj <player>))
  *player-commands*)