;;;; -*- Mode:LISP; Syntax:COMMON-LISP; Package:ELEVATOR-EXAMPLE; Base:10 -*-
;;;; *-* File: /u7/gbb/v-400/dev/source/gbb/examples/elevator-example-graphics.lisp *-*
;;;; *-* Edited-By: kevin *-*
;;;; *-* Last-Edit: Tue Mar 16 15:55:18 1999 *-*
;;;; *-* Machine: obsidian.bbtech.com *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *       ELEVATOR CONTROLLER/SIMULATOR PROBLEM (GRAPHICS MODIFICATIONS)
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Load this file if viewing the elevator example application using GBB's 
;;; graphics facilities.
;;;
;;; Written by: Participants in
;;;             ``Implementing Blackboard Applications''
;;;             Amherst, Massachusetts, March 25-27, 1992
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  03-27-92 File created.
;;;  09-18-98 Converted to GBB V4.0.  (Cork)
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

(in-package "ELEVATOR-EXAMPLE")

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

;; The colors are initialized below.
(defvar *elevator-window-background-color*)
(defvar *elevator-window-foreground-color*)

;; These variables are used by the status window, defined below.
(defvar *status-window* nil)

;; Size of the elevator cab in pixels.
(defvar *elevator-cab-size* 10)

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

;; Fonts...

(defparameter *FLOOR-FONT-SPECS*
  '(#+OS-UNIX  "-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1"
    #+OS-UNIX  "-adobe-helvetica-medium-r-normal--8-80-75-75-p-46-iso8859-1"
    #+OS-UNIX  "-adobe-helvetica-medium-r-normal--11-80-100-100-p-56-iso8859-1"
    #+OS-UNIX  "-schumacher-clean-medium-r-normal--10-100-75-75-c-60-iso8859-1"
    #+CL-MCL   ("Geneva" 9 :plain)
    (:serif 8 :oblique :bold)
    (:sans-serif 8 :oblique :bold)
    (:serif 9 :oblique :bold)
    (:sans-serif 9 :oblique :bold)))

(defparameter *floor-font*
   (make-font "Floor Font" *floor-font-specs*))

(defvar *floor-font-height*)
(defvar *floor-font-width*)

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

(defvar *clock-widget-font* nil)

;;; ---------------------------------------------------------------------------
;;;   Startup function
;;; ---------------------------------------------------------------------------

;; This is the top level function to set up the elevator graphics display.

(defun STARTUP-GRAPHICS ()
  ;; Startup graphics
  (unless (kti-module-loaded-p :gbb-graphics)
    (load-kti-module :gbb-graphics))
  (unless (chalkbox-initialized-p)
    (unless (initialize-chalkbox)
      (return-from startup-graphics
        (values :stop "ChalkBox is not initialized."))))
  (multiple-value-setq (*floor-font-height* *floor-font-width*)
    (font-dimensions *floor-font*))
  ;; Setup the windows
  (setup-elevator-windows))

;;; ---------------------------------------------------------------------------
;;;   Customized unit methods
;;; ---------------------------------------------------------------------------

;; Elevator Cab:
;;
;; The elevator cabs are drawn as a partially filled rectangle with the
;; floor number drawn below it.  The amount of fill indicates how full
;; the elevator is.  The color indicates its state (doors open, moving
;; up, moving down, etc.).

(defmethod DRAW-UNIT ((obj cab) widget x y &key foreground-color &allow-other-keys)
  
  (let* ((box-size *elevator-cab-size*)
         (box-size/2 (floor box-size 2))
         (box-left (- x box-size/2))
         (box-top (- y box-size/2))
         (box-bottom (+ y box-size/2))
         (fill-size (round (* (- box-size 2)
                              (/ (cab.current-weight obj)
                                 (elevator-spec.capacity (cab.elevator-spec obj)))))))
    
    ;; Outline of the cab.
    (draw-rectangle widget box-left box-top box-size box-size
                    :foreground-color foreground-color)

    ;; The weight histogram.
    (draw-rectangle widget box-left (- box-bottom fill-size 1)
                    box-size fill-size
                    :foreground-color foreground-color :fill-color t)

    ;; Show the floor number under the cab.
    (draw-string widget 
                 (princ-to-string (cab.current-floor obj))
                 x box-bottom
                 :font *floor-font*
                 :placement :top
                 :justification :center)))

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

