;;;; -*- Mode:COMMON-LISP; Package:ECO-EXAMPLE; Base:10 -*-
;;;; *-* File: lapis: /u7/gbb/v-400/dev/source/gbb/examples/eco-example.lisp *-*
;;;; *-* Edited-By: Cork *-*
;;;; *-* Last-Edit: Tuesday, September 22, 1998  10:44:22 *-*
;;;; *-* Machine: GRANITE (Explorer II, Microcode 489) *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *                         ECO SIMULATION SYSTEM
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Participants in
;;;             ``Designing and Implementing Blackboard Applications''
;;;             Northampton, Massachusetts, November 2-5, 1993
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  11-03-93 File created.
;;;  11-06-97 Converted to GBB V3.2.  (Cork)
;;;  09-22-98 Converted to GBB V4.0.  (Cork)
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

(in-package "ECO-EXAMPLE")

;;; ------------------------------------------------------------------------
;;;   Module Definition
;;; ------------------------------------------------------------------------ 
;;
;;     (define-kti-module :eco-example
;;       (:modules :rectangle-mixin 
;;                 :2d-point-mixin
;;                 :rectangle-set-mixin
;;                 :stimulus-unit-mixin
;;                 :agenda-shell
;;                 :gbb-graphics
;;                 :control-shell-graphics)
;;       (:package :eco-example
;;                 (:nicknames "ECO")
;;                 (:use #.*lisp-package-name* "CLOS" "KTI-TOOLS" "GBB"
;;                       "AGENDA-SHELL" "CHALKBOX" "GBB-GRAPHICS"))
;;       (:directory gbb-root-open "examples")
;;       (:files "eco-example"
;;     	  "eco-graphics")
;;       (:auxiliary-files "eco-data")) 

;;; ------------------------------------------------------------------------
;;;   Variables
;;; ------------------------------------------------------------------------ 

(eval-when (compile eval load)
  (defparameter *world-size* 100)
  (defparameter *max-time* 10000)
  (defparameter *max-energy-level* 1000))

(defparameter *eco-data-file* "eco-data")

;; the simulation clock
(defvar *world-clock* nil)

;; Controls the printing of do-action requests:
(defvar *trace-actions* nil)

;; Controls warning message if an animal attempts to move outside the 
;; known world:
(defvar *warn-if-outside-world* nil)

;; Pauses on every fauna death:
(defvar *pause-on-death* nil)

;; Number of clock ticks between pauses.
(defvar *wait-every-interval* 10)

(defvar *setup-windows* t)

;;; ------------------------------------------------------------------------
;;;   Blackboard and Space Definitions
;;; ------------------------------------------------------------------------ 

