;;;; -*- Mode:COMMON-LISP; Package:ECO-EXAMPLE; Base:10 -*-
;;;; *-* File: /u7/gbb/v-400/dev/source/gbb/examples/eco-graphics.lisp *-*
;;;; *-* Edited-By: zack *-*
;;;; *-* Last-Edit: Thu Oct 21 12:24:10 1999 *-*
;;;; *-* Machine: emerald.ktiworld.com *-*

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

(in-package "ECO-EXAMPLE")

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

;; Buttons in the status window.
(defvar *clock-widget* nil)

;; These three variables will be set to the actual values after the pixmaps are created.

(defvar *max-pixmap-height* 0)
(defvar *max-pixmap-width* 0)
(defvar *erase-unit-find-adjustment*)

(defvar *legend-classes* '(lion hyena zebra rabbit grass tree))

(defvar *legend-window* nil)
(defvar *status-window* nil)

;;; ------------------------------------------------------------------------
;;;   Critter Pixmaps
;;; ------------------------------------------------------------------------

(defun make-icon (name contents &key colors)
  ;; Returns a pixmap or bitmap filled with the bits in contents.
  ;; Contents should be a nested sequence of sequences
  ;; (i.e., a list of lists).
  (let ((height (length contents))
        (width (length (elt contents 0))))
    (unless (every #'(lambda (row) (= (length row) width)) contents)
      (error "Each row in a pixmap must be the same length."))
    (make-pixmap name
                 (make-array (list height width)
                             :element-type (if colors t 'bit)
                             :initial-contents contents)
                 :depth
		 #-CG-CHALKBOX
		 (if colors (ceiling (log (length colors) 2)) 1)
		 #+CG-CHALKBOX
		 (if colors 8 1)
                 :colors colors)))

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

(defparameter *rabbit-pixmap*
    (make-icon "Rabbit"
       '((0 0 0 0 0 0 0 0 1 1 0 0 0)
	 (0 0 0 0 0 0 0 0 0 1 1 0 0)
	 (0 0 0 1 1 1 0 0 0 0 1 1 0)
	 (0 0 1 1 1 1 1 1 0 1 1 0 1)
	 (0 1 1 1 1 1 1 1 1 1 1 1 1)
	 (0 1 1 1 1 1 1 1 1 1 0 1 1)
	 (1 1 1 1 1 1 1 1 1 0 0 0 0)
	 (0 1 1 1 1 1 1 1 1 0 0 0 0)
	 (0 0 1 1 1 1 1 1 1 1 0 0 0))))

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

(defparameter *lion-pixmap*
    (make-icon "Lion"
       '( (0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
          (0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
          (0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
          (1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 0 0)
          (1 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0)
          (1 0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 0)
          (0 1 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 0 1 1 1 1)
          (0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
          (0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1)
          (0 0 1 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0)
          (0 0 1 1 1 1 1 1 1 1 1 0 1 1 1 1 0 0 1 1 1 1 0)
          (0 0 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 0 0)
          (0 1 1 1 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 1 0 0 0)
          (0 1 1 1 0 1 1 1 0 0 0 0 0 1 1 0 1 0 1 0 0 0 0)
          (0 1 1 0 0 0 1 1 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0)
          (0 1 1 0 0 0 1 1 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0)
          (0 0 1 0 0 0 0 1 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0))))

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

(defparameter *zebra-pixmap*
    (make-icon "Zebra"
       `((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0)
	 (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
	 (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0)
	 (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 2 1 1 0 0)
	 (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 0 0)
	 (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 2 1 1 1 1 1 1 1 0)
	 (0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1)
	 (0 0 0 0 1 1 1 2 1 1 2 1 1 2 1 1 2 1 2 1 1 2 1 1 1 0 0 1 1 1)
	 (0 0 0 1 1 1 1 2 1 1 2 1 1 2 1 1 2 1 2 1 1 1 1 1 0 0 0 0 1 0)
	 (0 0 1 1 1 1 2 2 1 2 2 1 1 2 1 1 2 1 2 1 1 1 0 0 0 0 0 0 0 0)
	 (0 1 1 1 1 2 2 1 1 2 1 1 2 2 1 1 2 1 1 1 1 0 0 0 0 0 0 0 0 0)
	 (0 1 0 1 1 2 1 1 1 2 1 1 2 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
	 (0 1 0 1 1 2 1 1 1 1 1 1 1 1 0 1 1 2 1 1 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 0 1 1 1 1 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 1 0 1 1 0 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 0 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 0 1 1 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 1 0 1 1 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0)
	 (1 0 1 1 0 1 1 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0)
	 (0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0)
	 (0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0)
	 (0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0))
       :colors '((0 . :none) (2 . "black") (1 . "white"))))

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

(defparameter *hyena-pixmap*
    (make-icon "Hyena"
       '((0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	 (0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	 (1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0)
	 (1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 1 0)
	 (1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0)
	 (1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 1)
	 (0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
	 (0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 1 1)
	 (0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0)
	 (0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0)
	 (0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
	 (0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
	 (0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
	 (0 1 1 1 0 1 1 1 0 0 0 1 1 1 1 1 1 1 0 0 0 0)
	 (1 1 1 0 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1 0 0 0)
	 (1 1 1 0 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1 0 0 0)
	 (0 1 1 1 0 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1 0 0))))

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

(defparameter *grass-pixmap*
    (make-icon "Grass"
       '((0 1)
         (0 1)
         (1 0)
	 (1 0)
	 (1 0)
         (1 0))))

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

(defparameter *tree-pixmap*
    (make-icon "Tree"
       '((0 0 0 0 1 1 0 0 0 0)
	 (0 0 0 0 1 1 0 0 0 0)
	 (0 0 0 0 1 1 0 0 0 0)
	 (0 0 0 1 1 1 1 0 0 0)
	 (0 0 0 1 1 1 1 0 0 0)
	 (0 0 0 1 1 2 1 0 0 0)
	 (0 0 1 1 1 1 1 1 0 0)
	 (0 0 1 1 1 1 1 1 0 0)
	 (0 0 1 2 1 1 1 1 0 0)
	 (0 1 1 1 1 1 2 1 1 0)
	 (0 1 1 2 1 1 2 2 1 0)
	 (0 1 2 1 1 1 1 1 1 0)
	 (1 1 1 1 1 1 1 2 1 1)
	 (0 0 0 0 1 1 0 0 0 0)
	 (0 0 0 0 1 1 0 0 0 0)
	 (0 0 0 0 1 1 0 0 0 0))
       :colors '((0 . :none) (1 . "Darkgreen") (2 . "Green") (3 . "Tan"))))

;;; ------------------------------------------------------------------------
;;;   Unit Color Definitions
;;; ------------------------------------------------------------------------

;; These colors aren't used for those units that are drawn using
;; multi-color pixmaps because the color is already encoded in the
;; pixmap.
(defun initialize-eco-unit-colors ()
  (cond ((member (display-type) '(:color :grayscale) :test #'eq)
	 (set-unit-color 'river     *blue*      :fill-color t)
	 (set-unit-color 'sea       *blue*      :fill-color t)
	 (set-unit-color 'marsh     *darkgreen* :fill-color t)
	 (set-unit-color 'flatland  *tan*       :fill-color t)
	 (set-unit-color 'hilly     *orange*    :fill-color t)
	 (set-unit-color 'grass     *green*)
	 (set-unit-color 'tree      *darkgreen*)
	 (set-unit-color 'lion      *red*)
	 (set-unit-color 'rabbit    *yellow*)
	 (set-unit-color 'zebra     *black*)
	 (set-unit-color 'hyena     *cyan*))
	(t
	 (set-unit-color 'landform  *white* :fill-color nil)
	 (set-unit-color 'sea       *black* :fill-color t)
	 (set-unit-color 'organism  *black*))))

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

(defun initialize-pixmap-sizes ()
  (dolist (class *legend-classes*)
    (let ((pixmap (find-pixmap (symbol-name class) nil)))
      (setf *max-pixmap-height* 
            (max *max-pixmap-height* 
                 (if pixmap (pixmap-height pixmap) 0)))
      (setf *max-pixmap-width* 
            (max *max-pixmap-width* 
                 (if pixmap (pixmap-width pixmap) 0)))))
  (setf *erase-unit-find-adjustment*
        (ceiling (max *max-pixmap-height* *max-pixmap-width*) 2)))
 
;;; ------------------------------------------------------------------------

(defun setup-eco-graphics ()
  
  ;; Startup graphics
  (unless (kti-module-loaded-p :gbb-graphics)
    (load-kti-module :gbb-graphics))
  (unless (chalkbox-initialized-p)
    (unless (initialize-chalkbox)
      (return-from setup-eco-graphics
        (values :stop "ChalkBox is not initialized."))))
  
  ;; Determine the max width & height of pixmap
  (initialize-pixmap-sizes)
  
  ;; Initialize unit-class color
  (initialize-eco-unit-colors)
  
  ;; Put this in the application menu so the user can exit easily.
  (chalkbox::add-to-application-menu
   '("Exit Ecosystem Example" . do-exit-eco-example))
	
  ;; Layout the windows
  (setup-eco-windows))

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

(defun setup-eco-windows ()
  (let* ((mouse-window-height cb::*mouse-window-height*)
	 (map-window
	  (widget-window
	   (setup-blackboard-widget :map
	      :paths '(eco-system)
	      :unit-classes '(landform flora fauna)
	      :x-dimension 'x :y-dimension 'y
	      :label "Map View"
	      :activate nil
	      :x 0 :y 0 :width 0.6 :height 0.6
	      :draw-composite-dimension-connections nil)))
	 (energy-window
	  (widget-window
	   (setup-blackboard-widget :energy
                  :paths '(eco-system)
		  :x-dimension 'age
		  :x-bounds (make-range 0 50)
		  :y-dimension 'energy-level
		  :activate nil
		  :y-bounds (make-range 0 *max-energy-level*)
		  :label "Organism Energy and Age"
		  :unit-classes '(fauna)
		  :x 0 :y .6 :width 0.6
		  :height `(.4 ,(- mouse-window-height)))))
	 (logo-width (widget-outer-width *logo-window*))
	 (logo-height (widget-outer-height *logo-window*))
	 (status-window
	  (make-eco-status-window
	   :width `(.4 ,(- logo-width)) :height .5
	   :activate nil))
	 (legend-window
	  (make-eco-legend-window
	   :x '(:right 0) :y logo-height
	   :width logo-width :height `(0.5 ,(- logo-height))
	   :activate nil))
	 (legend-window-height (widget-outer-height legend-window))
	 (cs-window-y (+ logo-height legend-window-height))
	 (cs-window-width (+ (widget-outer-width legend-window)
			     (widget-outer-width status-window))))
    (if (small-screen-p)
	(setup-eco-windows-small-layout
	 (list map-window energy-window status-window)
	 legend-window)
      (setup-eco-windows-normal-layout 
       (list map-window energy-window status-window legend-window)
       cs-window-y cs-window-width))))
	
