;;;; -*- Mode:COMMON-LISP; Package:ELEVATOR-EXAMPLE; Base:10 -*-
;;;; *-* File: lapis: /u7/gbb/v-400/dev/source/gbb/examples/elevator-example.lisp *-*
;;;; *-* Edited-By: Cork *-*
;;;; *-* Last-Edit: Friday, September 18, 1998  14:31:34 *-*
;;;; *-* Machine: GRANITE (Explorer II, Microcode 489) *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *                  ELEVATOR CONTROLLER/SIMULATION PROBLEM
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Participants in
;;;             ``Designing and Implementing Blackboard Applications''
;;;             Amherst, Massachusetts, March 25-27, 1992
;;;
;;; ------------------------------------------------------------------------
;;; To run, evaluate (elevator:elevator-example).
;;;
;;; Tip: Use GBB's graphics to see what is happening!
;;;
;;; ------------------------------------------------------------------------
;;; Overview:
;;;
;;; This example implements a simple elevator controller which plans the
;;; movements and actions of all the elevators in a building.  It also
;;; acts as a simulator to simulate the behavior of the actual elevators
;;; with some randomness.
;;;
;;; There are three blackboards: 
;;;
;;; - The BUILDING-INFO blackboard is used by both the planner and the
;;;   simulator.  It contains all the information about the building and
;;;   its elevators: how many elevators, how they are grouped into banks
;;;   of elevators, what floors they serve, etc.
;;;
;;; - The SIMULATOR blackboard contains all the information used by the
;;;   simulator.  Only simulator KSs should look at these to maintain a
;;;   clean separation between the planner and the simulator.
;;;
;;; - The PLANNER blackboard contains all the information used by the
;;;   planner.  In particular, the space TASKS stores all the tasks that
;;;   have been planned for all the elevators.
;;;
;;; The system starts by reading the initial building configuration from
;;; a file and also reading some initial `orders' (i.e., what real world
;;; actions the simulator should simulate).  The planner KSs are
;;; triggered in response to the simulated button presses, door
;;; openings, etc., and decide where to send the elevators next.  These
;;; planned activities are then noted by the simulator as requests to be
;;; acted upon.  This is handled by the SIMULATOR-INTERFACE and
;;; COMPLETE-ACTION KSs.
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  03-25-92 File created.
;;;  09-07-93 Updated to GBB V3.0.  (Cork)
;;;  01-25-96 Updated to GBB V3.1.  (Cork)
;;;  05-06-97 Converted to GBB V3.2.  (Cork)
;;;  09-18-98 Converted to GBB V4.0.  (Cork)
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

(in-package "ELEVATOR-EXAMPLE")

;;; ------------------------------------------------------------------------
;;;   Module Definition
;;; ------------------------------------------------------------------------ 
;;
;;     (define-kti-module :elevator-example
;;       (:modules :2d-point-mixin
;;                 :time-interval-mixin
;;                 :agenda-shell
;;                 :gbb-graphics
;;                 :control-shell-graphics)
;;       (:package :elevator-example
;;                 (:nicknames "ELEVATOR")
;;                 (:use #.*lisp-package-name* "CLOS" "KTI-TOOLS" "GBB"
;;                       "AGENDA-SHELL" "CHALKBOX" "GBB-GRAPHICS"))
;;       (:directory gbb-root-open "examples")
;;       (:files "elevator-example"
;;               "elevator-example-graphics")
;;       (:auxiliary-files "elevator-building-info"
;;                         "elevator-orders"))

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

;; This controls whether executed actions "tasks" are retained on the
;; blackboard:

(defvar *retain-simulation-actions* nil)

(defparameter *building-info-file* "elevator-building-info")

(defparameter *orders-file* "elevator-orders")

(eval-when (compile eval load)

  (defparameter *max-time* 3600)     ;; Length of the simulation in seconds
  (defparameter *last-order-time* 3000) ;; Last possible time to generate a random order
  (defparameter *bottom-floor* -5)   ;; Lowest floor
  (defparameter *top-floor* 50)      ;; Highest floor
  (defparameter *max-weight* 1200)   ;; Maximum capacity of an elevator cab

) ;; End of eval-when


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

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

(defparameter *setup-windows-p* t)
(defparameter *random-p* t)

;; Total time spent waiting for an elevator and total number
;; of orders that have boarded an elevator.
(defvar *total-wait-time* 0)
(defvar *total-wait-count* 0)

;;; ------------------------------------------------------------------------
;;;   Top Level Function: ELEVATOR-EXAMPLE
;;; ------------------------------------------------------------------------

(defun elevator-example-startup ()
  (with-graphics-operations-deferred ()
    (delete-blackboard-database)
    (setf *world-clock* nil)
    (setf *total-wait-time* 0)
    (setf *total-wait-count* 0)
    (if *random-p*
      (enable-ks  'generate-random-orders)
      (disable-ks 'generate-random-orders))
    (instantiate-blackboard-database 'simulator 'building-info 'planner))
  (format *event-print-stream*
          "~2&;;; Running the elevator controller example....~%"))

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

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

(defun elevator-example-entry ()
  (with-graphics-operations-deferred ()
    ;; Function startup-graphics is defined in the file
    ;; elevator-example-graphics which may not have been loaded.
    (when (and *setup-windows-p* (fboundp 'startup-graphics))
      (startup-graphics))))

;; Add to control shell entry hooks:

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

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

(defun ELEVATOR-EXAMPLE (&optional *setup-windows-p*
                         &key ((:random *random-p*) t)
                              ((:wait-every *wait-every-interval*)
                               *wait-every-interval*) 
                              ((:event-print-stream *event-print-stream*)
			       *standard-output*)
			      ((:orders *orders-file*) *orders-file*))
  (start-control-shell :event-print-stream *standard-output*))

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

(defun elevator-example-exit ()
  (format *event-print-stream*
          "~2&;;; Leaving the elevator controller example....~%"))

(pushnew 'elevator-example-exit
	 control-shells::*control-shell-exit-hooks*)

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

(defun RESUME-ELEVATOR-EXAMPLE (&optional setup-windows
                                &key 
                                ((:wait-every *wait-every-interval*)
                                 *wait-every-interval*) 
                                ((:event-print-stream *event-print-stream*)
                                 *standard-output*))
  ;; Function startup-graphics is defined in the file
  ;; elevator-example-graphics which may not have been loaded.
  (when (and setup-windows (fboundp 'startup-graphics))
    (startup-graphics))
  (format *event-print-stream*
          "~2&;;; Resuming the elevator controller example....~%")
  (resume-control-shell)
  (format *event-print-stream*
          "~2&;;; Leaving the elevator controller example....~%"))


;;; ------------------------------------------------------------------------
;;;   Space definitions
;;; ------------------------------------------------------------------------

;; This blackboard contains all the information about the building and
;; its elevators: how many elevators, how they are grouped into banks of
;; elevators, what floors they serve, etc.

(define-space building-info ()
  ()
  (:unit-classes nil))

(define-space elevator-specs (building-info)
  ((elevator-type   :enumerated (:passenger :freight))
   (bank-spec       :enumerated :any :reset-display-axis t)
   (x               :ordered (0 100))
   (y               :ordered (0 100))
   (floors          :ordered (#.*bottom-floor* #.*top-floor*)))
  (:unit-classes elevator-spec))

(define-space bank-specs (building-info)
  ((floors          :ordered (#.*bottom-floor* #.*top-floor*)))
  (:unit-classes bank-spec))

(define-space call-button-specs (building-info)
  ((bank-spec       :enumerated :any :reset-display-axis t)
   (floor           :ordered (#.*bottom-floor* #.*top-floor*))
   (lit?            :enumerated (t nil)))
  (:unit-classes call-button-spec))

(define-space floor-button-specs (building-info)
  ((elevator-spec   :enumerated :any :reset-display-axis t)
   (floor           :ordered (#.*bottom-floor* #.*top-floor*))
   (lit?            :enumerated (t nil)))
  (:unit-classes floor-button-spec))

;; This blackboard contains all the information used by the simulator.
;; Only simulator KSs should look at these to maintain a clean 
;; separation between the planner and the simulator.

(define-space simulator ()
  ()
  (:unit-classes nil))

(define-space cabs (simulator)
  ((elevator-spec   :enumerated :any :reset-display-axis t)
   (floor           :ordered (#.*bottom-floor* #.*top-floor*))
   (weight          :ordered (0 #.*max-weight*))
   (status          :enumerated (:stopped :doors-open :out-of-service :moving-up :moving-down))
   (x               :ordered (0 100))
   (y               :ordered (0 100)))
  (:unit-classes cab))

(define-space sim-actions (simulator)
  ((time-interval   :ordered (-1 #.*max-time*))
   (cab-spec        :enumerated :any)
   (elevator-spec   :enumerated :any)
   (floors          :ordered (#.*bottom-floor* #.*top-floor*))
   (executed?       :enumerated (t nil)))
  (:unit-classes sim-action))

(define-space orders (simulator)
  ((time            :ordered (0 #.*max-time*))
   (start-floor     :ordered (#.*bottom-floor* #.*top-floor*))
   (up/down         :enumerated (:up :down))
   (answered        :enumerated (t nil))
   (bank-spec       :enumerated :any))
  (:unit-classes order))

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

;; This blackboard contains all the information used by the planner.
;; In particular, the space TASKS stores all the tasks that have been
;; planned for all the elevators.

(define-space planner ()
  ()
  (:unit-classes nil))

(define-space TASKS (planner)
  ((time-interval   :ordered (-1 #.*max-time*))
   (bank-spec       :enumerated :any)
   (elevator-spec   :enumerated :any)
   (floors          :ordered (#.*bottom-floor* #.*top-floor*))
   (task-type       :enumerated :any :test equal))
  (:unit-classes TASK))


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

(define-dimension-value-computation elevator-type-dvc
  ((elevator-type :label))
  (:scalar-type symbol))

(define-dimension-value-computation elevator-spec-dvc
  ((elevator-spec :label))
  (:scalar-type (or null elevator-spec)))

(define-dimension-value-computation elevator-location-dvc
  ((x :point elevator-location.x)
   (y :point elevator-location.y))
  (:scalar-type (or null elevator-spec)))

(define-dimension-value-computation elevator-floors-dvc
  ((floors :point))
  (:dimension-value-computation-type :set)
  (:element-type number))

(define-dimension-value-computation bank-spec-dvc
  ((bank-spec :label))
  (:scalar-type (or null bank-spec)))

(define-dimension-value-computation bank-spec-from-elevator-spec-dvc
  ((bank-spec :label (lambda (u) (and u (elevator-spec.bank-spec u)))))
  (:scalar-type (or null elevator-spec)))

;; Floor ranges are represented as a two-element list:
;;   (<start-floor> <end-floor>)
;; We could use defstruct here, but there isn't much advantage.

(defun make-floor-range (start end)
  (list start end))

(defun start-floor (floor-range)
  (first floor-range))

(defun end-floor (floor-range)
  (second floor-range))

(defun (setf start-floor) (nv floor-range)
  (setf (first floor-range) nv))

(defun (setf end-floor) (nv floor-range)
  (setf (second floor-range) nv))

(defmethod min-floor (floor-range)
  (min (start-floor floor-range) (end-floor floor-range)))

(defmethod max-floor (floor-range)
  (max (start-floor floor-range) (end-floor floor-range)))

(define-dimension-value-computation floor-range-dvc
  ((floors :range (:min min-floor) (:max max-floor)))
  (:scalar-type list))

(define-dimension-value-computation order-call-button-dvc
  ((start-floor :point button-spec.floor)
   (bank-spec :label call-button-spec.bank-spec)
   (up/down :label call-button-spec.direction))
  (:scalar-type (or null call-button-spec)))

(define-dimension-value-computation task-type-dvc
  ((task-type :label get-task-type-dvc)))

(defun get-task-type-dvc (arg)
  (declare (ignore arg))
  (typecase *self*
    (wait-task                    "Wait")
    (move-up-task                 "Move Up")
    (move-down-task               "Move Down")
    (door-cycle-task              "Open Door")
    (door-cycle-wait-sim-action   "Open Door & Wait!")
    (door-cycle-down-sim-action   "Open Door & Down!")
    (door-cycle-up-sim-action     "Open Door & Up!")
    (move-up-sim-action           "Move Up!")
    (move-down-sim-action         "Move Down!")
    (t (string (type-of *self*)))))
    

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

;; ELEVATOR-SPEC is the static information about each elevator.

(define-unit-class elevator-spec (2d-point-mixin)
  ((2d-point
         ;; Birds eye location of the elevator in the building.
         ;; This slot is inherited from 2d-point-mixin.  It is
         ;; repeated here to add another initarg and accessor.
         :initarg :location
         :accessor elevator-spec.location)
   (tasks
         ;; List of tasks that have been planned for this elevator,
         ;; collectively called the `plan'.  This list is not in order,
         ;; use the functions first-plan-task, task.next-task, etc.  to
         ;; traverse the plan.
         :link (task elevator-spec :singular))
   (sim-actions
         ;; Link to the simulator actions in progress for this elevator.
         :link (sim-action elevator-spec :singular))
   (bank-spec
         ;; Link to the bank that this elevator is a member of.
         :link (bank-spec elevator-specs)
         :singular t
         :link-event-functions (new-elevator-bank-spec)
         :unlink-event-functions (new-elevator-bank-spec)
         :link-initialization-event-functions (new-elevator-bank-spec))
   (floor-button-specs
         ;; List of floor buttons in this elevator.
         :link (floor-button-spec elevator-spec :singular))
   (cab
         ;; Link to the cab (the simulator object) for this elevator.
         :link (cab elevator-spec :singular)
         :singular t)
   (capacity
         ;; Capacity of this elevator in pounds.
         :initform 800)
   (type
         ;; One of :passenger or :freight.
         :initform :passenger
         :type elevator-type-dvc)
   (floors
         ;; List of floors that this elevator services.
         :initform nil)
   (start/stop-penalty
         ;; Number of seconds required to start moving
         :initform 5)
   (speed
         ;; Speed of the elevator in floors/second
         :initform 2)
   (door-cycle-time
         ;; Minimum time to open doors, wait a moment, and close them
         :initform 10))
  (:dimensions
      (bank-spec bank-spec :value-type :label)
      (elevator-type type)
      (floors floors :type elevator-floors-dvc))
  (:paths '(building-info elevator-specs))
  (:generate-initargs
      tasks sim-actions bank-spec floor-button-specs 
      capacity type start/stop-penalty speed door-cycle-time)
  (:generate-accessors
      tasks sim-actions bank-spec floor-button-specs cab capacity
      type floors start/stop-penalty speed door-cycle-time))

