;;;; -*- Mode:COMMON-LISP; Package:LIMO-EXAMPLE; Base:10 -*-
;;;; *-* File: lapis: /u7/gbb/v-400/dev/source/gbb/examples/limo-example.lisp *-*
;;;; *-* Edited-By: Cork *-*
;;;; *-* Last-Edit: Monday, September 21, 1998  16:33:12 *-*
;;;; *-* Machine: GRANITE (Explorer II, Microcode 489) *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *                         LIMO SCHEDULING PROBLEM
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Participants in
;;;             ``Designing and Implementing Blackboard Applications''
;;;             Amherst, Massachusetts, December 5-7, 1990
;;;
;;; To run, evaluate (limo:limo-example).
;;;
;;; During input, the following ``meta'' commands are available:
;;;             :e,:q -- exit limo scheduler
;;;             :r    -- resume event printing
;;;             :s    -- suspend event printing
;;;             :h    -- print above ``meta'' command descriptions
;;;             :eval <expr> -- evaluates lisp expression
;;;
;;; Tip: Use GBB's graphics to see what is happening!
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  12-05-90 File created.
;;;  01-09-91 Updated to GBB V2.0.  (Gallagher & Corkill)
;;;  11-08-93 Updated to GBB V3.0.  (Cork)
;;;  01-12-96 Updated to GBB V3.1.  (Cork)
;;;  11-08-97 Converted to GBB V3.2.  (Cork)
;;;  09-21-98 Converted to GBB V4.0 (KTI) release.  (Cork)
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

(in-package "LIMO-EXAMPLE")

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

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