;;; ------------------------------------------------------------------------

;;; The windows already have the approppriate sizes & positions
;;; so we simply need to activate them. On applcable platforms 
;;; we resize the listener window

(defun setup-eco-windows-normal-layout (windows cs-window-y cs-window-width)
  (mapc #'activate-widget windows)
  (let* ((cs-window (make-control-shell-window
		     :x `(:right 0) :y cs-window-y
		     :width cs-window-width
		     :initial-configuration :landscape-panel))
         (w (chalkbox::lisp-listener)))
    ;; Adjust lisp listener window (if there is one).
    (when w
      (reshape-widget 
       w
       :x '(:right 0) :y '(:bottom 0)
       :width cs-window-width
       :height (- (screen-height)
                  cs-window-y
                  (widget-outer-height cs-window))))))
 
;;; ------------------------------------------------------------------------

(defun setup-eco-windows-small-layout (windows legend-window)

  (let* ((mouse-window-width
           (min cb::*mouse-window-width*
                (floor (* 2 (screen-width)) 3)))
	 (mouse-window-height cb::*mouse-window-height*)
	 (logo-height (widget-outer-height *logo-window*))
	 (legend-window-height (widget-outer-height legend-window))
	 (chain-manager-width (- (screen-width) mouse-window-width))
	 (chain-manager
	  (cb::setup-window-chain windows
            ;; Position & size of the windows in the chain
            :x 0 :y 0
            :width mouse-window-width
            :height `(1.0 ,(- (+ legend-window-height cb::*mouse-window-height*)))
            ;; Initial position & size of the chain manager window itself
            :chain-manager-x '(:right 0)
            :chain-manager-y (1+ logo-height)
            :chain-manager-width chain-manager-width))
	 (chain-manager-height (widget-outer-height chain-manager))
	 (cs-window-y (+ logo-height chain-manager-height)))

    (gg::make-control-shell-window
     :x `(:right 0) :y cs-window-y :width chain-manager-width
     :initial-configuration :landscape-panel)
 
    (reshape-widget legend-window
                    :x 0
		    :y `(:bottom ,mouse-window-height)
		    :width mouse-window-width)
    (activate-widget legend-window)
    (let ((w (chalkbox::lisp-listener)))
      ;; Adjust lisp listener window (if there is one).
      (when w
        (reshape-widget 
          w
          :x `(:right 0)
          :y `(:bottom 0)
          :width `(1.0 ,(- mouse-window-width))
          :height `(1.0 ,(- (+ logo-height chain-manager-height))))))
    t))
   
;;; ---------------------------------------------------------------------------

(defun do-exit-eco-example ()
  (gbb-graphics::delete-all-bb-windows)
  (when (exists-window *control-shell-window*)
    (delete-widget *control-shell-window*))
  (when (exists-window *status-window*)
    (delete-widget *status-window*))
  (when (exists-window *legend-window*)
    (delete-widget *legend-window*))
  (chalkbox::delete-from-application-menu
    '("Exit Eco Example" . do-exit-eco-example))
  (control-shells::exit-control-shell))

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

(defmethod DRAW-UNIT ((unit organism) widget x y
                      &key foreground-color
		      &allow-other-keys) 
  (let* ((dead? (and (typep unit 'fauna) (fauna.dead? unit)))
	 (pixmap (find-pixmap (symbol-name (type-of unit))))
	 (pixmap-width (pixmap-width pixmap))
	 (pixmap-height (pixmap-height pixmap)))
    (cond (pixmap
           (multiple-value-bind (x y width height)
               (determine-scaled-pixmap-dimensions pixmap widget x y)
             (unless foreground-color
               (setf foreground-color *black*))
	     (draw-pixmap widget pixmap x y
			    :foreground-color foreground-color
			    :background-color nil
			    :source-width  pixmap-width 
			    :source-height pixmap-height 
                            ;; Note, ACLW doesn't always shrink bitmaps correctly.
			    :destination-width (max width #+(and :CL-ALLEGRO :OS-WINDOWS) pixmap-width)
			    :destination-height (max height #+(and :CL-ALLEGRO :OS-WINDOWS) pixmap-height)
			    :scale-p t)
             (when (and dead?
                        (let* ((x-dimension (blackboard-widget-axis-attributes widget :x))
                               (y-dimension (blackboard-widget-axis-attributes widget :y)))
                          (and (member x-dimension '(:x :y) :test #'eq)
                               (member y-dimension '(:x :y) :test #'eq))))
               (let* ((size (-& (min& width height) 2))
                      (x (+& x (floor& (-& width size) 2)))
                      (y (+& y (floor& (-& height size) 2))))
                 (draw-line widget x y (+& x size) (+& y size)
                            :foreground-color *darkgray*
                            :thickness 2)
                 (draw-line widget x  (+& y size) (+& x size) y
                            :foreground-color *darkgray*
                            :thickness 2)))))                 
	  (t
	   (call-next-method)))))

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

;; ERASING

;; Simply erase animals because drawing the units under the animals
;; would redraw the landform which would have the effect of overwriting
;; any animals that overlap the landform not the animal being erased.

(defmethod ERASE-UNIT-ACTION ((obj fauna) (widget t))
  :erase)

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

(defmethod ERASE-UNIT ((unit organism) widget x y
                       &key foreground-color
                       &allow-other-keys) 
  (let* ((pixmap (find-pixmap (symbol-name (type-of unit))))
         #+(and :CL-ALLEGRO :OS-WINDOWS)
         (pixmap-width (pixmap-width pixmap))
         #+(and :CL-ALLEGRO :OS-WINDOWS)
         (pixmap-height (pixmap-height pixmap)))
    (cond (pixmap
           (multiple-value-bind (x y width height)
               (determine-scaled-pixmap-dimensions pixmap widget x y)
             (unless foreground-color
               (setf foreground-color *black*))
             ;; Note, ACLW doesn't always shrink bitmaps correctly.
	     (erase-pixmap widget pixmap x y
                           :foreground-color foreground-color
                           :source-width (pixmap-width pixmap)
                           :source-height (pixmap-height pixmap)
                           :destination-width (max width #+(and :CL-ALLEGRO :OS-WINDOWS) pixmap-width)
                           :destination-height (max height #+(and :CL-ALLEGRO :OS-WINDOWS) pixmap-height)
                           :scale-p t)))
	  (t
	   (call-next-method)))))

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

(defmethod ERASE-UNIT ((obj fauna) widget x y &rest args)
  (declare (ignore args))
  (let* ((x-dimension (blackboard-widget-axis-attributes widget :x))
	 (y-dimension (blackboard-widget-axis-attributes widget :y)))
    (cond ((and (member x-dimension '(:x :y) :test #'eq)
                (member y-dimension '(:x :y) :test #'eq))
           (multiple-value-bind (x y width height)
               (eco-unit-drawing-size obj widget x y)
             (let ((x1 (x-pixel-to-world widget (-& x *erase-unit-find-adjustment*)))
                   (x2 (x-pixel-to-world widget (+& x width *erase-unit-find-adjustment*)))
                   (y1 (y-pixel-to-world widget (-& y *erase-unit-find-adjustment*)))
                   (y2 (y-pixel-to-world widget (+& y height *erase-unit-find-adjustment*))))
               (when (< x2 x1)
                 (rotatef x1 x2))
               (when (< y2 y1)
                 (rotatef y1 y2))
               (with-graphics-buffering 
                   (with-clipping-region (widget x y width height)
                     (gg::refresh-bb-widget-contents 
                      widget 
                      :pattern (gg::build-find-pattern
                                widget 
                                (make-range (max x1 0) (min x2 *world-size*))
                                (make-range (max y1 0) (min y2 *world-size*)))
                      :exclude-units obj
                      :mouse-cursor nil
                      :clip-to-widget? nil
                      :clear-first? nil))))))
          (t
           (call-next-method)))))

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

(defmethod ECO-UNIT-DRAWING-SIZE ((unit t) widget x y)
  (declare (ignore widget))
  (values (1-& x) 3 (1-& y) 3))

(defmethod ECO-UNIT-DRAWING-SIZE ((unit organism) widget x y)
  (let ((pixmap (find-pixmap (symbol-name (type-of unit)) nil)))
    (if pixmap
        (determine-scaled-pixmap-dimensions pixmap widget x y)
        (values (1-& x) 3 (1-& y) 3))))

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

(defun determine-scaled-pixmap-dimensions (pixmap widget x y)
  ;; Determine how big to draw the pixmap.  The pixmap height is used as
  ;; an indicator of how big the image should appear in `world' terms.
  ;; The height in pixels is then scaled to make the image appear that
  ;; big given what portion of the world is being displayed.
  ;; Returns the desired x, y, width & height of the scaled bitmap.
  (cond ((and (member (blackboard-widget-axis-attributes widget :x) '(:x :y) :test #'eq)
              (member (blackboard-widget-axis-attributes widget :y) '(:x :y) :test #'eq))
         (let* ((y-range
                 (nth-value 2 (blackboard-widget-axis-attributes widget :y)))
                (height
                 (max& 2
                       (round
                        (* (/ (pixmap-height pixmap) 5)
                           (/ (widget-inner-height widget)
                              (- (range-end y-range) (range-start y-range)))))))
                (width
                 (max& 2
                       (floor& (*& (pixmap-width pixmap) height)
                               (pixmap-height pixmap)))))
           (values (-& x (floor& width 2)) (-& y (floor& height 2)) width height)))
        (t
         (let ((width (pixmap-width pixmap))
               (height (pixmap-height pixmap)))
           (values (-& x (floor& width 2)) (-& y (floor& height 2)) width height)))))

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

(defclass eco-status-window (auto-layout-mixin window)
  ())

(defun make-eco-status-window (&key (x `(:right ,(widget-outer-width *logo-window*)))
				    (y 0)
				    (width 240)
				    (height 400)
				    (activate t))

  ;; Create status window if there isn't one already.
  (unless (and (typep *status-window* 'window)
               (not (widget-deleted-p *status-window*)))

    (let ((background (if (eq (display-type) :monochrome) *white* *lightgray*))
	  (margin 8)
	  (graph-margin-font "Small")   
	  (graph-types-menu
	   (cb::make-combined-scrolling-line-graph-types-menu)))
      

      (setf *status-window*
            (make-window 'eco-status-window :activate activate
                         :x x :y y :width width :height height
                         :font cb::*menu-subtitle-font*
                         :label "World Status"
                         :background-color background))

      (unless (find-widget *status-window* 'animal-population)
        (multiple-value-bind (widgets parent widget-layout)
            (layout-widgets
              `(((:clock text-widget
                      :value "Day 0"
                      :width ,(floor (widget-inner-width *status-window*) 2)
                      :height ,(+ 12 (font-height "clock"))
		      :auto-height-p nil
                      :foreground-color "black"
                      :background-color ,background
                      :font "clock"
                      :text-alignment :center
                      :border-size 0)
                 :center)
                (animal-population scrolling-line-graph
                    :label "Animal Population"
                    :min 0 :max 50 :rescale-p :max
		    :shift-width 10
		    :margin-font ,graph-margin-font
		    :graph-types-menu ,graph-types-menu)
		(animal-energy scrolling-line-graph
                    :label "Animal Energy"
                    :min 0 :max 500 :rescale-p :max
		    :shift-width 10
		    :margin-font ,graph-margin-font
		    :graph-types-menu ,graph-types-menu)
		(plant-energy scrolling-line-graph
                    :label "Plant Energy"
		    :min 0 :max 200 :rescale-p :max
		    :shift-width 10
		    :margin-font ,graph-margin-font
		    :graph-types-menu ,graph-types-menu))
	      :parent *status-window*
              :margin margin
              :height height)
          (declare (ignore widgets parent))
          (setf (cb::window-widget-layout *status-window*) widget-layout)))))

  (setf *clock-widget*
    (find-widget *status-window* :clock))
  (setf (widget-font *clock-widget*) "clock")
  (when activate
    (activate-widget *status-window*))
  *status-window*)

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

(defun initialize-clock-widget-stuff ()
  (make-font "Clock"
             '("-adobe-helvetica-medium-r-normal--24-240-75-75-p-130-iso8859-1"
               "-adobe-helvetica-medium-r-normal--17-120-100-100-p-88-iso8859-1"
               "-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1"
               "-adobe-helvetica-medium-r-normal--20-140-100-100-p-100-iso8859-1"
               "-adobe-helvetica-medium-r-normal--14-140-75-75-p-77-iso8859-1"
               "-adobe-helvetica-medium-r-normal--25-180-100-100-p-130-iso8859-1"
               "-adobe-helvetica-medium-r-normal--34-240-100-100-p-176-iso8859-1"
               #+CL-MCL ("Geneva" 14 :plain)
	       #+(and :CL-ALLEGRO :OS-WINDOWS) (:swiss |:MS SANS SERIF| 30 (:bold))
               (:sans-serif 24 :bold))))

(if (chalkbox-initialized-p)
    (initialize-clock-widget-stuff)
    (pushnew 'initialize-clock-widget-stuff *initialize-chalkbox-hooks*))

(defun update-clock-widget (&optional (world-clock *world-clock*))
  (when (and (typep *clock-widget* 'widget)
	     (widget-activated-p *clock-widget*))
    (setf (widget-text *clock-widget*)
          (format nil "Day ~d"
                  (if world-clock
                      (world-clock.time world-clock)
                      0)))
    (refresh-widget *clock-widget*)))

(defun update-clock-event-handler (event-name &key unit &allow-other-keys)
  (declare (ignore event-name))
  (update-clock-widget unit))

(add-event-function 'update-clock-event-handler 'slot-update-event 'world-clock 'time)
(add-event-function 'update-clock-event-handler 'creation-event 'world-clock)


 
;;;--------------------------------------------------------------------------;;; 
;;;  ECO LEGEND WINDOW
;;;--------------------------------------------------------------------------;;; 

(defclass eco-legend-window (window)
  ())
	
(defclass eco-legend-widget (textscroll-widget)
  ())
 
;;;--------------------------------------------------------------------------;;; 

(defun make-eco-legend-window (&key (x '(:right 1))
				    (y .2)
				    (width '(:inner 130))
				    (height '(:inner 200))
				    (activate t))

  (unless (cb::exists-window *legend-window*)
    (setf *legend-window*
	  (make-window 'eco-legend-window
		       :label "Legend" :activate activate
		       :x x :y y :width width :height height 
		       :font "Large" :foreground-color *black*
		       :background-color *lightgray*))
    (let ((inner-height (+ 12 *max-pixmap-height*)))
      (when (small-screen-p)
	(reshape-widget *legend-window* :height `(:inner ,inner-height)))))
  *legend-window*)

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

;;; Create the eco legend widget as a result of creating the eco
;;; legend window:

(defmethod initialize-instance :after ((window eco-legend-window) &key)
  ;; Make the eco legend widget
  (make-widget 'eco-legend-widget :label nil
     :item-list 
     (mapcar #'(lambda (class)
		 (list (symbol-name class) :value class
		       :font "normal"
		       :no-select t))
	     *legend-classes*)
     :parent window :item-vertical-alignment :spread
     :x 0.0 :y 0.0 :width 1.0 :height 1.0))
 
;;;----------------------------------------------------------------------;;;

;;; We define this after method so that if the window gets
;;; interactively resized, the displayed contents will look
;;; reasonable

(defmethod handle-reshape-widget :after ((window eco-legend-window))
  (let ((widget (first (widget-children window))))
    (when widget
      (let* ((width (widget-outer-width widget))
	     (height (widget-outer-height widget)))
	(if (> width height)
	  (progn
	    (setf (widget-item-vertical-alignment widget) :top)
	    (setf (widget-item-horizontal-alignment widget) :spread)
	    (setf (widget-layout widget) :horizontal))
	  (progn
	    (setf (widget-item-vertical-alignment widget) :spread)
	    (setf (widget-item-horizontal-alignment widget) :left)
	    (setf (widget-layout widget) :vertical)))))))

;;;--------------------------------------------------------------------------;;; 
;;;  ECO LEGEND WIDGET
;;;--------------------------------------------------------------------------;;; 

(defmethod eco-widget-additional-width ((widget eco-legend-widget) item)
  (if (eq (widget-layout widget) :vertical)
    (+ 25 *max-pixmap-width*)
    (let* ((class (item-value item))
	   (pixmap (find-pixmap (symbol-name class) nil)))
      (+ 3 (if pixmap (pixmap-width pixmap) 0)))))

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

(defmethod eco-widget-additional-height ((widget eco-legend-widget) item)
  (let ((pixmap (find-pixmap (symbol-name (item-value item)) nil)))
    (if pixmap
       (pixmap-width pixmap)
      0)))
 
;;;--------------------------------------------------------------------------;;;

(defmethod cb::draw-item ((widget eco-legend-widget) item x y width height selected-p)
  (let* ((additional-width (eco-widget-additional-width widget item))
	 (additional-height (eco-widget-additional-height widget item))
	 (class (item-value item))
	 (color (get-unit-color class nil))
	 (pixmap (find-pixmap (symbol-name class) nil))
	 (font-height (font-height (widget-font widget)))
	 (layout (widget-layout widget))
	 (pixmap-y y)
	 (label-x x)
	 (label-y y))
    (if (eq layout :vertical)
      ;; Vertical layout: center labels next pixmap
      (progn
	(incf label-x additional-width)
	(incf label-y (floor (max 0 (- additional-height font-height)) 2)))
      ;; Horizontal layout: align all labels & pixmap
      (progn
	(incf label-x (+ 3 (pixmap-width pixmap)))
	(incf label-y (max 0 (- *max-pixmap-height* font-height)))
	(incf pixmap-y (max 0 (- *max-pixmap-height* (pixmap-height pixmap))))))
    ;; Let default method draw the item label
    (call-next-method widget item
		      ;; x position of label
		      label-x
		      ;; y position of label
		      label-y
		      ;; width & height
		      (- width (pixmap-width pixmap)) height
		      selected-p)
    ;; Draw the pixmap or a box
    (draw-pixmap widget pixmap  x pixmap-y
           :foreground-color color
	   :background-color (widget-background-color widget))))

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

(defmethod cb::widget-item-width ((widget eco-legend-widget) &optional item)
  (if (or (eq (widget-layout widget) :vertical)
	  (not item))
    (call-next-method)
    (cb::compute-item-width item (cb::item-label item) widget)))

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

(defmethod cb::compute-item-width (item label (widget eco-legend-widget))
  (if (eq (widget-layout widget) :vertical)
    (+ (call-next-method)
       (eco-widget-additional-width widget item))
    (+ (string-width label (widget-font widget))
       (eco-widget-additional-width widget item))))
 
;;;----------------------------------------------------------------------;;;

(defmethod cb::compute-item-height (item label (widget eco-legend-widget))
  (declare (ignore label))
  (max (call-next-method)
       (eco-widget-additional-height widget item)))
      
;;; ------------------------------------------------------------------------
;;;   ECO Status Window Summary Graphs
;;; ------------------------------------------------------------------------

(defvar *fauna-units*
    '(rabbit zebra hyena lion))

(defvar *plant-units*
    '(grass tree))

(defun update-eco-summary-graphs-event-handler (event-name &key &allow-other-keys)
  (declare (ignore event-name))
  (when (chalkbox-initialized-p)
    (update-eco-summary-graphs)))

(defun update-eco-summary-graphs ()

  (when (and (chalkbox-initialized-p)(cb::exists-window *status-window*))
    (let ((animals (mapcar #'(lambda (x)(list x 0 0)) *fauna-units*))
	  (plants (mapcar #'(lambda (x)(list x 0 0)) *plant-units*))
	  (animal-population (find-widget *status-window* 'animal-population))
	  (animal-energy (find-widget *status-window* 'animal-energy))
	  (plant-energy (find-widget *status-window* 'plant-energy)))

      (flet ((add-amount (dimension amount type list)
	       (let ((record (assoc type list :test #'eq)))
		 (unless record
		   (setf record (list type 0 0))
		   (push record list))
		 (incf (nth dimension record) amount)
		 list)))

      (map-units-of-class
        #'(lambda (unit)
            (let ((unit-type (type-of unit))
                  (energy (organism.energy-level unit)))
              (typecase unit
                (fauna
                 (unless (fauna.dead? unit)
                   (setf animals (add-amount 1 1 unit-type animals))
                   (setf animals (add-amount 2 energy unit-type animals))))
                (flora
                 (setf plants (add-amount 1 1 unit-type plants))
                 (setf plants (add-amount 2 energy unit-type plants))))))
        'organism)

      (dolist (record animals)
        (setf (graph-widget-history-color animal-population (first record))
              (or (get-unit-color (first record) nil) *black*))
        (setf (graph-widget-history-color animal-energy (first record))
              (or (get-unit-color (first record) nil) *black*)))

      (dolist (record plants)
        (setf (graph-widget-history-color plant-energy (first record))
              (or (get-unit-color (first record) nil) *black*)))

      (update-scrolling-line-graph
        animal-population animals
        :value-accessor #'second)
      (update-scrolling-line-graph
        animal-energy animals
        :value-accessor #'(lambda (x) (let ((population (second x)))
                                        (if (plusp population)
                                            (floor (third x) (second x))
                                            0))))
      (update-scrolling-line-graph
        plant-energy plants
        :value-accessor #'(lambda (x) (let ((population (second x)))
                                        (if (plusp population)
                                            (floor (third x) (second x))
                                            0))))))))

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

(defun reset-eco-summary-graphs-event-handler (event-name &rest args)
  (declare (ignore event-name args))
  (reset-eco-summary-graphs))

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

(defun reset-eco-summary-graphs ()
  (when (cb::exists-window *status-window*)
	(let ((animal-population-graph (find-widget *status-window* 'animal-population))
	  (animal-energy-graph (find-widget *status-window* 'animal-energy))
	  (plant-energy-graph (find-widget *status-window* 'plant-energy)))
      (when animal-population-graph
        (reset-widget animal-population-graph))
      (when animal-energy-graph
        (reset-widget animal-energy-graph))
      (when plant-energy-graph 
        (reset-widget plant-energy-graph)))))

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

(add-event-function 'update-eco-summary-graphs-event-handler
		    'slot-update-event 'world-clock 'time)
(add-event-function 'reset-eco-summary-graphs-event-handler
		    'start-control-shell-event)

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