(defmethod print-object-for-display ((elevator elevator-spec) stream)
  (format stream "#<Elevator ~a>" (unit-name elevator)))

;; The TASK unit uses the value of the BANK-SPEC link in the
;; ELEVATOR-SPEC unit as dimension of its own.  Because it gets the
;; value indirectly through its own ELEVATOR-SPEC link, we must
;; explicitly notify GBB that the bank spec for an elevator has changed
;; so that the dimensional values will be updated accordingly.  Note,
;; that the BANK-SPEC dimension in the TASK class is cached so that it
;; can be repositioned correctly.
;;
;; Also each elevator gets the value of its FLOORS slot from the
;; BANK-SPEC.  So when the BANK-SPEC is initialized or changes we must
;; update the FLOORS slot.

(defun new-elevator-bank-spec (event-name
			       &key unit current-value
			       &allow-other-keys)
  ;; UNIT is the elvator-spec that has been modified.
  ;; CURRENT-VALUE is the new value of the bank-spec link.
  (declare (ignore event-name))
  (dolist (task (elevator-spec.tasks unit))
    (reposition-unit task :bank-spec))
  (setf (elevator-spec.floors unit) (bank-spec.floors current-value)))

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

;; BANK-SPEC contains the static information about each elevator
;; bank.  An elevator bank is a group of elevators all serving the
;; same floors.