(defvar *use-limo-file-p* nil

  "*USE-LIMO-FILE-P*

If true, reads initialization data from limo-map.lisp in the examples 
directory; otherwise uses the supplied data.")

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

;; These are used by the shortest path function.
(defvar *already-computed-apsp* nil)
(defvar *apsp-matrix* nil)
(defvar *path-matrix* nil)
(defvar *places* nil)

(eval-when (compile eval load)
  ;; Size of the map in grid coordinates.
  (defparameter *map-size* '(-100 1100))
  ;; Hours of business for the Lazy Limo Co.
  (defparameter *legal-time-range* '( 0 480))
  ;; Allow an extra 90 minutes after closing for pickups close to 5:00.
  (defparameter *space-time-range* '(-1 570)))

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

(defparameter *display-windows-p* t)
(defparameter *no-interaction-p* nil)

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

(defvar *order-pause* 10

  "*ORDER-PAUSE*

Seconds to sleep after planning each order when running the continuous
example.")

(defvar *example-pause* 15

  "*EXAMPLE-PAUSE*

Seconds to sleep before restarting the continuous example.")

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

(define-space MAP ()
  ((x             :ordered #.*map-size*)
   (y             :ordered #.*map-size*)
   (waiting-place :enumerated (t nil)))
  (:unit-classes road place))

(define-space TASKS ()
  ((time          :ordered #.*space-time-range* :display-value (0 480))
   (time-interval :ordered #.*space-time-range* :display-value (0 480))
   (x             :ordered #.*map-size*)
   (y             :ordered #.*map-size*)
   (place         :enumerated :any)
   (limo          :enumerated :any)
   (task-status   :enumerated (:carrying-fare :waiting :to-waiting-place :to-pickup-fare)))
  (:unit-classes task))

(define-space ORDERS ()
  ((time         :ordered #.*space-time-range* :display-value (0 480))
   (x            :ordered #.*map-size*)
   (y            :ordered #.*map-size*)
   (pickup-time  :ordered #.*space-time-range* :display-value (0 480))
   (arrival-time :ordered #.*space-time-range* :display-value (0 480)))
  (:unit-classes order))

(define-space LIMOS ()
  ((capacity :ordered (0 10)))
  (:unit-classes limo))


;;; ------------------------------------------------------------------------
;;;   Dimension-Value Computations and Related Definitions
;;; ------------------------------------------------------------------------

;; Several of the following datatypes are represented as lists for
;; simplicity.  We use defstruct to define them anyway as an easy
;; way to define accessor functions for the components

;;; TIME-PLACE-LIST is a list of time and place tuples.
;;; If is represented as follows:
;;;   ((<time-1> <place-1>)
;;;    (<time-2> <place-2>)
;;;    ...)

(defstruct (TIME-PLACE (:type list) (:conc-name tp-))
  time
  place)

(define-dimension-value-computation TIME-PLACE-LIST-DVC
  ((time   :point tp-time)
   (place  :label tp-place)
   (x      :point 2d-point.x place.location tp-place)
   (y      :point 2d-point.y place.location tp-place))
  (:dimension-value-computation-type :series time)
  (:element-type cons))

;;;
;;; See below for the definition of the PLACE-LIST-DVC dimension-value computation.
;;;

;;; Task status is a keyword like :carrying-fare, :to-pickup-fare, etc.

(define-dimension-value-computation TASK-STATUS-DVC
  ((task-status :label))
  (:scalar-type symbol))


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

(define-unit-class PLACE (2d-point-mixin)
  (;; This slot is inherited from the 2d-point-mixin class.
   ;; It is repeated here in order to add the :location initarg and the
   ;; place.location accessor.
   (2d-point       :initarg :location :accessor place.location)
   (waiting-place  :initform nil :initarg :waiting-place)
   (roads          :link (road connects))
   (waiting-tasks  :link (task waiting-at :singular))
   (orders         :link (order route)))
  (:dimensions
      (waiting-place waiting-place :value-type :label))
  (:paths '(map))
  (:generate-accessors waiting-place roads waiting-tasks orders))

(defmethod print-object-for-display ((place place) stream)
  (if *print-escape*
      (format stream "#<~a>" (unit-name place))
      (format stream "~a" (unit-name place))))


;; This method is required because the TASK gets its X and Y dimensional
;; values from the places that are in the PLACE slot of the TASK.  This
;; method simply repositions all the tasks that visit this place so that
;; the task's X & Y dimensional values will be correct after restoring.

(defmethod unit-restorer :after
           ((place place) saved-unit-value link-slot-names non-link-slot-names verify-only)
  (declare (ignore saved-unit-value link-slot-names non-link-slot-names))
  (unless verify-only
    (map-units-of-class
      #'(lambda (task)
          (when (member place (task.path task) :key #'tp-place :test #'eq)
            (reposition-unit task)))
      'task)))

;; Put this here so that the datatype `place-list-dvc' is defined.

(define-dimension-value-computation PLACE-LIST-DVC
  ((x :point 2d-point.x place.location)
   (y :point 2d-point.y place.location))
  (:dimension-value-computation-type :set)
  (:element-type   place))

;;; ---------------------------------------------------------------------------
  
(define-unit-class ROAD ()
   ((connects     :link (place roads) :initarg :connects)
    (normal-time  :type integer :initarg :normal-time)
    (tasks        :link (task roads)))
  :generate-accessors
  (:dimensions
      (x connects :value-type place-list-dvc)
      (y connects :value-type place-list-dvc))
  (:paths '(map)))
   
(defmethod print-object-for-display ((obj road) stream)
  (let ((connects (road.connects obj)))
    (if (and (consp connects)
             (= (length connects) 2))
        (format stream "#<ROAD ~a <-> ~a>"
                (unit-name (first connects))
                (unit-name (second connects)))
        (format stream "#<ROAD ? <-> ?>"))))

;;; ---------------------------------------------------------------------------
    
(define-unit-class TASK (time-interval-mixin)
  ((status
       :type task-status-dvc :initform :carrying-fare)
   (path
       :type time-place-list-dvc
       :initform nil       
       :slot-initialization-event-functions (initialize-task-roads))
   (waiting-at
       :link (place waiting-tasks) :singular t
       :initform nil)
   (limo
       :link (limo tasks) :singular t
       :initform nil)
   (n-passengers
       :type integer :initform 0)       
   (roads
       :link (road tasks)))
  (:dimensions
      (task-status status)
      (limo limo :value-type :label)
      (time path)
      (place path)
      (x path)
      (y path))
  (:paths '(tasks))
  :generate-accessors
  :generate-initargs)


(defmethod print-object-for-display ((obj task) stream)
  (format stream "#<~a ~a ~a ~a>"
          (type-of obj)
          (unit-name obj)
          (if (slot-boundp obj 'status)
              (task.status obj)
              "Status:?")
          (if (slot-boundp obj 'time-interval)
              (pretty-time-interval 
                (time-interval-mixin.time-interval obj))
              "Time interval:?")))

(defmethod (setf task.path) :after (nv (obj task))
  (unlinkf-all (task.roads obj))
  (when nv
    (linkf (task.roads obj) (get-roads-from-path nv))))

(defun initialize-task-roads (event-name &key unit current-value &allow-other-keys)
  (declare (ignore event-name))
  (when current-value
    (linkf (task.roads unit) (get-roads-from-path current-value))))

;;; ---------------------------------------------------------------------------
  
(define-unit-class EMPTY (TASK)
  ())

(define-unit-class CARRYING-FARE (TASK)
  ())

;;; ---------------------------------------------------------------------------
  
(define-unit-class LIMO ()
  ((capacity
       :type integer :initarg :capacity)
   (tasks
       :link (task limo :singular)))
  (:dimensions
      (capacity capacity :value-type :point))
  (:paths '(limos))
  :generate-accessors)
	
(defmethod print-object-for-display ((obj limo) stream)
  (if *print-escape*
      (format stream "#<LIMO ~a>" (unit-name obj))
      (format stream "Limo ~a" (unit-name obj))))

;;; ---------------------------------------------------------------------------
  
(define-unit-class ORDER ()
  ((route 
       :link (place orders))
   (n-passengers
       :type integer)
   (pickup-time
       :type integer :initform -1)
   (arrival-time 
       :type integer :initform -1))
  (:dimensions
      (x route :value-type place-list-dvc)
      (y route :value-type place-list-dvc)
      (pickup-time pickup-time :value-type :point)
      (arrival-time arrival-time :value-type :point))
  (:paths '(orders))
  :generate-accessors
  :generate-initargs)

(defun order.origin (order)
  (first (order.route order)))

(defun order.destination (order)
  (second (order.route order)))

;;; ------------------------------------------------------------------------
;;;   Events
;;; ------------------------------------------------------------------------

(define-event-class PLAN-COMPLETION-EVENT (single-unit-event)
  ()
  (:enable-event-printing task :permanent nil))

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

(define-event-class LIMO-EMPTIED-EVENT (single-unit-event)
  ()
  (:enable-event-printing carrying-fare :permanent nil))

(define-event-print-format limo-emptied-event (event-name &key unit
                                                          &allow-other-keys)
  (declare (ignore event-name))
  "Limo Emptied" "~A ~A"
  (task.limo unit)
  unit)

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

(define-event-class get-order-event (non-unit-event)
  ())

(defun place-order-message-event-function (&rest rest)
  (declare (ignore rest))
  ;; Only do this if the get-order-interactive-ks is enabled.
  (when (control-shells::ks.enabled (get-unit 'get-order-interactive-ks))
    (fresh-line)
    (princ "Click on the \"Place an order\" button to place an order.")))

(add-event-function 'place-order-message-event-function 
		    'control-shells::control-shell-hibernation-event)

(disable-event-printing 'get-order-event)

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

(disable-event-printing 'control-shells::control-shell-hibernation-event)


;;; ------------------------------------------------------------------------
;;;   INITIAL-KS Code
;;; ------------------------------------------------------------------------
;;;
;;; Simple initial KS that reads the map data and creates unit instances
;;; for places, roads between places, and limos.

(defun INITIAL-KS (ksa)
  (declare (ignore ksa))
  
  ;; If the space is not empty then the map must already exist.
  ;; Othersize it must be created.
  (let ((map-needed? (empty-space-p '(map))))

    (cond

      ;; Read data from limo-map.lisp file:
      (*use-limo-file-p* 
       (with-open-file (map-file (kti-directory-file-pathname
                                   '(kti-tools::gbb-root-open "examples")
                                   "limo-map"))
	 (cond (map-needed?
		(dolist (place-desc (read map-file))
		  (create-place place-desc))
		(dolist (road-desc (read map-file))
		  (create-road road-desc)))
	       (t
		;; Skip the place and roads.
		(read map-file)
		(read map-file)))
	 (dolist (limo-desc (read map-file))
	   (dotimes (i (first limo-desc))
	     (make-unit 'limo :capacity (second limo-desc))))))

      ;; Use internal data:
      (t
       (when map-needed?
	 ;; Places
	 (dolist
	     (place-desc
		 '(("Acme Manufacturing"        :location (020 040))
		   ("Mile Long Mall"            :location (020 980) :waiting-place t)
		   ("Mammoth Multicinema"       :location (150 920))
		   ("Piggly Wiggly"             :location (120 350))
		   ("County Hospital"           :location (180 150) :waiting-place t)
		   ("Golden Age Village"        :location (300 400) :waiting-place t)
		   ("Larry's Laundry and Video" :location (350 240))
		   ("Dave's Deli"               :location (360 120))
		   ("Lakeside Park"             :location (400 020))
		   ("Board of Trade"            :location (350 500))
		   ("Lazy Limo Co"              :location (450 640) :waiting-place t)
		   ("North Station"             :location (650 020) :waiting-place t)
		   ("Monroe Square Garden"      :location (500 470))
		   ("City Hall"                 :location (580 560))
		   ("Seventh National Bank"     :location (550 360))
		   ("Green Acres"               :location (640 820))
		   ("Metro Airport"             :location (800 350) :waiting-place t)
		   ("Big View Apartments"       :location (830 210))
		   ("9/16 Convenience Store"    :location (900 190))
		   ("J-Mart"                    :location (920 950))
		   ("Ted's Wharf"               :location (990 510))
		   ("Park Place"                :location (160 700))))
	   (create-place place-desc))

	 ;; Roads
	 (dolist
	     (road-desc
		 `(("Acme Manufacturing"    "Piggly Wiggly"          :normal-time 16)
		   ("Mile Long Mall"        "Mammoth Multicinema"    :normal-time 6)
		   ("Piggly Wiggly"         "County Hospital"        :normal-time 4)
		   ("County Hospital"       "Golden Age Village"     :normal-time 8)
		   ("Piggly Wiggly"         "Golden Age Village"     :normal-time 9)
		   ("Larry's Laundry and Video" "Dave's Deli"        :normal-time 8)  
		   ("Larry's Laundry and Video" "Golden Age Village" :normal-time 4)  
		   ("Acme Manufacturing"    "Lakeside Park"          :normal-time 25)
		   ("Board of Trade"        "Lazy Limo Co"           :normal-time 5)
		   ("Board of Trade"        "Monroe Square Garden"   :normal-time 6)
		   ("North Station"         "Lakeside Park"          :normal-time 6)
		   ("Monroe Square Garden"  "City Hall"              :normal-time 8)
		   ("City Hall"             "Seventh National Bank"  :normal-time 9)
		   ("Big View Apartments"   "9/16 Convenience Store" :normal-time 4)
		   ("J-Mart"                "Green Acres"            :normal-time 20)
		   ("Ted's Wharf"           "Green Acres"            :normal-time 31)
		   ("Metro Airport"         "Big View Apartments"    :normal-time 8)
		   ("Metro Airport"         "Seventh National Bank"  :normal-time 12)
		   ("City Hall"             "Green Acres"            :normal-time 20)
		   ("Lazy Limo Co"          "Green Acres"            :normal-time 24)
		   ("Metro Airport"         "Ted's Wharf"            :normal-time 18)
		   ("Lazy Limo Co"          "Mammoth Multicinema"    :normal-time 30)
		   ("North Station"         "Metro Airport"          :normal-time 31)
		   ("Monroe Square Garden"  "Dave's Deli"            :normal-time 24)
		   ("Park Place"            "Mammoth Multicinema"    :normal-time 28)
		   ("Park Place"            "Board of Trade"         :normal-time 30)
		   ("Park Place"            "Piggly Wiggly"          :normal-time 29)
		   ("Dave's Deli"           "North Station"          :normal-time 6)))
	   (create-road road-desc)))

       ;; Limos
       ;; (<n-limos> <capacity>)
       (dolist (limo-desc '((3 4)
			    (2 6)))
	 (dotimes (i (first limo-desc))
	   (make-unit 'limo :capacity (second limo-desc))))))
  
  ;; Create the initial waiting task for each limo object:
  (map-units-of-class #'initialize-limo-task '(limo))))
       
;;; ---------------------------------------------------------------------------

(defun INITIALIZE-LIMO-TASK (limo-unit)
  (make-wait-task (place-named "Lazy Limo Co")
		  (copy-list *legal-time-range*)
		  :limo limo-unit))

(defun make-wait-task (place interval &rest args)
  (apply #'make-unit 'empty
         :status :waiting
         :time-interval interval
         :path (list
                 (list (time-interval.start interval) place)
                 (list (time-interval.end interval) place))
         :waiting-at place
         :n-passengers 0
         :roads nil
         args))

(defun change-task-to-wait-task (task place interval)
  (setf (task.status task) :waiting)
  (setf (time-interval-mixin.time-interval task) interval)
  (setf (task.path task) (list
			  (list (time-interval.start interval) place)
			  (list (time-interval.end interval) place)))
  task)

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

(defun CREATE-PLACE (place-desc)
  (apply #'make-unit 'place :NAME place-desc))

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

(defun CREATE-ROAD (road-desc)
  (apply #'make-unit 'road
         :connects `(,(place-named (first road-desc))
                     ,(place-named (second road-desc)))
         (cddr road-desc)))
	     
;;; ------------------------------------------------------------------------

(defun limo-example-startup ()

  ;; Decide whether to use interactive GET-ORDER-KS or canned
  ;; GET-ORDERS-KS based on value of no-interaction:
  (cond (*no-interaction-p*
         (disable-ks 'get-order-ks)
	 (disable-ks 'get-order-interactive-ks)
         (enable-ks 'get-orders-ks)
         (enable-ks 'pause-ks))
        (t 
	 (disable-ks 'get-orders-ks)
	 (disable-ks 'pause-ks)
	 (cond (*display-windows-p*
		(disable-ks 'get-order-ks)
		(enable-ks 'get-order-interactive-ks))
	       (t
		(disable-ks 'get-order-interactive-ks)
		(enable-ks 'get-order-ks)))))

  ;; Setup the blackboard
  (with-graphics-operations-deferred ()
    (cond ((space-instance-exists-p '(map))
	   ;; Delete old unit instances
	   (delete-blackboard-database
	     :retain-space-instances '((map)))
	   (instantiate-blackboard-database 'tasks 'orders 'limos))
	  (t
	   (instantiate-blackboard-database 'map 'tasks 'orders 'limos))))
 
  ;; Reset path-finding variables.
  (setf *already-computed-apsp* nil
        *apsp-matrix* nil
        *path-matrix* nil)
  (format *event-print-stream*
          "~2&;;; Running the limo scheduling example....~%"))

;; Add to control shell initialization hooks:

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

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

(defun limo-example-entry ()
  ;; Startup graphics if present.
  ;; (This is slightly complicated by the fact that the limo graphics
  ;; may not be loaded so you can't simply simply call
  ;; SETUP-LIMO-WINDOWS.)
  (when (and *display-windows-p* (fboundp 'setup-limo-windows))
    (with-graphics-operations-deferred ()
      (setup-limo-windows))))

;; Add to control shell entry hooks:

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

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

(defun limo-example-exit ()
  (describe-blackboard-database t)
  (format *event-print-stream*
          "~2&;;; Exiting the control shell...~%")
  (when *no-interaction-p*
    (format t "~%Pausing....")
    (sleep *example-pause*)
    (format t "~%Continuing....")))

;; Add to control shell exit hooks:

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

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

(defun LIMO-EXAMPLE (&optional display-windows *no-interaction-p*)
  ;; Have the control shell hibernate on quiescence
  (if *no-interaction-p*
    (setf control-shells::*hibernate-on-quiescence-p* nil)
    (setf control-shells::*hibernate-on-quiescence-p* t))
  
  ;; Set *display-windows-p* (rather than bind it) so that
  ;; resume-control-shell will resume the limo application in the same
  ;; configuration as it was started in.
  (setf *display-windows-p* display-windows)
  #+(and CL-ALLEGRO OS-WINDOWS)
  (when (find-package :chalkbox)
    (funcall (intern "CLEAR-LISP-LISTENER" :chalkbox)))
  ;; Run the control shell.
  ;; Most of the setup is done by limo-example-startup.
  (start-control-shell :event-print-stream *standard-output*))

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

;;; The following function runs a canned limo-example application repeatedly
;;; until aborted:

(defun CONTINUOUS-LIMO-EXAMPLE (&optional (setup-windows t)
                                (no-interaction t))
  (loop (limo-example setup-windows no-interaction)))


;;; ------------------------------------------------------------------------
;;;   ASSIGN-LIMO-KS Code
;;; ------------------------------------------------------------------------
;;;
;;; This KS is triggered when a carrying-fare task is created.  It
;;; determines whether a limo is available to take this task.  If so,
;;; the new task is spliced into the task list for that limo.

;;
;;  Still to do::
;;
;;  - Check that the chosen limo can carry the desired number of passengers.
;;  - There may be a better limo to choose.  We just take the first available
;;    one.

(defun ASSIGN-LIMO (ksa)
  (let* ((carrying-fare (sole-stimulus-unit ksa))
         (current-task-list (find-available-limo carrying-fare)))
    (unless current-task-list
       (format t "~2%Can't assign a limo for ~s.~%~s~2%"
               carrying-fare
               (mapcar #'tp-place (task.path carrying-fare)))
       (return-from assign-limo nil))
;    (linkf (task.limo carrying-fare) (task.limo (car current-task-list)))
     (format t "~%Assigning ~a to pickup ~d passenger~:*~p at ~a from ~a.~@
                Drop off is at ~a at ~a."
;            (task.limo carrying-fare)  ; replaced with following line due to above linkf
                                        ; removal
	     (task.limo (car current-task-list))
             (task.n-passengers carrying-fare)
             (pretty-time (time-interval-mixin.start carrying-fare))
             (path.first-place (task.path carrying-fare))
             (pretty-time (time-interval-mixin.end carrying-fare))
             (path.last-place (task.path carrying-fare)))
     (modify-task-list carrying-fare current-task-list)
     (signal-event 'limo-emptied-event :unit carrying-fare)))


;;; This function looks to see if any limo is available for this
;;; carrying-fare task.  If it finds a limo, it returns the list of
;;; tasks for that limo that overlaps with time interval of the new
;;; task.  (For now, these tasks will all be either waiting or en route
;;; to waiting.) The new task will then be spliced into the task list
;;; for the limo.

(defun FIND-AVAILABLE-LIMO (task)
  (map-units-of-class
    #'(lambda (limo)
        (let ((tasks (limo-available? limo task)))
          (when tasks
            (return-from find-available-limo tasks))))
    'limo))

;;; This function looks at one limo to see if it can do the task.

(defun LIMO-AVAILABLE? (limo new-task)
  
  (let* ((time-interval (time-interval-mixin.time-interval new-task))
         (current-tasks (find-candidate-tasks limo time-interval)))

    ;; If all the current tasks of the limo are either waiting or en route to
    ;; waiting, and if the limo can get from where it started being
    ;; available to the place of origin of the new order, at the appropriate 
    ;; time, and then from the destination place of the order to where it is 
    ;; next required, at the appropriate time, then the limo can handle the 
    ;; task. Therefore, return the current task list.
    (when (and current-tasks
               (every #'(lambda (task)
                          (member (task.status task)
                                  '(:waiting :to-waiting-place)))
                      current-tasks)
               (limo-can-get-to-origin new-task current-tasks)
               (limo-can-get-from-destination new-task current-tasks))
      current-tasks)))


;; Search the TASKS space to find empty tasks that satisfy the following
;; criteria:
;;
;;   - The task belongs to the limo we're looking at.
;;   - The task's time interval overlaps with the new task's interval.

(defun FIND-CANDIDATE-TASKS (limo time-interval)
  (find-units 'empty '(tasks)
    `(:and (limo = ,limo)
           (time-interval-mixin-dvc :overlaps ,time-interval))))


;;; Returns true if the limo can get from where it became available
;;; to the origin of the new task, in the time available.

(defun LIMO-CAN-GET-TO-ORIGIN (new-task current-tasks)
  (let* (;; New task
         (start-time (time-interval-mixin.start new-task))
         (start-place (task.first-place new-task))
         ;; First (in time) of the current tasks
         (t1 (earliest-task current-tasks))
         (t1-start-place (task.first-place t1))
         (t1-start-time (time-interval-mixin.start t1))
         ;; Path from T1's start place to NEW-TASK's start-place
         (path (find-path t1-start-place start-place t1-start-time -1))
         ;; Time to travel from T1's start place to NEW-TASK's start-place
         (travel-time (time-over-path path)))
    (values
      (< (+ travel-time t1-start-time) start-time)
      path)))

;;; Returns true if the limo can get from the destination of the new
;;; task to where it is next needed, in the time available.

(defun LIMO-CAN-GET-FROM-DESTINATION (new-task current-tasks)
  (let* (;; New task
         (end-time (task.last-time new-task))
         (end-place (task.first-place new-task))
         ;; Last of the current tasks
         (t1 (latest-task current-tasks))
         (t1-end-place (task.last-place t1))
         (t1-end-time (task.last-time t1))
         ;; Path from T1's end place to NEW-TASK's end-place
         (path (find-path end-place t1-end-place end-time -1))
         ;; Time to travel from T1's end place to NEW-TASK's end-place
         (travel-time (time-over-path path)))
    (values
      (< (+ travel-time end-time)
         t1-end-time)
      path)))


;;; Modify the task list to splice in the new task.  Note that the tasks
;;; are linked to the limos and are not maintained in any order.
;;; Task-list is a list of the tasks for the selected limo that overlap
;;; with the time interval of the new task.

(defun MODIFY-TASK-LIST (new-task task-list)
  (case (length task-list)
    (1 (modify-task-list-1 new-task (first task-list)))
    (2 (modify-task-list-2
	 (earliest-task task-list) new-task (latest-task task-list)))
    (otherwise (modify-task-list-* new-task task-list))))


(defun MODIFY-TASK-LIST-* (new-task task-list)
  ;; Find the earliest and latest tasks, delete any others,
  ;; and insert the new task in the middle.

  (let ((t1 (earliest-task task-list))
        (tn (latest-task task-list)))

    ;; Delete all the intermediate tasks.
    ;; (These will all be :waiting or :to-waiting-place)
    (dolist (tsk task-list)
      (unless (or (eq tsk t1) (eq tsk tn))
        (delete-unit (car tsk))))

    (modify-task-list-2 t1 new-task tn)))


(defun MODIFY-TASK-LIST-1 (new-task the-task)

  (let* ((t1-limo (task.limo the-task))
         (new-time-interval (time-interval-mixin.time-interval new-task))
         (tn 
           ;; Create a new task to fill in after the new task is added.
           ;; This will get updated by modify-task-list-2.
           (make-wait-task (task.last-place new-task)
                           (make-time-interval
                             :start (time-interval.end new-time-interval)
                             :end (task.last-time the-task))
                           :limo t1-limo)))
    (modify-task-list-2 the-task new-task tn)))


(defun MODIFY-TASK-LIST-2 (t1 new-task tn)
  
  (let ((t1-interval (time-interval-mixin.time-interval t1))
        (t1-limo (task.limo t1))
        (new-interval (time-interval-mixin.time-interval new-task))
        (origin (task.first-place new-task)))

    (case (task.status t1)
      ;; For now, only handle waiting and to-waiting-place.

      (:WAITING
       (cond ((eq (task.last-place t1) origin)
              ;; Limo is already at the origin.
              ;; Just shorten the time interval that t1 is waiting.
              (with-destructively-changed-dimension-values (t1 :time :time-interval)
                (setf (time-interval-mixin.end t1) (time-interval.start new-interval))
	        (setf (path.last-time (task.path t1)) (time-interval.start new-interval))))
             (t
              ;; Add a :to-pickup-fare task to get the limo to the origin
              ;; and shorten the time interval that t1 is waiting.
              (let ((path (find-path (task.last-place t1)
                                     origin
                                     -1 (task.first-time new-task))))
                (make-unit 'empty
                           :time-interval (make-time-interval
                                            :start (path.first-time path)
                                            :end (path.last-time path))
                           :status :to-pickup-fare
                           :limo t1-limo
                           :path path)
                (with-destructively-changed-dimension-values (t1 :time :time-interval)
		  (setf (time-interval-mixin.end t1) (path.first-time path))
                  (setf (path.last-time (task.path t1)) (path.first-time path)))))))

      (:TO-WAITING-PLACE
       (cond ((eq (task.first-place t1) origin)
              ;; Limo was at the origin and is now moving.
              ;; Modify the task to just wait.
	      (change-task-to-wait-task
	        t1
		origin
		(make-time-interval
		  :start (time-interval.start t1-interval)
		  :end (time-interval.start new-interval))))
             (t
              ;; Limo was somewhere else.
              ;; Modify the task to be en-route to the origin.
              (let ((path (find-path (task.first-place t1)
                                     origin
                                     -1 (task.first-time new-task))))
                (setf (task.status t1) :to-pickup-fare)
                (setf (task.path t1) path)
                (setf (time-interval-mixin.time-interval t1)
                      (make-time-interval
                        :start (path.first-time path)
                        :end (path.last-time path)))
                (unlinkf-all (task.waiting-at t1)))))))

    ;; Modify the proposed new task.
    ;; The path and number of passengers should be set by the PLAN-FARE function.
    (setf (task.status new-task) :carrying-fare)
    (linkf (task.limo new-task) t1-limo)

    ;; Modify the last task for the final part of the time interval.
    (let ((tn-interval
	    (make-time-interval
	      :start (time-interval.end new-interval)
	      :end (time-interval-mixin.end tn))))
      (cond ((eq (task.last-place new-task) (task.last-place tn))
	     (change-task-to-wait-task tn (task.last-place tn) tn-interval))
	    (t
	     (setf (time-interval-mixin.time-interval tn) tn-interval)
	     (setf (task.path tn) (find-path (task.last-place new-task)
					     (task.last-place tn)
					     (task.last-time new-task)
					     (task.last-time tn))))))))


(defun EARLIEST-TASK (task-list)
  (let* ((task (first task-list))
	 (time (time-interval-mixin.start task)))
    (dolist (tk task-list)
      (when (< (time-interval-mixin.start tk) time)
	(setf task tk
	      time (time-interval-mixin.start tk))))
    task))

(defun LATEST-TASK (task-list)
  (let* ((task (first task-list))
	 (time (time-interval-mixin.end task)))
    (dolist (tk task-list)
      (when (> (time-interval-mixin.end tk) time)
	(setf task tk
	      time (time-interval-mixin.end tk))))
    task))

(defun task.first-place (task)
  (path.first-place (task.path task)))

(defun task.last-place (task)
  (path.last-place (task.path task)))

(defun task.first-time (task)
  (time-interval-mixin.start task))

(defun task.last-time (task)
  (time-interval-mixin.end task))


;; In the following path.xxx functions, the <path> argument is a time-place 
;; list.

(defun path.first-place (path)
  (tp-place (first path)))

(defun path.last-place (path)
  (tp-place (first (last path))))

(defun path.first-time (path)
  (tp-time (first path)))

(defun path.last-time (path)
  (tp-time (first (last path))))

(defmethod (setf path.last-time) (new-time path)
  (setf (tp-time (first (last path))) new-time))


(defun GET-ROADS-FROM-PATH (path)
  ;; <path> is a time place list.
  (unless (null (cdr path))
    (let ((p1 (tp-place (first path)))
	  (p2 (tp-place (second path))))
      (cons (or (find p2 (place.roads p1)
		      :test #'(lambda (place road)
				(member place (road.connects road))))
		(error "Can't find a path from ~a to ~a." p1 p2))
	    (get-roads-from-path (cdr path))))))

;; Compute the duration of the trip over the path.  It's simply the
;; difference between the time at the last place on the path and
;; the time at the first place on the path.

(defun TIME-OVER-PATH (path)
  (if (null path)
      0
      (- (tp-time (first (last path)))
         (tp-time (first path)))))

(defun SHOW-LIMO-TASKS ()
  (map-units-of-class #'show-limo-tasks-1 'limo))

(defun SHOW-LIMO-TASKS-1 (limo)
  (format t "~2%~s" limo)
  (dolist (task (sort (copy-list (limo.tasks limo)) #'< :key #'task.first-time))
    (format t "~%  ~s~%~8t~{~a~^ -> ~}"
            task
            (mapcar #'(lambda (tp) (unit-name (tp-place tp))) (task.path task)))))


;;; ------------------------------------------------------------------------
;;;   PLAN-FARE-KS Code
;;; ------------------------------------------------------------------------
;;;

(defun PLAN-FARE (ksa)
  
  (let* ((trigger-order (sole-stimulus-unit ksa))
         (pickup-time (order.pickup-time trigger-order))
         (new-path
           (find-path (order.origin trigger-order)
                      (order.destination trigger-order)
                      pickup-time
                      -1)))
    (unless new-path
      (format t "~2%Can't assign a limo when the source and destination are the same.")
      (return-from plan-fare))
    (setf (order.arrival-time trigger-order) (path.last-time new-path))
    (make-unit 'carrying-fare
               :path new-path
               :time-interval (make-time-interval
                                :start pickup-time
                                :end (+ pickup-time (time-over-path new-path)))
               :n-passengers (order.n-passengers trigger-order))))


;;; ------------------------------------------------------------------------
;;;   GET-ORDER-KS Code
;;; ------------------------------------------------------------------------
;;;
;;;
;;;  Get orders from the keyboard, when no other knowledge sources are active.
;;;  

(defun GET-ORDER (ksa)
  (with-abort-computation-handler
      (catch 'get-order-tag
	(if *display-windows-p*
	    ;; Use interactive get order
	    (get-order-interactive ksa)
	  ;; Otherwise get input from keyboard
	  (let ((origin (place-named (ask-user "~&Origin? ")))
		(destination (place-named (ask-user "~&Destination? ")))
		(pickup-time (ask-time "~&Pickup time [hh:mm]? "))
		(n-passengers (read-from-string
			       (ask-user "~&Number of passengers? "))))
	    (make-unit 'order
		       :route (list origin destination)
		       :pickup-time pickup-time
		       :n-passengers n-passengers))))))

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

(defun ASK-USER (prompt)
  (let ((result nil))
    (loop
      (format t prompt)
      (setf result (read-line))
      (cond ((string-equal result ":q")
             (abort-computation :STOP))
            ((string-equal result ":s")
             (suspend-event-printing)) 
            ((string-equal result ":r")
             (resume-event-printing))
            ((string-equal result ":h")
             (format t "~& Commands:")
             (format t "~%~5t:q  -- exit limo scheduler")
             (format t "~%~5t:r  -- resume event printing")
             (format t "~%~5t:s  -- suspend event printing")
	     (format t "~%~5t:e  -- evaluate lisp expression"))
	    ((member result '(":e" ":eval") :test #'string-equal)
	     (format t "~%Enter a LISP expression: ")
	     (print (kti::simple-eval (read))))
            (t (unless (string= result "")
                 (return result))
               (format t "~&Please enter something."))))))

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

(defun PLACE-NAMED (name)

  "Returns a place object corresponding to `name'. `Name' may be abbreviated."

  (flet ((short-named (name)
           ;; Look for a place for which the name contains `name' as a 
           ;; substring.
           (map-units-of-class
             #'(lambda (unit)
                 (when (search name (unit-name unit) :test #'char-equal)
                   (return-from short-named unit)))
             'place)))

    (or (get-unit name 'place)
        (let ((full-name (short-named name)))
          (when full-name
            (format t "     [~a]" full-name)
            full-name))
        (progn
          (format *error-output*
                  "~2&Can't find a place named ~a.~@
                   Valid names are:~&~{~&~5t~a~}"
                  name
                  (all-place-names))
          (place-named (ask-user "~&Enter a place name. "))))))

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

(defun all-place-names ()
  (let ((names nil))
    (map-units-of-class #'(lambda (unit)
                            (push (unit-name unit) names))
                        'place)
    (sort names #'string<)))
  
;;; ------------------------------------------------------------------------

(defun ASK-TIME (prompt)
  (let (time)
    (loop
      (setf time (parse-time (ask-user prompt)))
      (when (and (numberp time)
                 (<= (first *legal-time-range*)
                     time
                     (second *legal-time-range*)))
        (return time))
      (format t "~&Please enter the time as hh:mm.~@
                 Also the time must be between ~a and ~a.~%"
              (pretty-time (first *legal-time-range*))
              (pretty-time (second *legal-time-range*))))))

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

;; Converts from `limo time' (minutes past 9:00am) to hh:mm.

(defun pretty-time (time)
  (multiple-value-bind (hours minutes)
      (floor time 60)
    (setf hours (mod (+ 9 hours) 12))
    (format nil "~d:~2,'0d" (if (zerop hours) 12 hours) minutes)))

(defun pretty-time-interval (interval)
  (list 
    (pretty-time (time-interval.start interval))
    (pretty-time (time-interval.end interval))))

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

;; This function parses a string of the form hh[:mm] and returns the
;; number of minutes past 9:00.  If the argument string is not a valid
;; time then it returns nil.

(defun parse-time (text)

  (flet ((hhmm->minutes (hours minutes)
           ;; Compute the number of minutes past 9:00
           (- (+ (* hours 60) minutes) (* 9 60))))

    (multiple-value-bind (hours index)
        (parse-integer text :junk-allowed t)
    
      ;; If hours are invalid fail validity check
      (unless (and hours 
                   (or (<= 9 hours 12) (<= 1 hours 5)))
        (return-from parse-time nil))
    
      ;; Convert to 24 hour clock
      (when (<= hours 5)
        (incf hours 12))
   
      ;; Hours only?, otherwise neeed a ":" 
      (if (>= index (length text))
          (return-from parse-time (hhmm->minutes hours 0))
          (unless (char= (aref text index) #\:)
            (return-from parse-time nil)))

      ;; Hours are ok, the ":" is there, so  check minutes:
      (multiple-value-bind (minutes)
          (parse-integer text :start (1+ index) :junk-allowed t)
        (if (and minutes (<= 0 minutes 60))
            (hhmm->minutes hours minutes)
            nil)))))


;;; ------------------------------------------------------------------------
;;;   FIND-PLACE-TO-WAIT-KS Code
;;; ------------------------------------------------------------------------
;;;
;; A precondition function that determines whether the destination 
;; happens to be a waiting place.  If it is a waiting place, a KS need not be
;; scheduled to plan a route to a waiting place.

(defun END-PLACE-IS-WAITING-PLACE-P (ks events)
  (declare (ignore ks))
  (let* ((new-task (sole-stimulus-unit events))
         (end-place (task.last-place new-task)))
    (if (place.waiting-place end-place)
        :fail
        102)))


(defun FIND-PLACE-TO-WAIT-KS (ksa)
  ;; Find variables for the function.
  (let* ((trigger (if (typep ksa 'control-shell-ksa)
		      (sole-stimulus-unit ksa)
                      ksa))
         (last-time (task.last-time trigger))
         (last-place (task.last-place trigger))
         (min-interval 1000)
         (proposed-path nil)
         
         ;; Get all waiting places.
         (waiting-places
	  (find-units 'place '(map) `(waiting-place = t)))
         (wait-task
	  (sole-element
            (find-units 'empty '(tasks)
                 `(:and (task-status = :waiting)
                        (limo = ,(task.limo trigger))
                        (time-interval-mixin-dvc :overlaps (,last-time ,last-time)))))))
    
    ;; find-path(a,b,ts,te) -> time-place-list 
    (dolist (w-place waiting-places) 
      (let* ((path (find-path last-place w-place last-time -1))
             (interval (time-over-path path)))
        (when (> min-interval interval)
          (setf min-interval interval)
          (setf proposed-path path))))

    ;; Still need to modify the limo's task list to include the route
    ;; from the ending place to the waiting place.
    (make-unit 'empty
               :status :to-waiting-place
               :path proposed-path
               :time-interval (make-time-interval
                                :start last-time
                                :end (path.last-time proposed-path))
               :n-passengers 0
               :limo (task.limo trigger))

    (change-task-to-wait-task wait-task
			      (path.last-place proposed-path)
			      (make-time-interval
 			        :start (path.last-time proposed-path)
			        :end (time-interval-mixin.end wait-task)))
    (signal-event 'plan-completion-event :unit trigger)))


;;; ------------------------------------------------------------------------
;;;   GET-ORDERS-KS Code
;;; ------------------------------------------------------------------------
;;;
;;;
;;;  Get orders from the keyboard, when no other knowledge sources are active.
;;;  

(defun GET-ORDERS (ksa)
  (declare (ignore ksa))
  (flet ((make-an-order (origin-name destination-name pickup-time
                                     n-passengers)
           (make-unit 'order
                      :route (list (get-unit origin-name 'place)
                                   (get-unit destination-name 'place))
                      :pickup-time pickup-time
                      :n-passengers n-passengers)))
    (make-an-order "J-Mart" "Acme Manufacturing" 300 1)
    (make-an-order "Metro Airport" "City Hall" 60 2)
    (make-an-order "Mile Long Mall" "Ted's Wharf" 120 1)
    (make-an-order "Park Place" "Lakeside Park" 240 2)
    (make-an-order "Green Acres" "Park Place" 180 1)))


;;; ------------------------------------------------------------------------
;;;   FIND-PATH Routine (Not a KS!)
;;; ------------------------------------------------------------------------

(defun FIND-PATH (place-1 place-2 ts te)

  (unless (eq place-1 place-2)
    
    (unless *already-computed-apsp*
      (let ((places nil)
            (n-places 0)
            cost-matrix)
        (map-units-of-class #'(lambda (unit)
                                (push unit places)
                                (incf n-places))
                            'place)
        (setf cost-matrix
              (make-array (list n-places n-places)
                          :element-type t 
                          :initial-element 0))
        (dotimes (i n-places)
          (dotimes (j n-places)
            (unless (= i j)
              ;; Fill the cost matrix with the travel times between directly
              ;; connected places.
              (let ((road (find (place.roads (nth i places))
				(place.roads (nth j places))
				:test #'(lambda (roads s) (member s roads :test #'eq)))))
                (setf (aref cost-matrix i j)
                      (if road (road.normal-time road) 100000))))))
        (floyd cost-matrix places n-places)))

    (let ((path-list (cons place-1
                           (nconc (extract-path *apsp-matrix* *path-matrix*
                                                place-1 place-2 *places*)
                                  (list place-2)))))
      (if (= ts -1)
          (nreverse (return-result (nreverse path-list) *apsp-matrix* te *places* #'-))
          (return-result path-list *apsp-matrix* ts *places* #'+)))))
     

(defun RETURN-RESULT (path-list result-matrix time-so-far places fn)
  ;; Build a time place list from the ordered list of the
  ;; places on the path.
  (cond ((null (rest path-list))
	 `((,time-so-far ,(car path-list))))
	(t
	 (let ((new-t (funcall fn time-so-far
                               (aref result-matrix
                                     (position (car path-list) places)
                                     (position (cadr path-list) places)))))
	   (cons `(,time-so-far ,(car path-list))
                 (return-result (cdr path-list) result-matrix new-t places fn))))))


(defun EXTRACT-PATH (cost-matrix path-matrix p1 p2 places)
  (let* ((p1-dv (position p1 places))
	 (p2-dv (position p2 places))
	 (p3 (aref path-matrix p1-dv p2-dv)))
    (if (eq p3 nil)
        nil
        (nconc (extract-path cost-matrix path-matrix p1 p3 places)
               (cons p3
                     (extract-path cost-matrix path-matrix p3 p2 places))))))

;;; This is the standard Floyd all-pairs-shortest-path algorithm:

(defun FLOYD (A places n)
  (let* ((P (make-array `(,n ,n) :element-type t :initial-element nil)))
    (dotimes (k n)
      (dotimes (i n)
	(dotimes (j n)
	  (let ((new-cost (+ (aref A i k) (aref A k j))))
	    (when (< new-cost
		     (aref A i j))
	      (let ((place (nth k places)))
		(setf (aref A i j) new-cost)
		(setf (aref A j i) new-cost)
		(setf (aref P i j) place)
		(setf (aref P j i) place)))))))
    (setf *apsp-matrix* A)
    (setf *path-matrix* P)
    (setf *places* places)
    (setf *already-computed-apsp* t)))


;;; ------------------------------------------------------------------------
;;;   KS Definitions
;;; ------------------------------------------------------------------------

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

(define-ks ASSIGN-LIMO-KS 
  :rating 2
  :trigger-events ((creation-event carrying-fare))
  :ks-function 'assign-limo)

(define-ks PLAN-FARE-KS 
  :rating 1
  :trigger-events ((creation-event order))
  :ks-function 'plan-fare )

(define-ks GET-ORDER-INTERACTIVE-KS 
  :rating 99
  :trigger-events ((get-order-event))
  :ks-function 'get-order-interactive)

(define-ks GET-ORDER-KS 
  :rating 99
  :trigger-events ((quiescence-event)
                   (resume-control-shell-event))
  :ks-function 'get-order)

(define-ks FIND-PLACE-TO-WAIT-KS
  :trigger-events ((limo-emptied-event carrying-fare))
  :precondition-function #'end-place-is-waiting-place-p
  :ks-function 'find-place-to-wait-ks)

(define-ks GET-ORDERS-KS 
  :rating 99  ; we want initial-ks to run first!
  :trigger-events ((start-control-shell-event))
  :ks-function 'get-orders)

(define-ks PAUSE-KS 
  :rating 101
  :trigger-events ((plan-completion-event task))
  :ks-function #'(lambda (ksa)
                   (declare (ignore ksa))
                   (format t "~%Pausing....")
                   (sleep *order-pause*)
                   (format t "~%Continuing....")))

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

(defun save-limo-example (save-function)
  ;; Reset path-finding variables.
  (when (eq save-function 'save-blackboard-database)
    `((setf *already-computed-apsp* nil))))

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

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