(defmethod ERASE-UNIT ((obj cab) widget x y &key foreground-color &allow-other-keys)
  ;; Draw a filled rectangle to erase the elevator.
  (let* ((box-size *elevator-cab-size*)
         (box-width (max box-size (* 2 *floor-font-width*)))
         (box-height (+ box-size *floor-font-height*)))
    (draw-rectangle widget
                        (- x (ceiling box-width 2))
                        (- y (floor box-size 2))
                        box-width box-height
			:foreground-color foreground-color :fill-color t)))

;; This method handles the case where the unit argument is a symbol
;; naming the class.
(defmethod default-unit-color ((obj t) (widget t))
  *black*)

(defmethod default-unit-color ((cab cab) (widget t))
  (if (eq :color (display-type))
      (ecase (cab.status cab)
        (:stopped        *blue*)
        (:doors-open     *purple*)
        (:moving-up      *darkgreen*)
        (:moving-down    *red*)
        (:out-of-service *yellow*))
      *black*))

(set-unit-color 'cab #'default-unit-color)

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

;; Floor and Call buttons:
;;
;; Both the floor buttons within the elevator and call buttons on each
;; floor are drawn as small squares.  On a color display lit buttons
;; are drawn in yellow.  On a black and white display lit buttons they
;; are drawn as slightly larger hollow squares.

(defmethod DRAW-UNIT ((obj basic-button-spec) widget x y
                      &key foreground-color fill-color dot-size
                      &allow-other-keys)
  ;; Draw a floor button.  Lit buttons are drawn yellow on color
  ;; machines and as a hollow square on monochrome and grayscale.
  (when (and (button-spec.lit? obj)
	     (not (eq :color (display-type))))
    (incf dot-size 2))
  (draw-button widget x y dot-size foreground-color fill-color))

(defmethod ERASE-UNIT-ACTION ((obj basic-button-spec) (widget t))
  :erase)

(defmethod ERASE-UNIT ((obj basic-button-spec) widget x y
		       &key foreground-color dot-size &allow-other-keys)
  ;; To erase a button draw the larger button and assume that
  ;; there's no overlap between buttons.
  (draw-button widget x y (+ dot-size 2) foreground-color))

(defun DRAW-BUTTON (widget x y size color &optional (fill-color t))
  ;; Draw a square centered on X,Y representing a floor button.
  (let ((offset (floor size 2)))
    (draw-rectangle widget (- x offset) (- y offset) size size
                    :foreground-color color :fill-color fill-color)))
  
(defmethod default-unit-color ((obj floor-button-spec) (widget t))
  (if (button-spec.lit? obj)
      (if (eq :color (display-type))
          (values *yellow* t)
          (values *black* :background-color))
      (values *black* t)))

(set-unit-color 'floor-button-spec #'default-unit-color)

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

;; Call buttons:
;;
;; The following methods slightly modify the basic button drawing methods.
;;
;; In most views each pair of up and down buttons would occupy the same
;; location on the widget.  For a more visually appealing display, we
;; cheat here and draw the square representing the button a bit to the
;; left or right of the actual location.

(defmethod button-offset ((obj call-button-spec))
  (case (call-button-spec.direction obj)
    ;; Draw a bit to the left
    (:up -4)
    ;; Draw a bit to the right
    (:down 4)
    ;; this should never happen...
    (t 12)))