(define-space ECO-SYSTEM ()
  ((x                 :ordered (0 #.*world-size*))
   (y                 :ordered (0 #.*world-size*))
   (dead?             :enumerated :any)
   (age               :ordered (0 100))
   (energy-level      :ordered (0 #.*max-energy-level*))
   (dry-time          :ordered (0 50))  ;; Max Cycles
   (mobility          :ordered (0 20))  ;; Max squares
   (agility           :ordered (0 10))) ;; Scale 0 - 10
  (:unit-classes organism landform))

(define-space clock ()
  ((time      :ordered (-1 #.*max-time*)))
  (:unit-classes world-clock))


;;; ------------------------------------------------------------------------
;;;   Dimension-Value Computation Definitions
;;; ------------------------------------------------------------------------ 

(define-dimension-value-computation 2D-POINT-SET-DVC
  2d-point-mixin-dvc
  (:dimension-value-computation-type :set))

;;; ------------------------------------------------------------------------
;;;   Unit Class Definitions
;;; ------------------------------------------------------------------------

(define-unit-class LANDFORM (rectangle-set-mixin)
  ()
  (:abstract-class t)
  (:paths '(eco-system)))

;;; ------------------------------------------------------------------------

(define-unit-class LAND (landform)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class WATER (landform)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class SEA (water)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class RIVER (water)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class HILLY (land)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class FLATLAND (land)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class MARSH (land water)
  ())

;;; ------------------------------------------------------------------------

(define-unit-class ORGANISM (stimulus-unit-mixin 2d-point-mixin)
  (;; This slot is inherited from the 2d-point-mixin class.
   ;; It is repeated here to add an additional initarg and accessor.
   (2d-point
       :initarg :location 
       :accessor organism.location)
   (energy-level :initform 10)
   (maximum-energy
       :initform 40
       :allocation :class-per-class))
  (:dimensions (energy-level energy-level :value-type :point))
  (:generate-initargs  energy-level maximum-energy)
  (:generate-accessors energy-level maximum-energy)
  (:abstract-class t)
  (:paths '(eco-system)))

(eval-when (compile eval load)
  (defmacro safe-decf (place &optional (value 1))
    `(let ((%old-value ,place))
       (if (zerop %old-value)
           %old-value
           (setf ,place (max 0 (- %old-value ,value)))))))

(defmethod print-object-for-display ((obj organism) stream)
  (format stream "#<~s ~s ~s>"
          (type-of obj)
          (unit-name obj)
          (organism.location obj)))

;;; ------------------------------------------------------------------------

(define-unit-class FLORA (organism)
  ((regrowth-rate :allocation :class-per-class))
  (:abstract-class t)
  (:generate-initargs t)
  (:generate-accessors t))

;;; ------------------------------------------------------------------------

(define-dimension-value-computation FAUNA-DEAD?-DVC
  ((dead? :label first)))

(define-unit-class FAUNA (organism)
  ((energy-dissipation    :initform 10 :allocation :class-per-class)
   (minimum-energy-level  :initform 10 :allocation :class-per-class)
   (move-cost             :initform 10 :allocation :class-per-class)
   (max-dry-time          :initform 20 :allocation :class-per-class)
   ;; Max number of squares that the animal can see
   (sensing-range         :initform  1 :allocation :class-per-class)
   ;; Time since last drink
   (dry-time              :initform  0)
   (lifespan              :initform 80 :allocation :class-per-class)
   (reproduction-cycle    :initform  1 :allocation :class-per-class)
   (reproduction-rate     :initform  1 :allocation :class-per-class)
   (reproduction-cost     :initform 40 :allocation :class-per-class)
   (minimum-reproduction-energy  :initform 50 :allocation :class-per-class)
   ;; Max number of squares that the animal can cover in a day
   (mobility              :initform  1 :allocation :class-per-class)
   ;; Scale 0 -- 10
   (agility               :initform  2 :allocation :class-per-class)
   (age                   :initform  0)
   (dead?                 :initform nil)
   (swim?                 :initform nil :allocation :class-per-class)
   (feeding-rate          :initform 15 :allocation :class-per-class)
   ;; List of organism classes
   (suitable-food         :initform t  :allocation :class-per-class)
   ;; Single most desirable food
   (desirable-food        :initform t  :allocation :class-per-class))
  (:dimensions
   (age      age      :value-type :point)
   (dry-time dry-time :value-type :point)
   (mobility mobility :value-type :point)
   (agility  agility  :value-type :point)
   (dead?    dead?    :value-type fauna-dead?-dvc))
  (:abstract-class t)
  (:generate-initargs t)
  (:generate-accessors t))

(defmethod print-object-for-display ((obj fauna) stream)
  (format stream "#<~s ~s~:[~; Dead~] ~s>"
          (type-of obj)
          (unit-name obj)
          (fauna.dead? obj)
          (organism.location obj)))

;;; ------------------------------------------------------------------------

(define-unit-class CARNIVORE (fauna)
  ()
  (:abstract-class t))
 
;;; ------------------------------------------------------------------------

(define-unit-class HERBIVORE (fauna)
  ()
  (:abstract-class t))
 
;;; ------------------------------------------------------------------------

(define-unit-mapping (landform) (eco-system)
  ((x      :subranges (:start :end (:width 20)))
   (y      :subranges (:start :end (:width 20)))))

(define-unit-mapping (flora) (eco-system)
  ((x      :subranges (:start :end (:width 10)))
   (y      :subranges (:start :end (:width 10)))))

(define-unit-mapping (fauna) (eco-system)
  ((x      :subranges (:start :end (:width 10)))
   (y      :subranges (:start :end (:width 10)))))

;;; ------------------------------------------------------------------------

(define-unit-class STIMULATED-KSA (control-shell-ksa stimulated-ksa-mixin)
  ())
 
;;; ------------------------------------------------------------------------
;;;   ECO-EXAMPLE
;;; ------------------------------------------------------------------------

(defun eco-example-startup ()
  (disable-event-printing)
  (delete-blackboard-database)
  (instantiate-blackboard-database 'eco-system 'clock)
  (format *event-print-stream*
          "~2&;; Running the eco system example....~%"))

(pushnew 'eco-example-startup 
	 control-shells::*control-shell-initialization-hooks*)

;;; ------------------------------------------------------------------------

(defun eco-example-entry ()
  #+(and :CL-ALLEGRO :OS-WINDOWS)
  (cb::clear-lisp-listener)
  (setf *world-clock* nil)
  (when (and *setup-windows* (fboundp 'setup-eco-graphics))
    (setup-eco-graphics)))

(pushnew 'eco-example-entry 
	 control-shells::*control-shell-entry-hooks*)

;;; ------------------------------------------------------------------------

(defun ECO-EXAMPLE (&optional *setup-windows* &key
		    ((:event-print-stream *event-print-stream*) *standard-output*)
                    ((:wait *wait-every-interval*) *wait-every-interval*))
  (check-type *wait-every-interval* (or null number) "a number or nil")
  (start-control-shell :event-print-stream *event-print-stream*))
 
;;; ------------------------------------------------------------------------

(defun eco-example-exit ()
  (describe-blackboard-database t)
  (format *event-print-stream*
	  "~2&;; Leaving the eco system example....~%"))
  
(pushnew 'eco-example-exit 
	 control-shells::*control-shell-exit-hooks*)

;;; ------------------------------------------------------------------------
  
(defun ORGANISM-PRECONDITION (&rest ignore-list)
  ;; This COMMON precondition function provides a random KSA rating between
  ;; one and 100, allowing prey a 50/50 chance of moving away from a
  ;; tracker in the current simulation cycle:
  (declare (ignore ignore-list))
  (let ((rating (+ (random 100) 1)))
    rating))

;;; ------------------------------------------------------------------------
;;;   INITIAL-KS Code 
;;; ------------------------------------------------------------------------
;;;
;;; Simple initial KS that reads the initial conditions.

(define-ks INITIAL-KS
  :rating 100
  :trigger-events ((start-control-shell-event))
  :ks-function 'initial-ks
  :ksa-unit-class stimulated-ksa)

(defun INITIAL-KS (ksa)
  (declare (ignore ksa))
  (setf *world-clock* (make-unit 'world-clock))
  (let ((input-file (kti-directory-file-pathname
                      '(kti-tools::gbb-root-open "examples")
                      *eco-data-file*))
        (*package* (find-package "ECO-EXAMPLE")))
    (with-open-file (data-file input-file :direction :input)
      (build-landforms (read data-file))
      (build-flora (read data-file)))))

(defun build-landforms (specs)
  (dolist (spec specs)
    ;; Format of landform spec: (<classs> <extent> ...)
    (make-unit (first spec)
	       :extents
	       (mapcar #'(lambda (extent)
			   (make-rectangle :x-min (first extent)
					   :length (- (second extent) (first extent))
					   :y-min (third extent)
					   :width (- (fourth extent) (third extent))))
		       (rest spec)))))
    
(defun build-flora (specs)
  (format *event-print-stream* "~&;; Creating grass and trees....")
  (dolist (spec specs)
    ;; Format of flora spec: (<classs> <density> <extent> ...)
    (let ((class (first spec))
	  (density (second spec)))
      (dolist (extent (nthcdr 2 spec))
	(let ((x-min (first extent))
	      (x-max (second extent))
	      (y-min (third extent))
	      (y-max (fourth extent)))
	  (do ((x x-min (1+ x)))
	      ((> x x-max))
	    (do ((y y-min (1+ y)))
		((> y y-max))
	      (unless (> (random 100) density)
		(make-unit class
			   :location (make-2d-point :x x :y y))))))))))


;;; ------------------------------------------------------------------------
;;;   World Clock
;;; ------------------------------------------------------------------------

;; There is one world-clock instance.  It records the current simulation
;; time.

(define-unit-class WORLD-CLOCK ()
  ((time :initarg :time :initform 0))
  (:generate-accessors)
  (:dimensions (time time :value-type :point))
  (:paths '(clock)))

(defmethod print-object-for-display ((clock world-clock) stream)
  (format stream "#<World Clock: ~d>"
          (if (slot-boundp clock 'time)
              (world-clock.time clock)
              "Time:?")))

(defmacro world-clock ()
  `(world-clock.time *world-clock*))

(define-ks CLOCK-KS
  :rating 100
  :ks-function 'UPDATE-CLOCK
  :trigger-events ((quiescence-event)))

(define-event-class live-event (single-unit-event)
  ()
  (:enable-event-printing nil))

(define-event-class death-event (single-unit-event)
  (cause)
  (:generate-accessors t)
  (:generate-initargs t)
  (:enable-event-printing nil))

;; Globals for statistics:
(defvar *flora-alist* nil)
(defvar *fauna-alist* nil)

(defun UPDATE-CLOCK (ksa)
  (declare (ignore ksa))
  (let ((live-animals 0)
        (newly-dead-animals 0)
        (remaining-carcasses 0)
        (max-flora-energy 0)
        (flora-energy 0)
        (world-clock (world-clock)))
    (declare (fixnum live-animals newly-dead-animals remaining-carcases))
    (setf *flora-alist* nil)
    (setf *fauna-alist* nil)
    (macrolet ((update-alist (alist type energy)
                 `(let* ((%type ,type)
                         (%energy ,energy)
                         (acons (assoc %type ,alist :test #'eq)))
                    (unless acons
                      (setf acons (list %type 0 0))
                      (push acons ,alist))
                    (incf (second acons))
                    (incf (third acons) %energy))))

      (map-units-of-class
        #'(lambda (unit)
            (let ((energy (organism.energy-level unit))
                  (max-energy (organism.maximum-energy unit)))
              (incf flora-energy energy)
              (incf max-flora-energy max-energy)
              (update-alist *flora-alist* (type-of unit) (organism.energy-level unit))
              ;; We handle flora directly rather than as KSs:
              (cond ((= energy max-energy))
                    ;; Depleted plants start slowly!
                    ((zerop energy)
                     (setf (organism.energy-level unit) 1))
                    (t (setf (organism.energy-level unit)
                             (min max-energy
                                  (+ energy (flora.regrowth-rate unit))))))))
      'flora)
      (map-units-of-class
        #'(lambda (unit)
          (let ((dead? (fauna.dead? unit)))
            (cond (dead?
                   (if (= world-clock (second dead?))
                       (incf newly-dead-animals)
                       (incf remaining-carcasses))
                   ;; Simulate decay:
                   (safe-decf (organism.energy-level unit)
                              (* .1 (organism.maximum-energy unit)))
                   ;; Check for complete decay!
                   (unless (plusp (organism.energy-level unit))
                     #+IGNORE
                     (report-decay unit)
                     (delete-unit unit)))
                  (t
                   (incf live-animals)
                   (update-alist *fauna-alist* (type-of unit) (organism.energy-level unit))
                   (signal-event 'live-event :unit unit)))))
        'fauna))
    (format *event-print-stream* "~2&;; End of Day ~S ~40,,,'=<~>" (world-clock))
    (incf (world-clock))
    (cond ((not (find-units 'fauna '(eco-system) :all))
	   ;; All animals are dead and have decayed
	   (format *event-print-stream* "~&;; All animals are dead!!!!")
	   :stop)
	  ((<= (world-clock) *max-time*)
	   (format *event-print-stream* "~&;; ~d live animal~:p:" live-animals)
           (dolist (count-item *fauna-alist*)
             (format *event-print-stream* "~&;;~10T~A~25T~4d [Energy - avg:~5d total:~7d]"
                     (first count-item)
                     (second count-item)
                     (round (third count-item) (second count-item))
                     (round (third count-item))))
	   (format *event-print-stream* "~&;; ~A animal~:p died." newly-dead-animals)
	   (format *event-print-stream* "~&;; ~A additional carcass~:[es~;~] remain."
                   remaining-carcasses (= 1 remaining-carcasses))
	   (format *event-print-stream* "~&;; Total flora energy: ~S out of ~S."
		   flora-energy max-flora-energy)
           (dolist (count-item *flora-alist*)
             (format *event-print-stream* "~&;;~10T~A~25T~4d [Energy - avg:~5d total:~7d]"
                     (first count-item)
                     (second count-item)
                     (round (third count-item) (second count-item)) 
                     (round (third count-item))))
	   (when (and *wait-every-interval*
		      (zerop (mod (world-clock) *wait-every-interval*)))
             (if (eq (pause-system) :stop)
                 :stop
               (format *event-print-stream*
                       "~2&;; Start of Day ~S ~38,,,'=<~>"
                       (world-clock)))))
	  (t
	   ;; stop if at the end of time
	   :stop))))


;;; ------------------------------------------------------------------------
;;;   Pause/Resume
;;; ------------------------------------------------------------------------

;; If ChalkBox is running, then the user can usefully examine the system
;; using the GBB graphics.  In this case it's ok to pause the control
;; shell (which puts the lisp process to sleep and prevents any user
;; interaction with the lisp process) because you can do interesting
;; things with the mouse.
;;
;; If ChalkBox is not running then the only way to interact with the
;; system is through the lisp process, so we run a little interaction
;; loop to allow the user to examine the state of the system.

(defun pause-system ()
  (cond ((chalkbox-initialized-p)
	 ;; This is required on the PC because the listener fills up.
	 #+(and :CL-ALLEGRO :OS-WINDOWS)
	 (cb::clear-lisp-listener)
         (format *query-io*
		 "~2&Pausing with World Clock at ~a...~%~@
                    To continue click the Pause/Continue button in the Control Shell Window~@
                    or select Continue Control Shell from the ChalkBox Application Menu."
		 (world-clock.time *world-clock*))
         (pause-control-shell))
        (t
         ;; No graphics. 
         (format *query-io*
                 "~2&Pausing with World Clock at ~a...~%~@
                     Hit <return> to continue.  Type :help to see other commands."
                 (world-clock.time *world-clock*))
         (wait-loop "~&Pause: "))))

(defun wait-loop (prompt)
  (let ((line nil))
    (clear-input *query-io*)
    (loop
      (setf line (get-user-input prompt))
      (cond ((eq :error line)
	     (format *query-io* "~&Command error. Please re-enter your command."))
	    ((or (eq :continue line)
		 (zerop (length line))
		 (every #'(lambda (ch) (char= ch #\space)) line))
	     (format *query-io* "~&Resuming...")
	     (return t))
	    ((not (stringp line))
	     (format *query-io* "~&Unknown command: `~a'" line))
	    ((member line '(":e" ":eval") :test #'string-equal)
	     (format *query-io* "~&Eval: ")
	     (print (kti::simple-eval (read *query-io*)) *query-io*))
	    ((member line '(":q" ":quit") :test #'string-equal)
             (return :stop))
            ((string-equal line ":r")
             (resume-event-printing))
	    ((string-equal line ":s")
             (suspend-event-printing))
            ((member line '(":h" "h" ":help" "help" ":?" "?") :test #'string-equal)
	     (format *query-io* "~& Commands:")
	     (format *query-io* "~%~5t:e     -- evaluate a lisp expression")
	     (format *query-io* "~%~5t:q     -- quit eco simulation")
	     (format *query-io* "~%~5t:r     -- resume event printing")
	     (format *query-io* "~%~5t:s     -- suspend event printing")
	     (format *query-io* "~%~5t<cr>   -- continue running"))
	    (t
	     (format *query-io* "~&Unknown command: `~a'" line))))))

;;; ------------------------------------------------------------------------

;; This function waits for the user to type a command.  It returns the
;; string the user typed or the keyword :continue.  It is only used when
;; the graphics are not running.

(defun get-user-input (prompt)
  #+(and :CL-ALLEGRO :OS-WINDOWS)
  (cb::clear-lisp-listener)
  (format *query-io* prompt)
  (string-trim '(#\space) (read-line *query-io* nil nil)))



;;; ------------------------------------------------------------------------
;;;   Grass and Trees
;;; ------------------------------------------------------------------------

(define-unit-class GRASS (flora)
  ((energy-level     :initform 30)
   (regrowth-rate    :initform  4)
   (maximum-energy   :initform 30)))

(define-unit-class TREE (flora)
  ((energy-level     :initform 150)
   (regrowth-rate    :initform  1)
   (maximum-energy   :initform 200)))

(disable-event-printing 'creation/deletion-event 'flora)

;;; ------------------------------------------------------------------------
;;;   Organism 1 --- Hyena
;;; ------------------------------------------------------------------------

(define-unit-class HYENA (carnivore)
  ((energy-level          :initform 250)
   (maximum-energy        :initform 500)
   (minimum-energy-level  :initform  50)
   (energy-dissipation    :initform  20)
   (feeding-rate          :initform  60)
   (lifespan              :initform  50)
   (move-cost             :initform   5)
   (agility               :initform   7)
   (mobility              :initform   6)
   (sensing-range         :initform   8)
   (max-dry-time          :initform  12)
   (reproduction-rate     :initform   3)
   (reproduction-cost     :initform  40)
   (minimum-reproduction-energy  :initform 60)
   (swim?                 :initform t)
   ;; Hyenas will eat anything -- even other hyenas
   (suitable-food         :initform '(fauna flora))
   (desirable-food        :initform 'rabbit)))

(defun hyena-life (ksa)
  (let ((hyena (sole-stimulus-unit ksa)))
    (multiple-value-bind (action arg)
	(select-action hyena)
      (do-action action hyena arg))))

(defmethod select-action ((hyena hyena))
  "sense the environment first: then follow this heuristics:
   - check for enemies -> move away
   - check for dead animals -> feed

   returns: action & other argument"

  (with-accessors ((location organism.location)
                   (range fauna.mobility))
                  hyena
    (let ((food (first (find-local-food hyena)))
          potential-food)
      (cond (food 
	     ;; we are ALWAYS hungry!
	     (values ':feed food))
	    ((setq potential-food (first (find-remote-food hyena)))
	     (values ':move-to (organism.location potential-food)))
	    ((and (> (fauna.age hyena) 2)
		  (> (random 10) 5))
             (values :reproduce (+ (fauna.reproduction-rate hyena) (- 2 (random 4)))))
	    (t
             (let ((new-location (random-move location range)))
               (values ':move-to
                       (if (typep (first (find-landform new-location)) 'sea)
                           (random-move location range)
                           new-location))))))))

(defun make-some-hyenas (ksa)
  (declare (ignore ksa))
  (format *event-print-stream* "~&;; Creating hyenas....")
  (dotimes (i 10)
    (make-unit 'hyena 
               :location (list (random *world-size*) 
                               (random *world-size*)))))

(define-ks hyena-ks
  :precondition-function 'organism-precondition
  :ks-function 'hyena-life
  :revalidation-predicate 'sole-stimulus-unit
  :trigger-events ((live-event hyena))
  :ksa-unit-class stimulated-ksa)

(define-ks make-some-hyenas
  :rating 90
  :ks-function 'make-some-hyenas
  :trigger-events ((start-control-shell-event))
  :ksa-unit-class stimulated-ksa)

;;; ------------------------------------------------------------------------
;;;   Organism 2 --- Rabbit  (Shares common functions with Hyena)
;;; ------------------------------------------------------------------------

(define-unit-class RABBIT (herbivore)
  ((energy-level         :initform 100)
   (maximum-energy       :initform 200)
   (minimum-energy-level :initform  20)
   (energy-dissipation   :initform  20)
   (feeding-rate         :initform  50)
   (move-cost            :initform   2)
   (lifespan             :initform  10)
   (reproduction-cost    :initform  30)
   (minimum-reproduction-energy
                         :initform 60)
   (reproduction-rate    :initform   5)
   (mobility             :initform   8)
   (agility              :initform   5)
   (max-dry-time         :initform   10)
   (suitable-food        :initform '(grass))
   (desirable-food       :initform 'grass)))


(defun rabbit-life (ksa)
  (let ((rabbit (sole-stimulus-unit ksa)))
    (multiple-value-bind (action arg)
	(select-action rabbit)
      (do-action action rabbit arg))))

(defmethod select-action ((rabbit rabbit))
  "returns: action & other argument"

  (let* ((location (organism.location rabbit))
         (range (fauna.mobility rabbit))
         local-food 
         remote-food)

    (cond ((and (< (random 10) 3)
		(< (length (find-units 'rabbit
                                       '(eco-system)
                                       `(2d-point-mixin-dvc :within ,location :delta ,5)))
                   4))
	   ;; Breed 20% of the time if there are not too many other rabbits around.
           (values :reproduce (+ (fauna.reproduction-rate rabbit) (- 2 (random 4)))))

          ((and (setq local-food (first (find-local-food rabbit)))
                (< (fauna.minimum-energy-level rabbit) (organism.energy-level local-food)))
           ;; Good food here.
           (values ':feed local-food))

          ((setq remote-food (find-remote-food rabbit))
           ;; Find more food
           (values ':move-to (organism.location (closest-organism location remote-food))))

          (t
	   ;; Without anything better to do, wander at random.
           (values ':move-to (random-move location range))))))

(defun make-some-rabbits (ksa)
  (declare (ignore ksa))
  (format *event-print-stream* "~&;; Creating rabbits....")
  (dotimes (i 10)
    (make-unit 'rabbit 
               :location (list (random *world-size*) 
                               (random *world-size*)))))

(define-ks rabbit-ks
  :precondition-function 'organism-precondition
  :ks-function 'rabbit-life
  :revalidation-predicate 'sole-stimulus-unit
  :trigger-events ((live-event rabbit))
  :ksa-unit-class stimulated-ksa)

(define-ks make-some-rabbits
  :rating 80
  :ks-function 'make-some-rabbits
  :trigger-events ((start-control-shell-event))  
  :ksa-unit-class stimulated-ksa)

;;; ------------------------------------------------------------------------
;;;   Organism 3 --- Zebra
;;; ------------------------------------------------------------------------

(define-unit-class ZEBRA (herbivore)
  ((energy-level         :initform 350)
   (maximum-energy       :initform 350)
   (minimum-energy-level :initform 100)
   (move-cost            :initform   3)
   (energy-dissipation   :initform  10)
   (max-dry-time         :initform  20)
   (lifespan             :initform  20)
   (reproduction-cycle   :initform   4)
   (reproduction-rate    :initform   2)
   (reproduction-cost    :initform  30)
   (minimum-reproduction-energy :initform 160)
   (mobility             :initform  12)
   (agility              :initform  10)
   (feeding-rate         :initform 100)
   (suitable-food        :initform '(flora))
   (desirable-food       :initform 'flora)
   (swim?                :initform t)
   (sensing-range        :initform  16)))

;; This is the KS for managing ZEBRAs.

(define-ks ZEBRA-KS
    :precondition-function 'organism-precondition
    :ks-function 'zebra-ks
    :revalidation-predicate 'sole-stimulus-unit
    :trigger-events ((live-event zebra))
    :ksa-unit-class stimulated-ksa)

(defun ZEBRA-KS (ksa)
  (let* ((zebra (sole-stimulus-unit ksa))
	 (location (organism.location zebra))
	 (range (fauna.sensing-range zebra)))
    (zebra-react zebra location range)))

;; This is the KS for creating ZEBRAs at the start of execution.

(define-ks MAKE-SOME-ZEBRAS
  :rating 80
  :ks-function 'make-some-zebras
  :trigger-events ((start-control-shell-event))
  :ksa-unit-class stimulated-ksa)

(defun MAKE-SOME-ZEBRAS (ksa)
  (declare (ignore ksa))
  (format *event-print-stream* "~&;; Creating zebras....")
  (flet ((make-n-zebras (n x y)
           ;; Make a small herd of zebras near x, y.
           (dotimes (i n)
             (make-unit 'zebra
                        :location
                        (make-2d-point
                          :x (+ x (- (random 7) 3))
                          :y (+ y (- (random 7) 3)))))))
    (make-n-zebras 10 (+ 30 (random 30)) (+ 30 (random 30)))
    (make-n-zebras  5 (+ 30 (random 30)) (+ 30 (random 30)))
    (make-n-zebras  5 (+ 30 (random 30)) (+ 30 (random 30)))))

(defun ZEBRA-REACT (zebra location range)
  
  (let ((threats (find-units
                   'carnivore
                   '(eco-system)
                   `(2d-point-mixin-dvc :within ,location :delta ,range)))
        water
	(here (organism.location zebra))
	(speed (fauna.mobility zebra)))
    
    (cond (threats
	   ;; Flee.
	   (let* ((x-here (2d-point.x here))
		  (y-here (2d-point.y here))
                  (first-threat-location (organism.location (first threats)))
		  (x-enemy (if (cdr threats)
			       (floor (+ (2d-point.x first-threat-location)
                                         (2d-point.x (organism.location (second threats))))
                                      2)
                               (2d-point.x first-threat-location)))
		  (y-enemy (if (cdr threats)
			       (floor (+ (2d-point.y first-threat-location)
                                         (2d-point.y (organism.location (second threats))))
                                      2)
			     (2d-point.y first-threat-location)))
		  (x-new (- x-here (- x-enemy x-here)))
		  (y-new (- y-here (- y-enemy y-here))))
	     (do-action :move-to zebra (list x-new y-new))))

	  ((null (setq  water (find-units
                                'water
                                '(eco-system)
                                `(2d-point-mixin-dvc :within ,location :delta ,range))))
           ;; No water in sight - quess where.
	   (do-action :move-to zebra (list (+ (first here)
					 (if (zerop (random 2))
					     speed
                                             (- speed)))
				      (+ (second here)
					 (if (zerop (random 2))
					     speed
                                             (- speed))))))

	  ((> (fauna.dry-time zebra) (* .75 (fauna.max-dry-time zebra)))
           ;; Thirsty?
           (multiple-value-bind (x-offset y-offset)
               (closest-landform-element here water)
             (do-action :move-relative zebra
			(make-2d-point :x (+ (2d-point.x here) x-offset)
				       :y (+ (2d-point.y here) y-offset)))))

	  ((and (> (fauna.age zebra) 3)
		(> (organism.energy-level zebra)
                   (fauna.minimum-reproduction-energy zebra))
		(< (random 10) 2))
           ;; Multiply and conquer
	   (do-action :reproduce zebra (fauna.reproduction-rate zebra)))

	  (t
           ;; Eat!
           (let ((distance (* 2 *world-size*))
                 (meal nil))
             ;; Find closest meal.
             (dolist (food-item (find-units
                                  'flora
                                  '(eco-system)
                                  `(2d-point-mixin-dvc :within ,location :delta ,range)))
               (let ((d (distance-between-locations here (organism.location food-item))))
                 (when (< d distance)
                   (setf meal food-item)
                   (setf distance d))))
	     (cond ((null meal)
                    ;; Nothing to eat
                    (do-action :move-to zebra (random-move here (fauna.mobility zebra))))
                   ((equal here (organism.location meal))
                    (do-action :feed zebra meal))
                   (t
                    (do-action :move-to zebra (organism.location meal)))))))))

;;; ------------------------------------------------------------------------
;;;   Organism 4 --- Lion
;;; ------------------------------------------------------------------------

(define-unit-class LION (carnivore)
  ((energy-level         :initform  500)
   (maximum-energy       :initform 1000)
   (energy-dissipation   :initform   25)
   (minimum-energy-level :initform   80)
   (feeding-rate         :initform  400)
   (move-cost            :initform    8)
   (max-dry-time         :initform   30)
   (sensing-range        :initform   15)
   (lifespan             :initform   20)
   (reproduction-cost    :initform  100)
   (reproduction-rate    :initform    2)
   (reproduction-cycle   :initform    8)
   (minimum-reproduction-energy :initform 600)
   (mobility             :initform    5)
   (agility              :initform    3)
   (suitable-food        :initform '(zebra hyena rabbit))
   (desirable-food       :initform 'zebra)))

(defun make-some-lions ()
  (let ((location '()))
    (dotimes (count 6)
      ;; Find a dry location:
      (loop
        (setq location (list (random *world-size*) (random *world-size*)))
        (unless (typep (first (find-units 'landform
                                          '(eco-system)
                                          `(2d-point-set-dvc 
                                             :overlaps (,location))))
                       'water)
          (return)))
      (make-unit 'lion 
                 :location location
                 :energy-level (+ 500 (random 200))))))

(define-ks MAKE-SOME-LIONS
  :trigger-events ((start-control-shell-event))
  :ks-function 'startup-lion-fn
  :rating 90
  :ksa-unit-class stimulated-ksa)

(defun startup-lion-fn (ksa)
  (declare (ignore ksa))
  (format *event-print-stream* "~&;; Creating lions....")
  (make-some-lions))

(define-ks LION-KS
  :precondition-function 'organism-precondition
  :ks-function 'lion-ks-function
  :revalidation-predicate 'sole-stimulus-unit
  :trigger-events ((live-event lion))
  :ksa-unit-class stimulated-ksa)

(defun LION-KS-FUNCTION (ksa)
  (let ((lion (sole-stimulus-unit ksa)))
    (multiple-value-bind (action argument)
        (lion-action lion)
      (when action
        (do-action action lion argument)))))

(defun lion-action (lion)

  (let* ((lion-location (organism.location lion))
	 (dead-food
           (find-units
             (fauna.suitable-food lion)
             '(eco-system)
             `(2d-point-mixin-dvc = ,lion-location)
	     :filter-before 'fauna.dead?))
	 (food
           (find-units
             (fauna.suitable-food lion)
             '(eco-system)
             `(2d-point-mixin-dvc
                :overlaps ,lion-location
                :delta ,(fauna.sensing-range lion))))
         (closest-food (closest-organism lion-location food)))

    (cond ((>= 2 (- (fauna.max-dry-time lion) (fauna.dry-time lion)))
           ;; Only two days left until the lion dies of thirst.
           ;; Look for water.
           (let ((water
                   (find-units
                     'water
                     '(eco-system)
                     `(2d-point-mixin-dvc
                        :within ,lion-location
                        :delta ,(fauna.sensing-range lion)))))
             (multiple-value-bind (x-offset y-offset)
                 (closest-landform-element lion-location water)
               (values :move-to
                       (if x-offset
                           (make-2d-point
                             :x (+ (2d-point.x lion-location) x-offset)
                             :y (+ (2d-point.y lion-location) y-offset))
                           (random-move lion-location (fauna.mobility lion)))))))

          ((and (> (fauna.age lion) 4)
		(> (organism.energy-level lion)
		   (* .3 (organism.maximum-energy lion)))
		(> (organism.energy-level lion)
		   (fauna.minimum-reproduction-energy lion))
		(> (random 100) 5))
	   ;; The lion is not hungry or thirsty.
	   ;; Maybe breed.
	   (values :reproduce (- 2 (random (fauna.reproduction-rate lion)))))

	  (dead-food
           ;; Food is already dead -- scavenge
           (values :feed closest-food))
	   
          ((null closest-food)
           ;; No food around -- just wander
           (values :move-to (random-move lion-location (fauna.mobility lion))))

          (t
           ;; Try to kill the closest animal.
           (values :fight closest-food)))))


;;; ------------------------------------------------------------------------
;;;   Simulation actions
;;; ------------------------------------------------------------------------

(defgeneric DO-ACTION (action-name organism other))

(defmethod DO-ACTION (action-name organism other)
  (declare (ignore other))
  ;; Catch-all method for undefined actions:
  (cerror "Ignore the action and continue."
	  "The action ~s has not been defined for ~s."
	  action-name organism))

;;; ------------------------------------------------------------------------

(defconstant *cost-of-kill* 20)

(defmethod DO-ACTION ((action (eql :fight))
                      (predator fauna)
                      (prey fauna))
  (with-accessors ((dead? fauna.dead?))
                  prey
    ;; Don't kill dead animals
    (unless dead?
      (cond ((> (fauna.agility predator) (+ -10 (random 11) (fauna.agility prey)))
             (with-accessors ((energy organism.energy-level))
                             predator
               (safe-decf energy *cost-of-kill*))
             (setf dead? (list :killed-in-fight (world-clock)))
             (report-death "~&;; ~S was killed in a fight by ~S." prey predator))
            (t
             (let ((cost (floor *cost-of-kill* 2)))
               (safe-decf (organism.energy-level predator) cost)
               (safe-decf (organism.energy-level prey) cost))
             (report-fight predator prey))))))

(defmethod DO-ACTION ((action (eql :feed))
		      (predator fauna)
		      (prey fauna))
  (with-accessors ((predator-energy organism.energy-level)
                   (maximum-energy organism.maximum-energy)
                   (predator-location organism.location))
                  predator
    (with-accessors ((prey-energy organism.energy-level)
                     (dead? fauna.dead?)
                     (prey-location organism.location))
                    prey

      (flet ((eat ()
               (let* ((energy-needed (- maximum-energy predator-energy))
                      (energy-eaten
                        (min energy-needed
                             (max (fauna.feeding-rate predator)
                                  (min energy-needed
                                       prey-energy)))))
                 (incf predator-energy energy-eaten)
                 (safe-decf prey-energy energy-eaten)
                 (format *event-print-stream*
                         "~&;; ~s eating ~a.~%;;   ~d unit~:p consumed, ~d unit~:p remain."
                         predator prey energy-eaten (max 0 prey-energy)))))
               
      (cond ((not (equal predator-location prey-location))
             ;; Must move to the location of the prey before eating.
             (do-action :move-to predator prey-location))

            ((not dead?)
             ;; Prey is not yet dead -- Must fight first.
             (do-action :fight predator prey))
            (t ;; Prey is already dead.
             (report-scavenging prey predator prey-energy)
             (eat)))))))


(defmethod DO-ACTION ((action (eql :feed))
		      (nibbler fauna)
		      (grass flora))
  (with-accessors ((energy organism.energy-level)
                   (maximum-energy organism.maximum-energy)) nibbler
    (with-accessors ((food organism.energy-level)) grass
      (let ((grass-eaten (min (- maximum-energy energy) food)))
        (incf energy grass-eaten)
        (decf food grass-eaten)
        (report-nibbling grass-eaten grass nibbler)))))

(defmethod DO-ACTION ((action (eql :move-relative))
		      (org fauna)
		      offsets)
  (let ((location (organism.location org)))
    (do-action :move-to
               org
               (make-2d-point
                 :x (+ (2d-point.x location) (2d-point.x offsets))
                 :y (+ (2d-point.y location) (2d-point.y offsets))))))

(defmethod DO-ACTION ((action (eql :move-to))
		      (org fauna)
		      new-location)
  ;; error checking
  ;; deplete resources - move cost
  (with-accessors ((locus organism.location)
                   (energy organism.energy-level)
                   (move-cost fauna.move-cost))
                  org

    (let ((x (2d-point.x locus))
          (y (2d-point.y locus))
          (new-x (2d-point.x new-location))
          (new-y (2d-point.y new-location))
          (mobility (fauna.mobility org))
          (result nil))

      ;; Check wether new positions is ok.
      (cond ((acceptable-location-p new-location)
             (safe-decf energy move-cost)
             ;; Ensure that the animal isn't moving too fast.
             (setf new-location
                   (make-2d-point
                     :x (between (- x mobility) new-x (+ x mobility))
                     :y (between (- y mobility) new-y (+ y mobility))))
             (setf locus new-location result new-location))
            (*warn-if-outside-world*
             ;; else print error message
             (let ((*print-escape* nil))
               (format *event-print-stream*
                       "~&;; The new coordinates of ~A, (~d, ~d) are outside the world~%"
                       org new-x new-y))))
      (values result))))

(defun acceptable-location-p (location)
  (and (<= 0 (2d-point.x location) *world-size*)
       (<= 0 (2d-point.y location) *world-size*)))

;;; ------------------------------------------------------------------------

(defmethod DO-ACTION ((action-name (eql :reproduce))
		      (org fauna)
		      (num-kids t))
  (let ((location (organism.location org))
	(energy-level (organism.energy-level org)))
    (when (and (> energy-level (fauna.minimum-reproduction-energy org))
               (zerop (mod (world-clock) (fauna.reproduction-cycle org))))
      (dotimes (bud-count num-kids)
        (make-unit (type-of org)
                   :location (copy-list location)))
      (report-birth org num-kids)
      (safe-decf (organism.energy-level org)
                 (* num-kids (fauna.reproduction-cost org))))))
  
;;; ------------------------------------------------------------------------
;;; Check that the organism is still alive

(defmethod DO-ACTION :around (action-name org arg)
  (cond ((fauna.dead? org)
	 (cerror "Ignore this action for this organism."
		 "~s is dead so it can't ~a."
		 org
		 action-name))
	(t
         (when *trace-actions*
           (let ((*print-escape* nil))
             (format *event-print-stream* "~&;; ~s  ~s  ~s" action-name org arg)))
	 (call-next-method))))
		 
;;; death after-method

(defmethod DO-ACTION :after
	   ((action-name t)
	    (org fauna)
	    (arg t))
  
  (unless (fauna.dead? org)
    (let ((water (find-units 'water
                             (find-spaces org)
                             `(2d-point-set-dvc :includes (,(organism.location org)))))
          (land (find-units 'land
                            (find-spaces org)
                            `(2d-point-set-dvc :includes (,(organism.location org))))))
      
      ;; Take a drink:
      (when water
        (setf (fauna.dry-time org) 0))
      
      ;; Check for death:
      (cond ((> (incf (fauna.age org)) (fauna.lifespan org))
             (setf (fauna.dead? org) (list :old-age (world-clock))))
            ((< (safe-decf (organism.energy-level org)
                           (fauna.energy-dissipation org))
                (fauna.minimum-energy-level org))
             (setf (fauna.dead? org) (list :hunger (world-clock))))
            ((> (incf (fauna.dry-time org)) (fauna.max-dry-time org))
             (setf (fauna.dead? org) (list :thirst (world-clock))))
            ((and (not land)
                  water
                  (not (fauna.swim? org)))
             (setf (fauna.dead? org) (list :drowning (world-clock))))
            (t nil))))
  
  (when (fauna.dead? org)
    (let ((cause (first (fauna.dead? org))))
      (signal-event 'death-event :unit org :cause cause)
      (report-death "~&;; ~S died of ~A." org cause))))

(defun report-birth (org num-kids)
  (let ((*print-escape* nil))
    (format *event-print-stream*
            "~&;; ~s gave birth to ~s offspring."
            org num-kids)))

(defun report-fight (predator prey)
  (let ((*print-escape* nil))
    (format *event-print-stream*
            "~&;; ~s escaped from fight with ~s."
            prey predator)))

(defun report-death (format-string org &rest args)
  ;; Remove any pending KSAs for the dead org!
  (dolist (ksa (stimulus-unit-mixin.stimulated-ksas org))
    (unless (or (ksa.execution-cycle ksa)
                (ksa.obviation-cycle ksa))
      (obviate-ksa ksa)))
  (let ((*print-escape* nil))
    (apply #'format
           *event-print-stream*
           format-string
           org
           args))
  (when *pause-on-death*
    (pause-system))
  (unless (plusp (organism.energy-level org))
    (delete-unit org)))

(defun report-decay (unit)
  (let ((*print-escape* nil))
    (format *event-print-stream*
            "~&;; ~s's remains have disappeared completely."
            unit)))

(defun report-scavenging (org eater food)
  (let ((*print-escape* nil)
        (positive-energy? (plusp (organism.energy-level org))))
    (format *event-print-stream*
            "~&;; Dead ~s is being eaten by ~s.~:[~; (~d unit~:p remain)~]"
            org
            eater
            positive-energy?
            food)
    (unless positive-energy?
      (delete-unit org))))

(defun report-nibbling (amount org eater)
  (let ((*print-escape* nil))
    (unless (zerop amount)
      (format *event-print-stream*
	      "~&;; ~s unit~:p of ~s is being eaten by ~s. ~
               (~:[depleted~;~d unit~:p remain~])"
	      amount
	      org
	      eater
	      (plusp (organism.energy-level org))
	      (organism.energy-level org)))))

;;; ------------------------------------------------------------------------
;;;   Common utility functions


(defmethod find-local-food ((animal fauna))
  ;; Return a list of the possible food items at animal's current location.
  ;; Delete the animal itself in case the species is canibalistic.
  ;; Sort the list by decreasing energy level.
  (sort
    (delete animal
            (or 
              (find-units
                (fauna.desirable-food animal)
                '(eco-system)
                `(2D-point-mixin-dvc = ,(organism.location animal)))
              (find-units
                (fauna.suitable-food animal)
                '(eco-system)
                `(2D-point-mixin-dvc = ,(organism.location animal)))))
    #'> :key #'organism.energy-level))

(defmethod find-remote-food ((animal fauna))
  ;; Returns all the possible food that the animal can see.
  (sort
    (delete animal
            (or
              (find-units
                (fauna.desirable-food animal)
                '(eco-system)
                `(2D-point-mixin-dvc :overlaps ,(organism.location animal)
                                       :delta ,(fauna.sensing-range animal)))
              (find-units
                (fauna.suitable-food animal)
                '(eco-system)
                `(2D-point-mixin-dvc :overlaps ,(organism.location animal)
                                       :delta ,(fauna.sensing-range animal)))))
    #'> :key #'organism.energy-level))

(defun find-landform (location)
  ;; Return a list of landforms at LOCATION.  There will be more that
  ;; one landform in the case that location is on the boundary between
  ;; two landforms.
  (find-units
    'landform
    '(eco-system)
    `(2D-point-set-dvc :overlaps (,location))))


(defun DISTANCE-BETWEEN-LOCATIONS (l1 l2)
  (sqrt (+ (expt (- (2d-point.x l1) (2d-point.x l2)) 2)
           (expt (- (2d-point.y l1) (2d-point.y l2)) 2))))

(defun random-move (location mobility)
  ;; Returns a new, random location based on the starting location.
  (flet ((get-random-sign ()
           (if (zerop (random 2)) -1 1)))
    (let* ((sign1 (get-random-sign))
           (sign2 (get-random-sign))
           (new-location
             (make-2d-point
               :x (+ (2d-point.x location) (* sign1 (random mobility)))
               :y (+ (2d-point.y location) (* sign2 (random mobility))))))
      (if (acceptable-location-p new-location)
          (values new-location)
          (random-move location mobility)))))

(defun closest-landform-element (location landforms)
  ;; Returns two values: the x offset and y offset (i.e., signed
  ;; numbers) of the composite element of LANDFORM that is closest to
  ;; LOCATION.
  
  (unless landforms
    (return-from closest-landform-element nil))

  (let* ((x (2d-point.x location))
         (y (2d-point.y location))
         closest-distance x-offset y-offset
         new-distance new-x-offset new-y-offset)

    (flet ((distance (rect)
             (let* ((x-min (gbb::rectangle.x-min rect))
                    (x-max (+ (gbb::rectangle.x-min rect)
                              (gbb::rectangle.length rect)))
                    (y-min (gbb::rectangle.y-min rect))
                    (y-max (+ (gbb::rectangle.y-min rect)
                              (gbb::rectangle.width rect)))
                    (x-offset
                      (cond ((< x x-min) (- x-min x))
                            ((> x x-max) (- x-max x))
                            (t 0)))
                    (y-offset
                      (cond ((< y y-min) (- y-min y))
                            ((> y y-max) (- y-max y))
                            (t 0))))
               (values (+ (abs x-offset) (abs y-offset))
                       x-offset
                       y-offset))))

      (multiple-value-setq (closest-distance x-offset y-offset)
        (distance (first (rectangle-set-mixin.extents (first landforms)))))

      (dolist (landform landforms)
        (dolist (rect (rectangle-set-mixin.extents landform))
          (multiple-value-setq (new-distance new-x-offset new-y-offset)
            (distance rect))
          (when (< new-distance closest-distance)
            (setf closest-distance new-distance)
            (setf x-offset new-x-offset)
            (setf y-offset new-y-offset))))

      (values x-offset y-offset))))


(defun closest-organism (location organisms)

  (unless organisms
    (return-from closest-organism nil))

  (let* ((closest-organism (first organisms))
         (closest-distance
           (distance-between-locations location (organism.location closest-organism)))
         new-distance)
    
    (dolist (org (rest organisms))
      (setf new-distance (distance-between-locations location (organism.location org)))
      (when (< new-distance closest-distance)
        (setf closest-organism org)
        (setq closest-distance new-distance)))
    
    (values closest-organism closest-distance)))

;;; ------------------------------------------------------------------------
;;;   End of File
;;; ------------------------------------------------------------------------