;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                             Animates                             ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

;;; The class of all animated objects, they can hold things.
(defclass <animate> (<contained> <container>))

;;; Objects with a plan - which is what do-something will do.
(defclass <automated> (<animate>)
  ;; plan is a function that will be applied on the automated object
  (plan :type      <function>
        :accessor  plan
        :initarg   :plan
        :initvalue (lambda (a) #f))) ; do nothing by default

;;; Class of objects that receive verbal messages.
(defclass <listener> (<animate>))

;;; Characters are automated listeners.
(defclass <character> (<automated> <listener>))

;;; Followers - characters that can follow another animate.
(defclass <follower> (<character>)
  (leader :type        <animate>
          :accessor    leader
          :initarg     :leader)
  (plan   :initializer (lambda (args) follower-plan)))

;;; This is the class of knights that you need to get to follow you.
(defclass <knight> (<follower>))


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

;;; A predicate for animates.
;;; (define (animate? x) ...)

;;; The time that the animate should have it's first do-something.
(defgeneric (start-time (a <animate>)))

;;; This generic is what is used to do what the character is doing.  The
;;; return value is a number that is the delay until the next call
;;; event.
(defgeneric (do-something animate))

;;; Destroys an animate object.
(defgeneric (kill animate))

;;; Say something to all animates in the same place.
(defgeneric (say animate string))

;;; Emote something - like say without the colon.
(defgeneric (emote animate string))

;;; Shout something.
(defgeneric (shout animate string))

;;; A predicate for listeners.
;;; (define (listener? x) ...)

;;; A general string message.
(defgeneric (tell listener string))

;;; This is used to make a listener react to some message.
(defgeneric (message listener originator type msg))


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

;;; A predicate for animates.
(define (animate? x)
  (instance-of? x <animate>))

;;; Animates have nothing to do by default so return a non-number.
(defmethod (start-time (a <animate>))
  #f)

;;; This specialize the way that <animate> objects are created - adding
;;; the initial do-something event automatically.
(defmethod (initialize (a <animate>) initargs)
  (define (animate-loop)
    ;; this will do-something and insert the next event if the result is
    ;; a number.
    (let ((n (do-something a)))
      (when (number? n) (insert-event n animate-loop))))
  (call-next-method)                    ; must call this
  (let ((start (start-time a)))
    (when (number? start)               ; add 1st event if got a number
      (insert-event start animate-loop))))

;;; When an animate is destroyed, all of its belongings are dropped.
(defmethod (kill (a <animate>))
  (emote a "died")
  (for-each (lambda (o) (transfer o a (location a)))
            (contents a))
  ;; place a corresponding corpse object in the same place - it's
  ;; initialization will add it to the place contents.
  (make-corpse a)
  ;; remove the animate
  (set! (contents (location a)) (remq a (contents (location a))))
  ;; and indicate that this character is dead, should there be more
  ;; references to the object.
  (set! (location a) *null-place*))

;;; Say something to all animates in the same place.
(defmethod (say (a <animate>) (s <string>))
  (place-message (location a) s a 'say))

;;; Say something to all animates in the same place _without_ "name:" -
;;; so if you do (emote "laughs"), everyone will see "*name* laughs".
(defmethod (emote (a <animate>) (s <string>))
  (place-message (location a) s a 'emote))

;;; Shout something to everyone.
(defmethod (shout (a <animate>) (s <string>))
  (place-message (location a) s a 'shout))

;;; Automated start immediately, and run their plan.
(defmethod (start-time (a <automated>))
  0)
(defmethod (do-something (a <automated>))
  ((plan a) a))

;;; A general string message - do nothing by default.
(defmethod (tell (l <listener>) (s <string>))
  #t)

;;; This is defined since it is used in several places.
(define (listener? x)
  (instance-of? x <listener>))

;;; Messages - default is to translate to simple message.
(defmethod (message (l <listener>) (from <animate>)
                    (type <symbol>) (msg <string>))
  (define bell (as <char> 7))
  (tell l (case type
            ((say)   (echos (name from) "says:" msg))
            ((emote) (echos-ns "*" (name from) " " msg "*"))
            ((shout) (echos (name from) "shouts:" msg bell))
            ((tell)  (echos (name from) "tells you:" msg))
            ((enter) (echos (name from) "arrived from" msg))
            ((leave) (echos (name from) "left to" msg))
            (else msg))))

;;; Followers, first - a plan that will make them follow their leader.
(defmethod (follower-plan (f <follower>))
  (let ((ldr (leader f))
        (loc (location f)))
  (if (memq ldr (contents loc))
    ;; the leader is here, get bored & check again in some time
    (random 8)
    ;; otherwise look for the leader in a nearby place
    (let ((p (find-if (lambda (p) (memq ldr (contents p)))
                      (exits loc))))
      (if p
        ;; leader found - go there
        (transfer f loc p)
        ;; otherwise, lose interest (make f follow itself)
        (set! (leader f) f))
      ;; check again in a second in case leader moves again
      1))))

;;; Follow if you say "follow me", stop if you say "leave me".
(defmethod (message (f <follower>) (from <animate>)
                    (type <symbol>) (msg <string>))
  (when (memq type '(say shout tell))
    ;; use an event so the actual message will be seen before these
    ;; responses.
    (insert-immediate-event
     (lambda ()
       (cond
        ((equal? msg "follow me")
         (cond
          ((eq? (leader f) f)    ; no current leader - set it
           (emote f "nods")
           (set! (leader f) from))
          ((eq? (leader f) from) ; same leader, stay with it
           (emote f (echos "looks lovingly at" (name from))))
          (else                  ; no stealing!
           (emote f (echos "grunts and looks at" (name (leader f)))))))
        ((equal? msg "leave me")
         (cond
          ;; require also that no current leader is set
          ((eq? (leader f) f)    ; no leader - nothing to do
           (emote f "yawns"))
          ((eq? (leader f) from) ; leader said - leave it
           (emote f (echos "looks at" (name from) "insultingly"))
           (set! (leader f) f))
          (else
           (emote f (echos "grunts and looks at" (name (leader f)))))))
        (else (call-next-method)))))))

;;; Indicate the follow commands in the description, or the leader if it
;;; is already following someone - this is an example for overriding a
;;; generic that was created with :accessor.
(defmethod (description (f <follower>))
  (append (call-next-method)
          (if (eq? (leader f) f)
            (list (echos-ns "You can ask " (name f)
                            " to follow or to leave you."))
            (list (echos-ns "(following " (name (leader f)) ")")))))