(defmethod DRAW-UNIT ((obj call-button-spec) widget x y &rest args)
  (apply #'call-next-method obj widget (+ x (button-offset obj)) y args))

(defmethod ERASE-UNIT-ACTION ((obj call-button-spec) (widget t))
  :erase)

(defmethod ERASE-UNIT ((obj call-button-spec) widget x y
		       &key foreground-color dot-size &allow-other-keys)
  (draw-button widget (+ x (button-offset obj)) y (+ dot-size 2) foreground-color))

(defmethod default-unit-color ((obj call-button-spec) (widget t))
  (if (button-spec.lit? obj)
      (if (eq :color (display-type))
          (values
            (case (call-button-spec.direction obj)
              (:up   *green*)
              (:down *red*)
              (t     *black*))
            t)
          (values *black* :background-color))
      (values *black* t)))

(set-unit-color 'call-button-spec #'default-unit-color)

;;; ---------------------------------------------------------------------------
;;;   Window Layout
;;; ---------------------------------------------------------------------------

(defun SETUP-ELEVATOR-WINDOWS ()

  #+OS-LINUX (declare (optimize (speed 0) (safety 3)))

  (setup-elevator-colors)

  ;; Put this in the application menu so the user can exit easily.
  (add-to-application-menu
   '("Exit Elevator Example" . do-exit-elevator-example))
	
  (labels ((setup (window paths x-dim y-dim label x-pos y-pos width height &rest args)
             (widget-window 
	      (apply #'setup-blackboard-widget window
		     :label label :paths paths :activate nil
		     :x-dimension x-dim :y-dimension y-dim
		     :x x-pos :y y-pos :width width :height height
		     :foreground-color *elevator-window-foreground-color*
		     :background-color *elevator-window-background-color*
		     :font "normal" :margin-font "normal"
		     args))))
           
    (let* ((w1 0.25)  ;; Width of the elevator and floor button windows
           (h1 0.55)  ;; Height of the elevator, floor button and call button windows
           (w3 0.15)  ;; Width of the call button window
	    ;; Width of the two plan windows
	   (w4 (/ (+ w1 w1 w3) 2))
	   ;; Height of the two plan windows
	   (h4 (- 1 h1
                  (/ chalkbox::*mouse-window-height* (screen-height))))
	   (win1
	    ;; Elevator position window:
	    (setup 1 '(simulator cabs) 'elevator-spec 'floor
		   "Elevator Positions"   0 0 w1 h1
		   :other-dimensions '(:weight :status)
		   :y-bounds (make-range -5 40)))
	   (win2
	    ;; Floor button window:
	    (setup 2 '(building-info floor-button-specs) 'elevator-spec 'floor
		   "Floor Buttons"   w1 0 w1 h1
		   :other-dimensions '(:lit?)
		   :y-bounds (make-range -5 40)))
	   (win3
	    ;; Call button window:
	    (setup 3 '(building-info call-button-specs) :bank-spec :floor
		   "Call Buttons"   (* 2 w1) 0 w3 h1
		   :other-dimensions '(:lit?)
		   :y-bounds (make-range -5 40)))
	   (win4
	    ;; Plan for elevator "A":
	    ;; This is located below the elevator and elevator button
	    ;; windows, so its Y position is the height of the elevator
	    ;; window.  Its X position is zero (at the left edge of the
	    ;; screen).  Its width is calculated to be half the combined
	    ;; width of windows 1, 2 and 3.
	    (setup 4 '(planner tasks) :time-interval :task-type
		   "Planned Tasks for A" 0 h1 w4 h4
		   :x-bounds (make-range 0 400)
		   :filter-function
		   #'(lambda (unit widget)
		       (declare (ignore widget))
		       (if (typep unit 'task)
                           (and (task.elevator-spec unit)
                                (string= "A" (unit-name (task.elevator-spec unit))))
                           t))))
	   (win5
	    ;; Plan for elevator "E":
	    ;; As with the previous window, this one is located below the
	    ;; elevator button windows and call button windows, so its Y
	    ;; position is the height of the elevator window.  It is to the
	    ;; right of window 4, so its X position is the width of window
	    ;; 4.  Its width is calculated to be half the combined width of
	    ;; windows 1, 2 and 3.
	    (setup 5 '(planner tasks) :time-interval :task-type
		   "Planned Tasks for E"  w4 h1 w4 h4
		   :x-bounds (make-range 0 400)
		   :filter-function
		   #'(lambda (unit widget)
		       (declare (ignore widget))
                       (if (typep unit 'task)
                           (and (task.elevator-spec unit)
                                (string= "E" (unit-name (task.elevator-spec unit))))
                           t)))))

      ;; Layout the windows differently depending on whether we have
      ;; a high resolution screen or not:
      (cond ((chalkbox::small-screen-p)
	     (setup-elevator-windows-small-layout 
	      (list  win1 win2 win3 win4 win5)))
	    (t
	     (setup-elevator-windows-normal-layout 
	      (list  win1 win2 win3 win4 win5)
	      ;; Status window x position
	      (+ (* 2 w1) w3)))))))
	 			
;;; ---------------------------------------------------------------------------

;;; We use this layout for high resolution screens. The various
;;; blackboard windows are tiled on the screen. The x position is
;;;  for the status window

(defun SETUP-ELEVATOR-WINDOWS-NORMAL-LAYOUT (bb-windows status-x)

  ;; Activate the blackboard windows
  (mapc #'activate-widget bb-windows)

  ;; Create the status window & the control shell window
  (let* ((logo-height (widget-outer-height *logo-window*))
	 (logo-width (widget-outer-width *logo-window*))

	 ;; Create the elevator status window
	 (status-window (make-elevator-status-window
			 :x status-x :y 0
			 :width `(,(- 1 status-x) ,(- logo-width))
			 :height  (max 90 logo-height)))
	 (status-height (widget-outer-height status-window))
	
	 ;; Create the control shell window
	 (cs-width (+ (widget-outer-width status-window) logo-width))
	 (cs-window (make-control-shell-window
		     :x '(:right 0) :y status-height
		     :width cs-width :height .58
		     :initial-configuration :portrait)))

    ;; Finally adjust the lisp listener window (if we can find it).
    (let ((w (chalkbox::lisp-listener)))
      (when w
        (reshape-widget 
          w
          :x `(:right 0) :y `(:bottom 0)
          :width cs-width
          :height `(1.0 ,(- (+ status-height (widget-outer-height cs-window)))))))

    cs-window))

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

;;; We use this layout for low resolution screens. Instead of
;;; tiling the various blackboard windows, we set up a chain
;;; of windows, that the user can navigate through by using
;;; the chain manager window

(defun SETUP-ELEVATOR-WINDOWS-SMALL-LAYOUT (bb-windows)

  (let* ((logo-height (widget-outer-height chalkbox:*logo-window*))
	 (mouse-window-width (min chalkbox::*mouse-window-width*
				  (floor (* 2 (screen-width)) 3)))
	 ;; Control Shell window
	 (cs-window (make-control-shell-window :activate nil))
	 ;; Create the chain manager
	 (chain-manager-width (- (screen-width) mouse-window-width))
	 (chain-manager
	  (chalkbox::setup-window-chain `(,.bb-windows ,cs-window)
	   ;; Position & size of the windows in the chain
	   :x 0  :y 0 :width mouse-window-width
	   :height `(1.0 ,(- chalkbox::*mouse-window-height*))
	   ;; Initial position of the chain manager
	   :chain-manager-x '(:right 0) :chain-manager-y (1+ logo-height)
	   ;; Initial width of the chain manager
	   :chain-manager-width chain-manager-width))
         ;; chain-manager-height
         #+(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL) 
         (chain-manager-height (widget-outer-height chain-manager))
	 ;; Elevator Status window
	 (status-window
	  (make-elevator-status-window
	   ;; Position & size of the windows in the chain
	   :x '(:right 0)
           :y (+ logo-height (widget-outer-height chain-manager))
	   :width chain-manager-width
           :height (max 75 logo-height))))

    ;; Finally Adjust lisp listener window.
    #+(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL)
    (reshape-widget (chalkbox::lisp-listener)
      :x `(:right 0) :y `(:bottom 0)
      :width `(1.0 ,(- mouse-window-width))
      :height (- (screen-height)
		 (+ logo-height
                    chain-manager-height
                    (widget-outer-height status-window))))

    status-window))
   
;;; ---------------------------------------------------------------------------

(defun do-exit-elevator-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*))
  (delete-from-application-menu
    '("Exit Elevator Example" . do-exit-elevator-example))
  (control-shells::exit-control-shell))

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

(defun setup-elevator-colors ()
  (cond ((eq :color (display-type)) 
         (set-unit-color 'move-up-task    *darkgreen*)
         (set-unit-color 'move-down-task  *red*)
         (set-unit-color 'wait-task       *blue*)     
         (set-unit-color 'door-cycle-task *purple*)
         (setf *elevator-window-background-color* *lightgray*)
         (setf *elevator-window-foreground-color* *black*))
        (t
         (setf *elevator-window-background-color* *white*)
         (setf *elevator-window-foreground-color* *black*))))

;;; ---------------------------------------------------------------------------
;;;   Status Window
;;; ---------------------------------------------------------------------------


(defclass status-window (container-window)
  ())

(defun make-elevator-status-window (&key
				    (x `(:right ,(widget-outer-width *logo-window*)))
				    (y 0)
				    (width 200)
				    (height (widget-outer-height *logo-window*)))
  
  ;; Create status window if there isn't one already.

  (cond ((and (typep *status-window* 'window)
              (not (widget-deleted-p *status-window*)))
         (reshape-widget *status-window* :x x :y y :width width :height height))
        (t
	 (let* ((font  "Normal"))
	   (setf *status-window*
	     (make-window 'status-window
			  :x x :y y :width width :height height
			  :label "Elevator Status"
			  :background-color *lightgray*
			  :activate nil))
	   (setup-widget-configurations
	     *status-window*
             `((nil ((:clock text-widget
                             :label "Current time: "
                             :label-side :left
                             :label-side-alignment :center
                             :label-on-inside-p t
                             :font ,font
                             :text-horizontal-alignment :right
                             :text-vertical-alignment :center
                             :item-horizontal-margin 4)
                     (:wait text-widget
                            :label "Average wait: "
                            :label-side :left
                            :label-side-alignment :center
                            :font ,font
                            :label-on-inside-p t
                            :text-horizontal-alignment :right
                            :text-vertical-alignment :center
                            :item-horizontal-margin 4))))
             nil
             :width :parent-size :height :parent-size
             :margin (if (chalkbox::small-screen-p)
                         (or #+(and :CL-ALLEGRO :OS-WINDOWS) 2 3)
                         (or #+(and :CL-ALLEGRO :OS-WINDOWS) 3 6)))
           (activate-widget *status-window*))))
  
  *status-window*)

;;; ---------------------------------------------------------------------------
;;;   Status Widgets' Update Functions
;;; ---------------------------------------------------------------------------

(defun update-status-widget (widget value)
  (unless (typep widget 'widget)
    (setf widget (and (typep *status-window* 'window)
                      (not (widget-deleted-p *status-window*))
                      (find-widget *status-window* widget))))
  (when (and (typep widget 'widget)
             (not (widget-deleted-p widget)))
    (setf (widget-text widget)
          (cond ((null value) "")
                ((stringp value) value)
                (t (princ-to-string value))))
    (cb::refresh-contents widget)))

(defun update-clock-widget (&optional world-clock)
  (unless world-clock
    (setf world-clock *world-clock*))
  (update-status-widget
    :clock
    (if world-clock (world-clock.time world-clock) 0)))

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

(defun update-clock-event-handler (event-name &key unit &allow-other-keys)
  (declare (ignore event-name))
  (update-clock-widget unit)
  (update-status-widget
    :wait
    (and (not (zerop *total-wait-count*))
         (format nil "~,2f" (/ *total-wait-time* *total-wait-count*)))))

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

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

(defun initialize-clock-widget-stuff ()
  (setf *clock-widget-font*
        (make-font "Clock Font"
                   '("-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)
		     (:sans-serif 22 :bold)
		     (:sans-serif 20 :bold)))))

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

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