(define-unit-class bank-spec ()
  ((floors
         :type elevator-floors-dvc)
   (elevator-specs
         :link (elevator-spec bank-spec :singular))
   (call-button-specs
         :link (call-button-spec bank-spec :singular)))
  (:dimensions (floors floors))
  (:paths '(building-info bank-specs))
  (:generate-initargs t)
  (:generate-accessors t))

(defmethod print-object-for-display ((bank bank-spec) stream)
  (format stream "#<~a>" (unit-name bank)))

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

(define-unit-class basic-button-spec ()
  ((floor
       :initform nil)
   (lit?
       :initform nil))
  (:dimensions
      (floor floor :value-type :point)
      (lit? lit? :value-type :label))
  (:generate-initargs floor)
  (:generate-accessors)
  (:accessor-prefix "BUTTON-SPEC."))

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

(define-unit-class floor-button-spec (basic-button-spec)
  ((elevator-spec
       :link (elevator-spec floor-button-specs)
       :singular t))
  (:dimensions
      (elevator-spec elevator-spec :value-type elevator-spec-dvc))
  (:paths '(building-info floor-button-specs))
  (:generate-initargs)
  (:generate-accessors))

(defmethod print-object-for-display ((button floor-button-spec) stream)
  (format stream "#<Button E:~a F:~d>"
          (and (floor-button-spec.elevator-spec button)
               (unit-name (floor-button-spec.elevator-spec button)))
          (button-spec.floor button)))

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

(define-unit-class call-button-spec (basic-button-spec)
  ((bank-spec
         :link (bank-spec call-button-specs)
         :singular t)
   (orders
         :link (order call-button-spec :singular))
   (keyed
         :initform nil))
  (:dimensions
      (floor floor :value-type :point)
      (bank-spec bank-spec :value-type bank-spec-dvc)
      (lit? lit? :value-type :label))
  (:paths '(building-info call-button-specs))
  (:generate-initargs)
  (:generate-accessors))

(define-unit-class up-call-button-spec (call-button-spec) ())

(define-unit-class down-call-button-spec (call-button-spec) ())		   

(defmethod print-object-for-display ((button up-call-button-spec) stream)
  (format stream "#<UP Call Button - ~d>" (button-spec.floor button)))

(defmethod print-object-for-display ((button down-call-button-spec) stream)
  (format stream "#<DOWN Call Button - ~d>" (button-spec.floor button)))

(defmethod call-button-spec.direction ((call-button call-button-spec))
  (etypecase call-button
    (up-call-button-spec :up)
    (down-call-button-spec :down)))


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

(define-unit-class CAB ()
  ((elevator-spec
         :link (elevator-spec cab :singular)
         :singular t)
   (orders
         :link (order cab :singular))
   (sim-action
         :link (sim-action cab :singular)
         :singular t)
   (status
         :initform :stopped)
   (current-floor
         ;; Default is the ground floor, which is appropriate for the initial state.
         :initform 0)
   (current-weight
         ;; Default is empty, which is appropriate for the initial state.
         :initform 0))
  (:dimensions
      (elevator-spec elevator-spec  :value-type elevator-spec-dvc)
      (floor         current-floor  :value-type :point)
      (weight        current-weight :value-type :point)
      (status        status         :value-type :label)
      (x             elevator-spec  :value-type elevator-location-dvc)
      (y             elevator-spec  :value-type elevator-location-dvc))
  (:paths '(simulator cabs))
  (:generate-initargs)
  (:generate-accessors))

(defmethod print-object-for-display ((cab cab) stream)
  (if (cab.elevator-spec cab)
      (format stream "#<Cab ~a>" (unit-name (cab.elevator-spec cab)))
      (format stream "#<~a ???>" (unit-name cab))))

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

(define-unit-class world-clock ()
  ((time :initform 0))
  (:dimensions (time time :value-type :point))
  (:paths '(simulator clock))
  (:generate-accessors)
  (:generate-initargs time))

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

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

(define-unit-class order ()
  ((time
         ;; Time that the person/people pressed the call button.
         )
   (cab
         ;; Link to the elevator cab that is handling this order.  If
         ;; this is null then this order hasn't yet been fulfilled. 
         :link (cab orders)
         :singular t)
   (call-button-spec
         :link (call-button-spec orders)
         :singular t)
   (call-button-actions)
   (dest-floors
         ;; List of floor buttons that will be pressed when this
         ;; party gets on.
         )
   (departure-floor
         ;; Actual floor that the party gets off at.
         )
   (weight)
   (entry-time
         ;; Time taken to get on
         )
   (exit-time
         ;; Time taken to get off
         )
   (answered
         ;; whether an elevator has stopped at the call floor
         ;; going in the right direction
         :initform nil))
  (:dimensions
      (start-floor call-button-spec :value-type order-call-button-dvc)
      (bank-spec call-button-spec   :value-type order-call-button-dvc)
      (up/down call-button-spec     :value-type order-call-button-dvc)
      (time time                    :value-type :point)
      (answered answered            :value-type :label))
  (:paths '((simulator orders)))
  (:generate-accessors)
  (:generate-initargs))

(defmethod print-object-for-display ((order order) stream)
  (format stream "#<~d ~a from ~s to ~s exit at ~s>"
          (order.time order)
          (order.call-button-actions order)
          (if (order.call-button-spec order)
              (button-spec.floor (order.call-button-spec order))
              "???")
          (order.dest-floors order)
          (order.departure-floor order)))

;;; ------------------------------------------------------------------------
;;;   Tasks
;;; ------------------------------------------------------------------------

(define-unit-class BASIC-TASK (time-interval-mixin)
  ((time-interval
       ;; Time interval spaned by this task.
       ;; Default is all time, which is appropriate for the initial tasks.
       :initform (make-time-interval :start 0 :end #.*max-time*))
   (floors
       ;; Start and end floor for this task.
       ;; Default is the ground floor, which is appropriate for the initial tasks.
       :initform (make-floor-range 0 0)
       :type floor-range-dvc))
  (:dimensions
      (floors floors)
      (task-type gbb:unit-name :value-type task-type-dvc))
  (:generate-accessors)
  (:generate-initargs floors)
  (:accessor-prefix "TASK."))


;; Methods for reading and writing components of the TIME-INTERVAL and
;; FLOORS slots.  The setf methods destructively modify components of
;; the time interval or floor range data structures rather than creating
;; new ones.  Because it's a destructive change, GBB must be notified
;; that it should update the unit's location on the blackboard.  This is
;; done via WITH-DESTRUCTIVELY-CHANGED-DIMENSION-VALUES.  Using these
;; methods simplifies lots of code below.

(defmethod task.start-time ((task basic-task))
  (time-interval.start (task.time-interval task)))

(defmethod task.end-time ((task basic-task))
  (time-interval.end (task.time-interval task)))

(defmethod (setf task.start-time) (nv (task basic-task))
  (with-destructively-changed-dimension-values (task :time-interval)
    (setf (time-interval.start (task.time-interval task)) nv)))

(defmethod (setf task.end-time) (nv (task basic-task))
  (with-destructively-changed-dimension-values (task :time-interval)
    (setf (time-interval.end (task.time-interval task)) nv)))


(defmethod task.start-floor ((task basic-task))
  (start-floor (task.floors task)))

(defmethod task.end-floor ((task basic-task))
  (end-floor (task.floors task)))

(defmethod (setf task.start-floor) (nv (task basic-task))
  (signal-event 'plan-modified-event :unit task)
  (with-destructively-changed-dimension-values (task :floors)
    (setf (start-floor (task.floors task)) nv)))

(defmethod (setf task.end-floor) (nv (task basic-task))
  (signal-event 'plan-modified-event :unit task)
  (with-destructively-changed-dimension-values (task :floors)
    (setf (end-floor (task.floors task)) nv)))

(defmethod task.min-floor ((task basic-task))
  (apply #'min (task.floors task)))

(defmethod task.max-floor ((task basic-task))
  (apply #'max (task.floors task)))


;;; ------------------------------------------------------------------------
;;;   Simulator Tasks (called Actions)
;;; ------------------------------------------------------------------------

(define-unit-class SIM-ACTION (basic-task) 
  ((task
         :link (task sim-action :singular)
	 :singular t)
   (new
         :initform t)
   (elevator-spec
         :link (elevator-spec sim-actions)
         :singular t)
   (cab
         :link (cab sim-action :singular)
         :singular t)
   (executed?
         :initform nil))
  (:dimensions
      (elevator-spec elevator-spec :value-type elevator-spec-dvc)
      (executed? executed?         :value-type :label))
  (:paths '(simulator sim-actions))
  (:generate-accessors)
  (:generate-initargs))

(defmethod sim-action.bank-spec ((action sim-action))
  (and (sim-action.elevator-spec action)
       (elevator-spec.bank-spec (sim-action.elevator-spec action))))

(define-unit-class MOVE-SIM-ACTION (sim-action)
  ((speed
         :initform 0)
   (penalty
         :initform 0))
  (:generate-accessors)
  (:generate-initargs)
  (:accessor-prefix "SIM-ACTION."))

(define-unit-class MOVE-UP-SIM-ACTION (move-sim-action) ())

(define-unit-class MOVE-DOWN-SIM-ACTION (move-sim-action) ())

(define-unit-class DOOR-CYCLE-UP-SIM-ACTION (sim-action) ())

(define-unit-class DOOR-CYCLE-DOWN-SIM-ACTION (sim-action) ())

(define-unit-class DOOR-CYCLE-WAIT-SIM-ACTION (sim-action) ())

(define-unit-class WAIT-SIM-ACTION (sim-action) ())

(defmethod print-object-for-display ((action move-up-sim-action) stream)
  (format stream "#<SIM: ~a up ~d -> ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.min-floor action)
          (task.max-floor action)))

(defmethod print-object-for-display ((action move-down-sim-action) stream)
  (format stream "#<SIM: ~a down ~d -> ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.max-floor action)
          (task.min-floor action)))

(defmethod print-object-for-display ((action door-cycle-up-sim-action) stream)
  (format stream "#<SIM: ~a up door-cycle at ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.min-floor action)))

(defmethod print-object-for-display ((action door-cycle-down-sim-action) stream)
  (format stream "#<SIM: ~a down door-cycle at ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.min-floor action)))

(defmethod print-object-for-display ((action door-cycle-wait-sim-action) stream)
  (format stream "#<SIM: ~a wait door-cycle at ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.min-floor action)))

(defmethod print-object-for-display ((action wait-sim-action) stream)
  (format stream "#<SIM: ~a waiting at ~d>"
          (and (sim-action.elevator-spec action)
               (unit-name (sim-action.elevator-spec action)))
          (task.min-floor action)))

;;; ------------------------------------------------------------------------
;;;   Planner Tasks
;;; ------------------------------------------------------------------------

;; TASK is the parent class to all task's created by the planner.
;;
;; This class gets the value of its BANK-SPEC dimension from its
;; ELEVATOR-SPEC link.  Because there is no direct reference to the
;; BANK-SPEC unit, changes to the elevator's BANK-SPEC won't be noticed
;; automatically.  There is an event function on ELEVATOR-SPEC that
;; notifies any TASKS that the bank-spec has changed so that the
;; dimensional values will be updated accordingly.  Note, that the
;; BANK-SPEC dimension in TASK is cached so that it can be repositioned
;; correctly.

(define-unit-class TASK (basic-task)
  ((sim-action
         :link (sim-action task :singular)
         :singular t)
   (elevator-spec
         :link (elevator-spec tasks)
         :singular t)
   (duration
         :initform 0)
   (next-task
         :link (task previous-task :singular)
         :singular t)
   (previous-task
         :link (task next-task :singular)
         :singular t))
  (:dimensions
      (elevator-spec elevator-spec :value-type elevator-spec-dvc)
      (bank-spec     elevator-spec
                     :value-type bank-spec-from-elevator-spec-dvc
                     :cache t))
  (:paths '(planner tasks))
  (:generate-accessors)
  (:generate-initargs))

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

(define-unit-class MOVE-TASK (task) ())

(define-unit-class MOVE-UP-TASK (move-task) ())

(define-unit-class MOVE-DOWN-TASK (move-task) ())

(define-unit-class DOOR-CYCLE-TASK (task) ())

(define-unit-class WAIT-TASK (task) ())

(defmethod print-object-for-display ((task move-up-task) stream)
  (format stream "#<~a up ~d -> ~d>"
          (and (task.elevator-spec task)
               (unit-name (task.elevator-spec task)))
          (task.min-floor task)
          (task.max-floor task)))

(defmethod print-object-for-display ((task move-down-task) stream)
  (format stream "#<~a down ~d -> ~d>"
          (and (task.elevator-spec task)
               (unit-name (task.elevator-spec task)))
          (task.max-floor task)
          (task.min-floor task)))

(defmethod print-object-for-display ((task door-cycle-task) stream)
  (format stream "#<~a door-cycle at ~d>"
          (and (task.elevator-spec task)
               (unit-name (task.elevator-spec task)))
          (task.min-floor task)))

(defmethod print-object-for-display ((task wait-task) stream)
  (format stream "#<~a waiting at ~d>"
          (and (task.elevator-spec task)
               (unit-name (task.elevator-spec task)))
          (task.min-floor task)))

(defmethod task.direction ((task move-up-task))
  :up)

(defmethod task.direction ((task move-down-task))
  :down)

(defmethod task.direction ((task door-cycle-task))
  :cycle)

(defmethod task.direction ((task wait-task))
  :wait)

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

;; These methods are used by the dimension-value computation
;; elevator-location-dvc, etc.  They defined here because they must
;; appear after the class definition.  (You can't define a method on a
;; class that hasn't been defined.)

(defmethod elevator-location.x ((elevator elevator-spec))
  (2d-point.x (elevator-spec.location elevator)))

(defmethod elevator-location.y ((elevator elevator-spec))
  (2d-point.y (elevator-spec.location elevator)))

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

(defun copy-task-time-interval (task)
  (make-time-interval
    :start (task.start-time task)
    :end (task.end-time task)))

(defun copy-task-floors (task)
  (make-floor-range (task.start-floor task) (task.end-floor task)))


;;; ------------------------------------------------------------------------
;;;   Blackboard Storage
;;; ------------------------------------------------------------------------

(define-unit-mapping (elevator-spec) ((building-info elevator-specs))
  ((bank-spec       :hash)))

(define-unit-mapping (floor-button-spec) ((building-info floor-button-specs))
  ((elevator-spec   :hash)
   (floor           :subranges (:start 0) (0 :end (:width 10)))))

(define-unit-mapping (call-button-spec) ((building-info call-button-specs))
  ((bank-spec       :hash)
   (floor           :subranges (:start 0) (0 :end (:width 10)))))

(define-unit-mapping (sim-action) ((simulator sim-actions))
  ((elevator-spec   :hash)))

(define-unit-mapping (order) ((simulator orders))
  ((time            :subranges (:start :end (:width 100)))
   (bank-spec       :hash)))

(define-unit-mapping (cab) ((simulator cabs))
  ((elevator-spec   :hash)))
  
(define-unit-mapping (task) ((planner tasks))
  ((time-interval   :subranges (:start :end (:width 100)))
   (floors          :subranges (:start 0) (0 :end (:width 10)))
   (bank-spec       :hash)
   (elevator-spec   :hash)
   (task-type       :hash)))


;;; ------------------------------------------------------------------------
;;;   Events
;;; ------------------------------------------------------------------------

(define-event-class floor-button-event (single-unit-event)
  ()
  (:enable-event-printing floor-button-spec :permanent nil))

(define-event-print-format floor-button-event (event-name &key unit
                                                          &allow-other-keys)
  (declare (ignore event-name))
  "Floor Button Pressed" "Elevator ~A for floor ~A"
  (unit-name (floor-button-spec.elevator-spec unit))
  (button-spec.floor unit))

(define-event-class call-button-event (single-unit-event)
  ()
  (:enable-event-printing call-button-spec :permanent nil))

(define-event-print-format call-button-event (event-name &key unit
                                                         &allow-other-keys)
  (declare (ignore event-name))
  "Call Button Pressed" "~A at floor ~A going ~A"
  (unit-name (call-button-spec.bank-spec unit))
  (button-spec.floor unit)
  (etypecase unit
    (up-call-button-spec "up")
    (down-call-button-spec "down")))

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

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

;; Turn off printing for uninteresting events:
(disable-event-printing 'creation-event 'call-button-spec)
(disable-event-printing 'creation-event 'floor-button-spec)
(disable-event-printing 'creation-event 'basic-task)
(disable-event-printing 'deletion-event 'basic-task)
(disable-event-printing 'creation-event 'control-shell-ksa)
(disable-event-printing 'deletion-event 'control-shell-ksa)
;; (disable-event-printing 'ks-activation-event)
(disable-event-printing 'control-shell-cycle-header-event)

(defmethod print-object-for-display ((ksa control-shell-ksa) stream)
  (format stream "#<~a ~a {~d}>"
          (unit-name ksa)
          (if (ksa.ks ksa) (unit-name (ksa.ks ksa)) "???")
          (ksa.rating ksa)))

(defmethod print-object-for-display ((ks control-shell-ks) stream)
  (format stream "#<KS ~a>" (unit-name ks)))

;;; ------------------------------------------------------------------------
;;;   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)
         (format *query-io*
                 "~2&Pausing with World Clock at ~a...~%~@
                    To continue click the Pause/Unpause 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 "~&Waiting: "))))


(defun wait-loop (prompt)

  (flet ((resume ()
           (format *query-io* "~&Resuming...")
           (return-from wait-loop t)))

    (let ((line nil))

      (clear-input *query-io*)

      (loop

        (setf line (get-user-input prompt))

        (cond
          ((stringp line)
           (setf line (string-trim '(#\space) line))
           (cond ((or (zerop (length line))
                      (every #'(lambda (ch) (char= ch #\space)) line))
                  (resume))
                 ((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 elevator 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'~%Enter `help' for help."
                          line))))
          ((eq :error line)
           (format *query-io* "~&Command error. Please re-enter your command."))
          ((eq :continue line)
           (resume))
          (t
           (format *query-io* "~&Unknown command: `~a'~%Enter `help' for help." line)))))))

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

;; This function waits for the user to type a command.  It returns the
;; string the user typed or the keyword :continue.

(defun get-user-input (prompt)
  (format *query-io* prompt)
  (string-trim '(#\space) (read-line *query-io* nil nil)))
 
;;; ------------------------------------------------------------------------
;;;   Utility functions
;;; ------------------------------------------------------------------------

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

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

(defun READ-BUILDING-INFO ()

  (let ((input-file
          (kti-directory-file-pathname
                      '(kti-tools::gbb-root-open "examples")
                      *building-info-file*)))
      
    (with-open-file (stream input-file :direction :input)

      ;; Elevator specs:
      ;; Each elevator spec is a list of the form:
      ;;  (<elevator-name> (<x-loc> <y-loc>))
      (dolist (spec (read stream))
        (let* ((name (first spec))
               (xy (second spec))
               (elevator-spec
                (make-unit 'elevator-spec
                           :name name
                           :location (make-2d-point :x (first xy) :y (second xy))))
               ;; make the wait task:
               (wait-task
                (make-unit 'wait-task
                           :elevator-spec elevator-spec))
               (cab
                (make-unit 'cab
                           :elevator-spec elevator-spec)))
          ;; make the sim-wait task:
          (make-unit 'wait-sim-action
                     :elevator-spec elevator-spec
                     :task wait-task
                     :cab cab)))
        
      ;; Bank specs:
      ;; Each bank spec is a list of the form:
      ;;  (<bank-name> ({<elevator-name>}*) ({<floor> || <floor-range>}*))
      (gbb::with-unit-hooks-disabled/refresh () 
        (dolist (spec (read stream))
          (let* ((name (first spec))
                 (elevator-specs 
                   (mapcar #'(lambda (name)
                               (get-unit name 'elevator-spec))
                           (second spec)))
                 (floors (expand-floor-list (third spec)))
                 (bank-spec (make-unit 'bank-spec
                                       :name name
                                       :floors floors
                                       :elevator-specs elevator-specs))
                 (highest-floor (apply #'max floors))
                 (lowest-floor (apply #'min floors)))
            
            ;; Make the call buttons and floor buttons.
            (dolist (floor floors)
              
              ;; Call buttons
              (unless (= floor highest-floor)
                (make-unit 'up-call-button-spec :bank-spec bank-spec :floor floor))
              (unless (= floor lowest-floor)
                (make-unit 'down-call-button-spec :bank-spec bank-spec :floor floor))
              
              ;; Floor buttons (one button on each elevator)
              (dolist (elevator-spec elevator-specs)
                (make-unit 'floor-button-spec
                           :elevator-spec elevator-spec
                           :floor floor)))))))))

(defun expand-floor-list (spec)
  ;; Expands a specification of floor numbers into a a list of all the
  ;; floor numbers.  SPEC is a list of elements indicating a floor or
  ;; floors as follows:
  ;;   integer      -- a single floor
  ;;   (start end)  -- all the floors from start to end inclusive
  (let ((floor-list nil))
    (dolist (x spec)
      (etypecase x
        (integer
         (push x floor-list))
        (cons 
         (let ((start (first x))
               (end (second x)))
           (dotimes (i (1+ (- end start)))
             (push (+ i start) floor-list))))))
    (nreverse floor-list)))


;;; ------------------------------------------------------------------------
;;;   Initial KS
;;; ------------------------------------------------------------------------

(define-ks initial-ks
  :rating 100
  :ks-function 'initial-ks-function
  :trigger-events ((start-control-shell-event)))

(defun initial-ks-function (ksa)
  (declare (ignore ksa))
  ;; create the world clock:
  (setf *world-clock* (make-unit 'world-clock))
  ;; read the building information file:
  (read-building-info))


;;; ------------------------------------------------------------------------
;;;   Generate Random Orders KS
;;; ------------------------------------------------------------------------

(define-ks generate-random-orders
  :rating 100
  :ks-function 'generate-random-orders
  :trigger-events ((quiescence-event)))

(defun generate-random-orders (ksa)
  (declare (ignore ksa))
  (when (>= (world-clock) *last-order-time*)
    (disable-ks 'generate-random-orders))
  (flet ((choose-bank ()
           (let ((length 0)
                 (the-bank nil))
             (map-units-on-space #'(lambda (bank)
                                     (declare (ignore bank))
                                     (incf length))
                                 'bank-spec
                                 '(building-info bank-specs))
             (map-units-on-space #'(lambda (bank)
                                     (when (or (null the-bank)
                                               (zerop (random length)))
                                       (setf the-bank bank)))
                                 'bank-spec
                                 '(building-info bank-specs))
             the-bank))
         (choose-button (list &optional (start 0) (end (length list)))
           (let ((length (- end start)))
             (nth (+ start (random length)) list))))
    (when (zerop (random 10))
      (let* ((bank (choose-bank))
             (call-button (choose-button (bank-spec.call-button-specs bank)))
             (call-floor (button-spec.floor call-button))
             (up? (typep call-button 'up-call-button-spec))
             (floors (bank-spec.floors bank))
             (dest-floors
               (list
                 (if up?
                     (choose-button floors (1+ (position call-floor floors)))
                     (choose-button floors 0 (position call-floor floors))))))
        (make-unit 'order
                   :time                 (+ 2 (world-clock))
                   :call-button-spec     call-button
                   :call-button-actions  (if up? :up :down)
                   :dest-floors          dest-floors
                   :weight               (+ 150 (random 400))
                   :departure-floor      (car (last dest-floors))
                   :entry-time           (+ 2 (random 10))
                   :exit-time            (+ 1 (random 5)))))))


;;; ------------------------------------------------------------------------
;;;   Elevator Simulator KSs
;;; ------------------------------------------------------------------------

(define-ks SIMULATOR-INTERFACE
  :rating 100
  :trigger-events ((creation-event task)
                   (plan-modified-event basic-task))
  :ks-function 'simulator-interface)

(define-ks COMPLETE-ACTION
  :rating 100
  :trigger-events ((action-completion-event basic-task))
  :ks-function 'complete-action)


;;; ------------------------------------------------------------------------
;;;   Simulator Interface KS
;;; ------------------------------------------------------------------------
;;;
;;; This KS is triggered by the creation of a new task or by the modification
;;; of an existing task.  If the task is not the first task of the current
;;; task queue then this KS does nothing -- the task will eventually be
;;; handled when its turn comes.  Otherwise a command is issued to the
;;; simulator.  The command is issued by creating a simulator action unit that
;;; is placed on the simulator's blackboard.

(defun SIMULATOR-INTERFACE (ksa)
  (let ((task (sole-stimulus-unit ksa)))
    (when (and task 
               (first-task? task))
      (let ((old-sim-action
              ;; Find a simulator task for the same elevator
              (sole-element
                (find-units 'sim-action
                            '(simulator sim-actions)
                            `(:and (elevator-spec = ,(task.elevator-spec task))
                                   (executed? = nil))))))
        ;; If an old task exists then delete it.
        (when old-sim-action
          (delete-unit old-sim-action))
        ;; Create a new simulation elevator task.
        (make-simulator-task task)))))

(defun make-simulator-task (task)
  (make-unit (simulator-action-type task)
             :time-interval (copy-task-time-interval task)
             :floors (copy-task-floors task)
             :cab (elevator-spec.cab (task.elevator-spec task))
             :elevator-spec (task.elevator-spec task)
             :task task))

;;; The class of simulator action to create is based on the scheduler's
;;; task type.

(defmethod simulator-action-type ((task move-up-task))
  'move-up-sim-action)

(defmethod simulator-action-type ((task move-down-task))
  'move-down-sim-action)

(defmethod simulator-action-type ((task door-cycle-task))
  (simulator-cycle-action-type task (task.next-task task)))

(defmethod simulator-action-type ((task wait-task))
  'wait-sim-action) 

;;; The simulator's cycle task is based on the scheduler's task type and
;;; the type of the next task on the scheduler's list.  This is used by
;;; the simulator to indicate the direction the elevator will go once
;;; the door closes.

(defmethod simulator-cycle-action-type ((task door-cycle-task) (next-task move-up-task))
  'door-cycle-up-sim-action)

(defmethod simulator-cycle-action-type ((task door-cycle-task) (next-task move-down-task))
  'door-cycle-down-sim-action)

(defmethod simulator-cycle-action-type ((task door-cycle-task) (next-task wait-task))
  'door-cycle-wait-sim-action)

(defmethod simulator-cycle-action-type ((task door-cycle-task) (next-task door-cycle-task))
  'door-cycle-wait-sim-action)

;;; ------------------------------------------------------------------------
;;;   Complete Task KS
;;; ------------------------------------------------------------------------

;;; Given an action-completion-events from the simulator, and the associated
;;; simulation action as an argument, the execution monitor does the
;;; following:
;;;
;;; 1. Compares the completion time on the simulator action to the expected 
;;;    completion time on the scheduler task.  If the simulated action is
;;;    late by more then *Simulator-late-delta* minutes, then a
;;;    task-late-events is created for the scheduler with the argument of
;;;    the scheduler task.  It is assumed that the scheduler will do
;;;    whatever action is necessary and delete the given task from the
;;;    scheduler's blackboard.
;;;
;;; 2. Compares the completion time on the simulator action to the expected
;;;    completion time on the scheduler task.  If the simulated action is
;;;    different then this KS will update the estimated completion time of
;;;    each task linked to the current scheduler task.
;;;
;;; 3. Deletes the simulator's action and the scheduler's task from their
;;;    blackboards.
;;;
;;; 4. Creates a new simulator action to handle  the next scheduled task.

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

(defvar *simulator-late-delta* 4000) ;;PAIN THRESHOLD - infinite

(defun COMPLETE-ACTION (ksa)
  (let* ((sim-action (sole-stimulus-unit ksa))
	 (sched-task (sim-action.task sim-action)))
    (cond
      ;; Compare completion times on sim-action and sched-task
      ((action-completed-very-late? sim-action sched-task)
       (signal-event 'task-late-events :unit sched-task)
       (cond (*retain-simulation-actions*
              (unlinkf-all (sim-action.cab sim-action))
              (setf (sim-action.executed? sim-action) t))
             (t (delete-unit sim-action))))
      ;;otherwise update times and setup for next task 
      (t
       (update-estimated-time-from-simulator sim-action sched-task)
       (let ((next-task (task.next-task sched-task)))
         (cond (*retain-simulation-actions*
                (unlinkf-all (sim-action.cab sim-action))
                (setf (sim-action.executed? sim-action) t))
               (t (delete-unit sim-action)))
         (delete-unit sched-task)
         (make-simulator-task next-task))))))

;;; TASK COMPLETED VERY LATE function determines if the amount of 
;;; time that simulated task is later than the scheduler task by an 
;;; amount greater than *Simulator-late-delta*

(defun action-completed-very-late? (sim-action sched-task)
  (> (- (task.end-time sim-action)
        (task.end-time sched-task))
     *simulator-late-delta*))


;;; UPDATE-ESTIMATED-TIME-FROM-SIMULATOR
;;; Updates the end time of the planner task corresponding to the
;;; simulator task to reflect the actual completion time.  Also
;;; updates the estimated start and end times for all subsequent
;;; planned tasks.

(defun update-estimated-time-from-simulator (sim-action sched-task)
  (setf (task.end-time sched-task) (task.end-time sim-action))
  (update-estimated-time (task.next-task sched-task) (task.end-time sim-action)))


;;; ------------------------------------------------------------------------
;;;   Answer Call Button KS
;;; ------------------------------------------------------------------------

;;; This KS will plan a task to send an elevator to answer a call button.

(define-ks ANSWER-CALL-BUTTON
	   :rating 100
	   :trigger-events ((call-button-event call-button-spec))
	   :ks-function 'answer-call-button)

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

;;; Check to find the elevators' plans to find which one can service this
;;; request quickest

(defun ANSWER-CALL-BUTTON (ksa)
  (let* ((button (sole-stimulus-unit ksa))
         (floor (button-spec.floor button))
         (bank (call-button-spec.bank-spec button))
         (best-time 10000)
         (best-next-task nil))
    (find-units 'elevator-spec '(building-info elevator-specs)
                `(bank-spec = ,bank)
                :filter-after #'(lambda (elevator)
                                  (multiple-value-bind (next-task time)
                                      (plan-door-cycle elevator floor 
                                                       :up (typep button 'up-call-button-spec)
                                                       :down (typep button 'down-call-button-spec))
                                    (when (< time best-time)
                                      (setf best-time time)
                                      (setf best-next-task next-task)))))
    (when best-next-task (insert-door-cycle floor best-next-task))))


;;; ------------------------------------------------------------------------
;;;   Clock Update KS
;;; ------------------------------------------------------------------------

;;; This KS will update the clock when we are done with all the planning
;;; and simulating for this clock tick.  It's triggered on quiescence.
;;; It also will pause periodically to allow the user to look at the
;;; state of the system (typically with the graphics).

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

(defun CLOCK-KS-FUNCTION (ksa)
  (declare (ignore ksa))
  (cond ((<= (incf (world-clock)) *max-time*)
         (when (and *wait-every-interval*
                    (zerop (mod (world-clock) *wait-every-interval*)))
           (pause-system)))
        (t
         ;; stop if at the end of time
         :stop)))

;;; ------------------------------------------------------------------------
;;;   Simulation Update KS
;;; ------------------------------------------------------------------------

;;; This KS will perform all the simulation actions: signalling button
;;; presses, opening doors, moving the elevator cab, etc.  It's triggered
;;; by updating the clock.

(define-ks SIMULATION-UPDATE
  :rating 100
  :ks-function 'do-updates
  :trigger-events ((slot-update-event world-clock :slot-name time)))


;;; handle the simulation events
(defun DO-UPDATES (ksa)
  (declare (ignore ksa))
  (process-new-orders)
  (dolist (sim-action
            (find-units 'sim-action '(simulator sim-actions) '(executed? = nil)))
    (update-sim-action sim-action)))


;;; Process orders at current time.
(defun process-new-orders ()
  ;; This function looks for orders starting at the current time and
  ;; signals a call-button-event for each such order.  The find-units
  ;; works by side effect only -- we don't use the return value.  The
  ;; signal function is called by the after filter which then returns
  ;; nil to avoid consing a list of units found.
  (find-units
    'order
    '(simulator orders)
    `(time = ,(world-clock))
    :filter-after #'(lambda (order)
		      (let ((call-button (order.call-button-spec order)))
			(signal-event 'call-button-event :unit call-button)
			(setf (button-spec.lit? call-button) t)
			nil))))

;;; Update methods for sim-action classes.
(defmethod update-sim-action ((task door-cycle-up-sim-action))
  (update-door-cycle-task task :up))

(defmethod update-sim-action ((task door-cycle-down-sim-action))
  (update-door-cycle-task task :down))

;; Check if there is anyone waiting to get in on this floor.
(defmethod update-sim-action ((task door-cycle-wait-sim-action))
  (let* ((cab (sim-action.cab task))
         (elevator (cab.elevator-spec cab))
         (this-floor-button
          (find (task.start-floor task)
                (elevator-spec.floor-button-specs elevator)
                :key #'button-spec.floor))
         (orders (find-unfilled-orders task :up :down)))

    (flet ((turn-off-call-button (direction)
	     (let ((button
                    (find (task.start-floor task)
                          (bank-spec.call-button-specs
                           (elevator-spec.bank-spec elevator))
                          :test #'(lambda (floor button)
                                    (and (= floor (button-spec.floor button))
                                         (eq direction (call-button-spec.direction button)))))))
	       (when (and button (button-spec.lit? button))
		 (setf (button-spec.lit? button) nil)))))
      
      ;; Turn off the floor button and call button (if they are on)
      ;; for this floor.
      (when (button-spec.lit? this-floor-button)
	(setf (button-spec.lit? this-floor-button) nil))
      ;; Actually, we don't know what direction we'll be going in
      (turn-off-call-button :up)
      (turn-off-call-button :down)
      
      ;; let passengers off
      (process-off-cab-orders task)
      
      ;; Put any passengers on.
      (process-on-cab-orders task orders)
      
      ;; Signal that we are done waiting.
      (when (>= (world-clock) (task.end-time task))
	(signal-event 'action-completion-event :unit task)))))

(defmethod update-sim-action ((task wait-sim-action))
  (when (sim-action.new task)
    (setf (cab.status (sim-action.cab task)) :stopped)
    (setf (sim-action.new task) nil)))

(defmethod update-sim-action ((task move-up-sim-action))
  (update-move-task task :up #'+ #'>=))

(defmethod update-sim-action ((task move-down-sim-action))
  (update-move-task task :down #'- #'<=))

;;; Update function for cab move task.
(defun update-move-task (task direction function predicate)
  (let* ((cab (sim-action.cab task))
         (current-floor (cab.current-floor cab)))
    (when (sim-action.new task)
      (setf (sim-action.speed task)
            (elevator-spec.speed (sim-action.elevator-spec task)))
      (setf (sim-action.penalty task)
            (if (= (task.start-floor task) (task.end-floor task))
                0
                (elevator-spec.start/stop-penalty (sim-action.elevator-spec task))))
      (setf (cab.status (sim-action.cab task))
            (if (eq direction :up)
                :moving-up
                :moving-down))
      (setf (sim-action.new task) nil))
    (cond ((= (sim-action.penalty task) 0)
           (cond ((funcall predicate current-floor (task.end-floor task))
                  (setf (cab.current-floor cab)
                        (task.end-floor task))
                  (signal-event 'action-completion-event :unit task))
                 (t
                  (setf (cab.current-floor cab)
                        (funcall function
                                 current-floor
                                 (sim-action.speed task))))))
          (t (decf (sim-action.penalty task))))))

;;; Update function for door cycle task.
(defun update-door-cycle-task (task direction)

  (let* ((elevator (cab.elevator-spec (sim-action.cab task)))
	 (floor-button
	      (find (task.start-floor task)
		    (elevator-spec.floor-button-specs elevator)
		    :key #'button-spec.floor))
	 (call-button 
	      (find (task.start-floor task)
		    (bank-spec.call-button-specs
 		      (elevator-spec.bank-spec elevator))
		    :test #'(lambda (floor button)
			      (and (= floor (button-spec.floor button))
				   (eq direction (call-button-spec.direction button)))))))

    ;; If  this is a new action then update the cab status.
    (when (sim-action.new task)
      (setf (sim-action.new task) nil)
      (setf (cab.status (sim-action.cab task)) :doors-open))

    ;; Turn off the floor button and call button lights if they've
    ;; been pressed.  This is checked at each time interval because
    ;; someone could press a button any time after the doors open.
    (when (button-spec.lit? floor-button)
      (setf (button-spec.lit? floor-button) nil))
    (when (and (button-spec.lit? call-button))
      (setf (button-spec.lit? call-button) nil))

    (process-off-cab-orders task)
    (process-on-cab-orders task (find-unfilled-orders task direction))

    (when (>= (world-clock) (task.end-time task))
      (signal-event 'action-completion-event :unit task))))

;;; Process orders waiting to get on a cab at a given floor.
(defun process-on-cab-orders (task orders)
  (let* ((cab (sim-action.cab task))
	 (capacity (elevator-spec.capacity (cab.elevator-spec cab)))
         (unanswered-orders nil))
    (mapc #'(lambda (order)
              (if (<= (+ (order.weight order) (cab.current-weight cab)) capacity)
                  ;; get on the elevator
                  (progn                
                    ;; Record that this order was answered.
                    (setf (order.answered order) t)
                    ;; Assign this cab to this order
                    (linkf (cab.orders cab) order)
                    ;; Push the floor buttons
                    (push-floor-buttons cab (order.dest-floors order) (task.start-floor task))
                    ;; Update the weight of the cab
                    (incf (cab.current-weight cab) (order.weight order))
                    ;; Add in the time to get on the elevator
                    (incf (task.end-time task) (order.entry-time order))
                    ;; Add in the time spent waiting
                    (incf *total-wait-time* (- (world-clock) (order.time order)))
                    (incf *total-wait-count*))
                ;; get left behind
                (push order unanswered-orders)))
          orders)
    (if unanswered-orders
        ;; increment the wait time, and then reset the order time 
        ;; to simulate the unanswered-orders letting the elevator go and ordering
        ;; another.
        (let ((reorder-time (+ 5 (world-clock))))
          (mapc #'(lambda (order)
                    (when (>= (world-clock) (order.time order))
                      ;; (cerror "keep going" "the elevator was full and some got left behind")
                      (incf *total-wait-time* (- (world-clock) (order.time order)))
                      (setf (order.time order) reorder-time)))
                unanswered-orders)))))

;; Signal to the planner that a floor button has been pushed.
;; The local function PUSH-BUTTON does this by signalling the
;; event.  (It then returns nil because it's being used as an
;; after-filter function, and we don't care about the return 
;; value of the find-units call.)
(defun push-floor-buttons (cab floors this-floor)
  (flet ((push-button (floor-button)
	   (unless (= this-floor (button-spec.floor floor-button))
	     ;; Signal the floor button press and light the button.
	     (signal-event 'floor-button-event :unit floor-button)
	     (setf (button-spec.lit? floor-button) t)
	     nil)))
    (find-units
      'floor-button-spec
      '(building-info floor-button-specs)
      `(:and
	 (elevator-spec = ,(cab.elevator-spec cab))
	 (floor         :member = ,floors))
      :filter-after #'push-button)))

;;; Process orders waiting to get off a cab at a given floor.
(defun process-off-cab-orders (task)
  (let ((cab (sim-action.cab task)))
    (mapc #'(lambda (order)
	      (when (= (order.departure-floor order) (cab.current-floor cab))
                ;; This order is finished
		(unlinkf (cab.orders cab) order)
                ;; Update the weight of the cab
                (decf (cab.current-weight cab) (order.weight order))
                ;; Add in the time to exit the elevator
		(incf (task.end-time task) (order.exit-time order))
                ;; delete the order
                (with-repositioning-disabled
                  (delete-unit order))))
	  (cab.orders cab))))

;;; Find all orders waiting on a floor for a given direction.
(defun find-unfilled-orders (task &rest directions)
  (find-units
    'order
    '(simulator orders)
    `(:and
       (time        :within (0 . ,(world-clock)))
       (start-floor = ,(task.start-floor task))
       (bank-spec   = ,(sim-action.bank-spec task))
       (up/down     :member = ,directions)
       (answered    = nil))))

;;; Sum the entry-times of all orders getting on an elevator.
(defun get-entry-time (orders)
  (apply #'+
	 (mapcar #'(lambda (order)
		     (order.entry-time order))
		 orders)))

;;; Sum the exit-times of all orders getting off an elevator.
(defun get-exit-time (cab)
  (apply #'+
	 (mapcar #'(lambda (order)
		     (order.exit-time order))
		 (cab.orders cab))))


;;; ------------------------------------------------------------------------
;;;   Simulation Update KS
;;; ------------------------------------------------------------------------

;;; This KS will read in the orders from a file.

(define-ks READ-ORDERS
  :rating 99
  :ks-function #'(lambda (ksa)
		   (declare (ignore ksa))
		   (read-orders))
  :trigger-events ((start-control-shell-event)))


;;; Read in the orders and create an order unit for each one.

(defun READ-ORDERS ()

  (let ((input-file (kti-directory-file-pathname
                      '(kti-tools::gbb-root-open "examples")
                      *orders-file*)))

    (with-open-file (order-file input-file :direction :input)

      (loop
        (let ((order-spec (read order-file nil :eof)))
          (when (eq :eof order-spec)
            (return t))
          (let* ((time                  (first order-spec))
                 (bank                  (second order-spec))
                 (call-floor            (third order-spec))
                 (direction             (fourth order-spec))
                 (destination-floors    (fifth order-spec))
                 (weight                (sixth order-spec))
                 (departure-floor       (seventh order-spec))
                 (entry-time            (eighth order-spec))
                 (exit-time             (ninth order-spec))
                 (call-button
                   (sole-element
                     (find-units
                       (if (eq direction :up) 
                           'up-call-button-spec
                           'down-call-button-spec)
                       '(building-info call-button-specs)
                       `(:and 
                          (bank-spec = ,(get-unit bank))
                          (floor     = ,call-floor))))))
            (cond ((find-units
                     'elevator-spec
                     '(building-info elevator-specs)
                     `(:and
                        (bank-spec = ,(get-unit bank 'bank-spec))
                        (floors    :member = (,call-floor))
                        (floors    :member = ,destination-floors :match :all)
                        (floors    :member = (,departure-floor))))
                   (make-unit 'order
                              :time time
                              :call-button-spec call-button
                              :call-button-actions direction
                              :dest-floors destination-floors
                              :weight weight
                              :departure-floor departure-floor 
                              :entry-time entry-time
                              :exit-time exit-time))
                  (t
                   (cerror "Ignore this order."
                           "Can't create an order to go from ~
                              floor ~d to floor~:[~;s~] ~{~d~^~#[~; and~:;,~] ~}~@
                              because there is no elevator in bank ~a that goes between~@
                              those floors."
                           call-floor (cdr destination-floors) destination-floors bank)))))))))


;;; ------------------------------------------------------------------------
;;;   Update Modified Plan KS   
;;; ------------------------------------------------------------------------

;; This KS updates a task after important changes have been made.  For
;; example, if the start or end floor has changed, the estimated duration
;; of the task must be updated.

(define-ks UPDATE-MODIFIED-TASK
  :trigger-events ((plan-modified-event task))
  :precondition-function 'update-modified-task-precondition
  :ks-function 'update-modified-task)

(defun update-modified-task-precondition (ks events)
  ;; Determines how important it is to update this task.  If it's the
  ;; first (current) task then do it right away because the simulator
  ;; must see the new values.
  (declare (ignore ks))
  (let ((task (sole-stimulus-unit events)))
    (cond ((first-task? task)
           500)
          ((< (task.start-time task) (+ 5 (world-clock)))
           400)
          (t
           100))))

(defun update-modified-task (ksa)
  (let ((task (sole-stimulus-unit ksa)))
    (when (typep task 'move-task)
      ;; If the floors have changed than the time will change.
      (setf (task.duration task) (task-move-time task)))
    (update-estimated-time task)))


;;; ------------------------------------------------------------------------
;;;   Floor Button Request KS
;;; ------------------------------------------------------------------------

;; This KS will add a task (possibly modifying the existing plan) to take
;; the elevator to the designated floor(s).

(define-ks FLOOR-BUTTON-REQUEST-KS
  :rating 100
  :trigger-events ((floor-button-event floor-button-spec))
  :ks-function 'floor-button-request)

(defun floor-button-request (ksa)
  (let* ((button (sole-stimulus-unit ksa))
         (destination (button-spec.floor button))
         (elevator (floor-button-spec.elevator-spec button))
         (next-task (plan-door-cycle elevator destination)))
    (when next-task (insert-door-cycle destination next-task))))
      
;;; ------------------------------------------------------------------------

(defun first-task? (task)
  ;; Returns true if this is the first task in the elevator's task queue.
  ;; This should also be the task currently executing on the simulator.
  (null (task.previous-task task)))

(defun last-task? (task)
  ;; Returns true if this is the last task in the elevator's task queue.
  ;; This should be the wait task.
  (null (task.next-task task)))

(defmethod first-plan-task ((task-list cons) &optional not-this-task)
  (dolist (task task-list)
    (when (and (first-task? task)
	       (not (eq task not-this-task)))
      (return task))))

(defmethod first-plan-task ((task basic-task) &optional not-this-task)
  (when not-this-task
    (error "Can't supply NOT-THIS-TASK argument in this context."))
  (do ((p task (task.previous-task p)))
      ((first-task? task)
       p)))

(defmethod last-plan-task ((task-list cons) &optional not-this-task)
  (dolist (task task-list)
    (when (and (last-task? task)
	       (not (eq task not-this-task)))
      (return task))))

(defmethod last-plan-task ((task basic-task) &optional not-this-task)
  (when not-this-task
    (error "Can't supply NOT-THIS-TASK argument in this context."))
  (do ((p task (task.next-task p)))
      ((last-task? p)
       p)))

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

(defun search-plan (elevator predicate)
  ;; Returns the first task from ELEVATOR'S task queue for which
  ;; PREDICATE returns true.  Returns nil if no task satisfies
  ;; PREDICATE.
  (do ((task (first-plan-task (elevator-spec.tasks elevator))
             (task.next-task task)))
      ((null task)
       nil)
    (when (funcall predicate task)
      (return task))))

(defun show-plan (obj &optional reverse?)
  (let ((start-task
         (etypecase obj
           (string (first-plan-task (elevator-spec.tasks (get-unit obj))))
           (elevator-spec (first-plan-task (elevator-spec.tasks obj)))
           (task obj))))
    (do ((task start-task (if reverse? (task.previous-task task) (task.next-task task)))
         (i 0 (if reverse? (1- i) (1+ i))))
	((null task))
      (format t "~%~2d: ~s~30t(~2d ~2d)~40t~3d ~3d ~3d task: ~s"
              i
	      (unit-name task)
	      (task.start-floor task)
	      (task.end-floor task)
	      (task.start-time task)
	      (task.end-time task)
	      (task.duration task)
              (etypecase task
                (wait-task "wait-task")
                (door-cycle-task "door-cycle")
                (move-down-task "move-down")
                (move-up-task "move-up")
                (task "? task"))))))

(defun show-plans ()                    ; Useful function to show all the plans
  (mapc #'(lambda (unit) 
            (format *standard-output* "~% elevator ~s" (elevator-spec.cab unit)) 
            (show-plan unit)) 
        (find-units 'elevator-spec '(building-info elevator-specs) :all))
  nil)

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

(defun insert-door-cycle (floor next-task)
  ;; insert a door cycle at the given floor before next-task
  ;; and insert or change moves around it if necessary to 
  ;; maintain continuity.
  
  ;; if next task is a wait task, change it to wait on the destination floor:
  (when (typep next-task 'wait-task)
    (setf (task.start-floor next-task) floor)
    (setf (task.end-floor next-task) floor))
  
  ;; insert door cycle and add or change moves:
  (let* ((elevator-spec (task.elevator-spec next-task))
         (previous-task (task.previous-task next-task))
         ;; here is the new door cycle:
         (door-cycle (make-unit 'door-cycle-task
                                :duration (+ (elevator-spec.start/stop-penalty elevator-spec)
                                             (elevator-spec.door-cycle-time elevator-spec))
                                :elevator-spec elevator-spec
                                :floors (make-floor-range floor floor)))
         (start-floor (if previous-task
                          (task.end-floor previous-task)
                        (cab.current-floor (elevator-spec.cab elevator-spec))))
         (end-floor (task.start-floor next-task))
         (before-move nil)
         (after-move nil)
         (speed (elevator-spec.speed elevator-spec)))
    
    ;; check if the elevator needs to move before the new door cycle.
    (cond ((and previous-task
                (typep previous-task 'move-task)
                (/= start-floor floor))
           ;; change existing move task before door cycle
           (unless (etypecase previous-task 
                     (move-up-task (> floor (task.start-floor previous-task)))
                     (move-down-task (< floor (task.start-floor previous-task))))
             (error "bad door cycle insert point"))
           (setf (task.end-floor previous-task) floor)
           (setf (task.duration previous-task)
             (* speed (abs (- floor (task.start-floor previous-task))))))
          ((< start-floor floor)
           ;; create new move up task before door cycle
           (setf before-move (make-unit 'move-up-task
                                        :duration (* speed (- floor start-floor))
                                        :floors (make-floor-range start-floor floor)
                                        :elevator-spec elevator-spec)))
          ((> start-floor floor)
           ;; create new move down task before door cycle
           (setf before-move (make-unit 'move-down-task
                                        :duration (* speed (- start-floor floor))
                                        :floors (make-floor-range start-floor floor)
                                        :elevator-spec elevator-spec))))

    ;; check if the elevator needs to move after the new door cycle
    (cond ((and (typep next-task 'move-task)
                (/= end-floor floor))
           ;; change existing move task after door cycle
           (unless (etypecase next-task 
                     (move-up-task (< floor (task.end-floor next-task)))
                     (move-down-task (> floor (task.end-floor next-task))))
             (error "bad door cycle insert point"))
           (setf (task.start-floor next-task) floor)
           (setf (task.duration next-task)
             (* speed (abs (- floor (task.end-floor next-task))))))
          ((> end-floor floor)
           ;; create new move up after door cycle
           (setf after-move (make-unit 'move-up-task
                                       :duration (* speed (- end-floor floor))
                                       :floors (make-floor-range floor end-floor)
                                       :elevator-spec elevator-spec)))
          ((< end-floor floor)
           ;; create new move down after door cycle
           (setf after-move (make-unit 'move-down-task
                                       :duration (* speed (- floor end-floor))
                                       :floors (make-floor-range floor end-floor)
                                       :elevator-spec elevator-spec))))

    ;; link up the new door cycle and (possibly) moves into the plan:
    (if before-move
        (progn
          (linkf! (task.previous-task door-cycle) before-move)
          (linkf! (task.next-task before-move) door-cycle)
          (when previous-task
            (linkf! (task.previous-task before-move) previous-task)
            (linkf! (task.next-task previous-task) before-move)))
      (when previous-task                   
        (linkf! (task.previous-task door-cycle) previous-task)
        (linkf! (task.next-task previous-task) door-cycle)))
    (if after-move
        (progn
          (linkf! (task.next-task door-cycle) after-move)
          (linkf! (task.previous-task after-move) door-cycle)
          (linkf! (task.next-task after-move) next-task)
          (linkf! (task.previous-task next-task) after-move))
      (progn
        (linkf! (task.next-task door-cycle) next-task)
        (linkf! (task.previous-task next-task) door-cycle)))
    
    ;; update estimated times for the plan
    (if before-move
        (update-estimated-time before-move (if previous-task
                                               (task.end-time previous-task)
                                             (world-clock)))
      (update-estimated-time door-cycle (if previous-task
                                            (task.end-time previous-task)
                                          (world-clock))))))

(defun plan-door-cycle (elevator-spec floor &key (up nil) (down nil))
  ;; Finds the time best time for a door cycle at the specified
  ;; floor for the specified elevator. The :up or :down key restricts
  ;; to make sure the elevator will go in the specified direction.
  ;; Returns two values:
  ;;    1. the task the door cycle should precede (or nil if the)
  ;;       elevator is already stopping of the desired floor
  ;;    2. the estimated time of the door cycle.
  
  (labels ((insert-door-cycle-before (task)
             (values task (task.start-time task)))
           (insert-door-cycle-after (task)
             (values (task.next-task task) (task.end-time task)))
           (insert-during-fall (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task))
                   (end (task.end-floor task)))                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (= floor start)
                                      (values nil (task.start-time task))
                                    (insert-during-fall next)))
                 (move-up-task (insert-door-cycle-before task))
                 (move-down-task (cond ((>= floor start) ; floor at start or above move
                                        (insert-door-cycle-before task))
                                       ((and (< floor start) ; floor within move
                                             (> floor end))
                                        (insert-door-cycle-after task))
                                       ((<= floor end) ; floor at end or below move
                                        (insert-during-fall next)))))))
           (insert-during-rise (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task))
                   (end (task.end-floor task)))                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (= floor start)
                                      (values nil (task.start-time task))
                                    (insert-during-rise next)))
                 (move-up-task (cond ((<= floor start) ; floor at start or below move
                                      (insert-door-cycle-before task))
                                     ((and (> floor start) ; floor within move
                                           (< floor end))
                                      (insert-door-cycle-after task))
                                     ((>= floor end) ; floor at end or above move
                                      (insert-during-rise next))))
                 (move-down-task (insert-door-cycle-before task)))))
           (insert-after-rise (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task)))                                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (= floor start)
                                      (values nil (task.start-time task))
                                    (insert-after-rise next)))
                 (move-up-task (insert-after-rise next))
                 (move-down-task (insert-during-fall task)))))
           (insert-after-fall (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task)))                                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (= floor start)
                                      (values nil (task.start-time task))
                                    (insert-after-fall next)))
                 (move-up-task (insert-during-rise task))
                 (move-down-task (insert-after-fall next)))))
           (find-insert-location (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task)))                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (= floor start)
                                      (values nil (task.start-time task))
                                    (find-insert-location next)))
                 (move-up-task (if (<= floor start) ; floor below to move
                                   (insert-after-rise next)
                                 (insert-during-rise task)))
                 (move-down-task (if (>= floor start) ; floor above to move to
                                     (insert-after-fall next)
                                   (insert-during-fall task))))))
           (find-insert-location-going-up (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task)))                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (and (= floor start)
                                           (not (typep next 'move-down-task)))
                                      (values nil (task.start-time task))
                                    (find-insert-location-going-up next)))
                 (move-up-task (if (> floor start) ; floor above 
                                   (insert-during-rise task)
                                 (find-insert-location-going-up next)))
                 (move-down-task (find-insert-location-going-up next)))))
           (find-insert-location-going-down (task)
             (let ((next (task.next-task task))
                   (start (task.start-floor task)))                         
               (etypecase task
                 (wait-task (insert-door-cycle-before task))
                 (door-cycle-task (if (and (= floor start)
                                           (not (typep next 'move-up-task)))
                                      (values nil (task.start-time task))
                                    (find-insert-location-going-down next)))
                 (move-down-task (if (< floor start) ; floor below 
                                     (insert-during-fall task)
                                   (find-insert-location-going-down next)))
                 (move-up-task (find-insert-location-going-down next))))))
    (cond (up
           (find-insert-location-going-up (first-plan-task (elevator-spec.tasks elevator-spec))))
          (down
           (find-insert-location-going-down (first-plan-task (elevator-spec.tasks elevator-spec))))
          (t
           (find-insert-location (first-plan-task (elevator-spec.tasks elevator-spec)))))))

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

;;; UPDATE-ESTIMATED-TIME traverses the task queue starting with the
;;; argument TASK to change the start and end times of TASK and each
;;; subsequent task that they are consistent.

(defun update-estimated-time (task &optional new-start-time)
  (when task
    (let ((start-time (or new-start-time (task.start-time task))))
      (when new-start-time 
        ;; temporarily set the start time to -1 to make sure that
        ;; changing the end time won't make the end before the start
        (setf (task.start-time task) -1))
      (if (typep task 'wait-task)
          (setf (task.duration task) (- (task.end-time task) start-time))
          (setf (task.end-time task) (+ start-time (task.duration task))))
      (when new-start-time
        (setf (task.start-time task) new-start-time)))
    (update-estimated-time
      (task.next-task task)
      (task.end-time task))))

(defun elevator-move-time (elevator start-floor end-floor)
  (* (elevator-spec.speed elevator)
     (abs (- start-floor end-floor))))

(defun task-move-time (task)
  (elevator-move-time (task.elevator-spec task)
                      (task.start-floor task)
                      (task.end-floor task)))

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

(defmethod get-elevator-current-floor ((task task))
  (cab.current-floor (elevator-spec.cab (task.elevator-spec task))))

(defmethod get-elevator-current-floor ((button floor-button-spec))
  (cab.current-floor
    (elevator-spec.cab (floor-button-spec.elevator-spec button))))
  
;;; ------------------------------------------------------------------------

(defun floor-beyond-end-floor (floor task)
  ;; Returns true if FLOOR is beyond (above if going up, or below if
  ;; going down) the destination floor of TASK.
  (etypecase task
    (move-up-task   (>= floor (task.end-floor task)))
    (move-down-task (< floor (task.end-floor task)))))

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

(defun save-current-orders (file)
  (with-open-file (stream file :direction :output)
    (format stream ";;; Random orders.~%")
    (map-units-of-class
      #'(lambda (order)
	  (format stream
		  "~%(~@{~8@s ~})"
		  (order.time order)
		  (unit-name (call-button-spec.bank-spec (order.call-button-spec order)))
		  (order.departure-floor order)
		  (order.call-button-actions order)
		  (order.dest-floors order)
		  (order.weight order)
		  (order.departure-floor order)
		  (order.entry-time order)
		  (order.exit-time order)))
      'order)
    (format stream "~2%;;; EOF.~%")))
 
;;; ------------------------------------------------------------------------
;;; Event Printing:
;;; ------------------------------------------------------------------------

(disable-event-printing 'awaken-control-shell-event)
(disable-event-printing 'quiescence-event)

;;; ------------------------------------------------------------------------
;;; Save/Restore Actions:
;;; ------------------------------------------------------------------------

(defun save-elevator-example (save-function)
  (flet ((save-variable (var)
          `(setf ,var ',(symbol-value var))))
    (when (eq save-function 'save-blackboard-database)
      (mapcar #'save-variable
              '(*world-clock*
                *wait-every-interval*
                *simulator-late-delta*)))))

(eval-when (eval load)
  (pushnew 'save-elevator-example *save-blackboard-database-form-functions*))

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