;;;-*- Mode: Lisp; Package: (VEIL CL) -*-

(loom:use-loom "VEIL")

(in-package "VEIL")

#+:MCL
(setf (logical-pathname-translations "VEIL")
      '(("VEIL:home;*.*" "Dockweiler:loom:veil:*.*")))

(set-feature :closed-world)


;;;
;;;  Macro to make writing the Loom interface to radius objects easier:
;;;

(defmacro apply-to-radius-objects ((&rest vars) &body body)
  ;; Create a form suitable as input to the :function or :predicate
  ;;  option of a Loom definition;
  ;; This is in the form ((var ...) statement ...)
  ;; In the body of this function, each of the "vars" will be bound to
  ;;   the filler of the "radius-object" role on an instance.  If such an
  ;;   object exists for all instances, then "body" is executed with those
  ;;   bindings;
  (let ((bindings (loop for v in vars
			collect `(,v (get-value ,(gensym "V-") 'radius-object)))))
    `'(,(mapcar #'cadadr bindings)    ; Establish Function/Predicate bindings
       (let ,bindings                 ; Bind "vars" to RADIUS-OBJECT fillers
	 (when (and ,@vars)
	   ,@body))) ))               


;;;
;;;  Contexts.
;;;
;;;  The top level context is called COMMON.  It holds
;;;     (1)  the domain model
;;;     (2)  the instances that are in the static site model (such as buildings)
;;;     (3)  shared instances such as groups
;;;
;;;  Each image has its own model for variable information such as
;;;     (1)  vehicles
;;;     (2)  which group the vehicles belong to
;;;     (3)  information about changes to other site model entities
;;;  For convenience, the context name is the same as the image name.
;;;
;;;  There is also an EVENT context that is used to store records of events
;;;  that have been detected.
;;;

(defcontext common :theory nil)

(defcontext event :theory (common))

(defcontext m4 :theory (common))
(defcontext m6 :theory (common))
(defcontext m8 :theory (common))
(defcontext m12 :theory (common))
(defcontext m16 :theory (common))
(defcontext m19 :theory (common))
(defcontext m24 :theory (common))
(defcontext m27 :theory (common))
(defcontext m32 :theory (common))
(defcontext m33 :theory (common))

;;;
;;; Basic Entities
;;;

(cc common)

(format t "~%Defining Loom Terminology")

;;;
;;; Context to World and Time Line Related Relations
;;;
;;; Contexts are associated with a particular World, which is a Radius
;;; 3D-World connected to a particular image.  World names are the prefix
;;; "MB2-" (for model board 2) and the image name.
;;;
;;; The sequence of images was chosen to be consistent with two scenarios
;;; provided to us, as well as to incorporate other images with interesting
;;; sequences for event detection
;;;

(defrelation before :domain context :range context)
(defrelation after :is (:Inverse before))
(defrelation before+ :is
             (:satisfies (?x ?y) (:or (before ?x ?y)
                                      (:exists ?z
                                               (:and (before ?x ?z)
                                                     (before+ ?z ?y))))))
(defrelation after+ :is
             (:satisfies (?x ?y) (:or (after ?x ?y)
                                      (:exists ?z
                                               (:and (after ?x ?z)
                                                     (after+ ?z ?y))))))

(defrelation world-name)
(defrelation world)

(set-value (find-context 'common) 'world-name "Radius Model Board 2")

(defparameter *context-sequence* '(m8 m19 m27 m24 m33 m6 m16 m12 m4 m32))

(defparameter *context-worlds*
  (loop for ?previousContext = nil then ?context
	for contextName in *context-sequence*
	as ?context = (find-context contextName)
	as ?worldName = (format nil "MB2-~(~A~)" contextName)
	when ?previousContext do (tell (before ?previousContext ?context))
	  do (tell (world-name ?context ?worldName))
	collect ?worldName))


;;;
;;; Visual Objects
;;;
;;; Visual objects represent items that have geometric models and can be
;;; seen.  The concept hierarchy developed here includes other collateral
;;; information that may or may not have a visual manifestation.

(defconcept visual-entity)
(defconcept container-object)   ;; Suitable range for "IN"
(defconcept areal-object)       ;; Suitable range for "ON"

(defconcept physical-object :is-primitive visual-entity 
            :partitions $object-type$)

(defconcept structure :is-primitive (:and physical-object container-object)
	    :in-partition $object-type$ :partitions $structure-type$)

(defconcept building :is-primitive structure :in-partition $structure-type$)
(defconcept fuel-tank :is-primitive structure :in-partition $structure-type$)
(defconcept smoke-stack :is-primitive structure :in-partition $structure-type$)
(defconcept bleachers :is-primitive structure :in-partition $structure-type$)

(defconcept track :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)
(defconcept road :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)
(defconcept railroad :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)
(defconcept field :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)
(defconcept growth-area :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)
(defconcept parking-lot :is-primitive (:and physical-object areal-object)
	    :in-partition $object-type$)

(defconcept headquarters :is-primitive building)
(defconcept vehicle-shed :is-primitive building)
(defconcept power-plant :is-primitive building)
(defconcept barracks :is-primitive building)

(defconcept area :is-primitive (:and visual-entity container-object))
(defconcept general-storage-area :is-primitive area)
(defconcept storage-area :is-primitive general-storage-area)
(defconcept maintenance-area :is-primitive general-storage-area)
(defconcept hq-area :is-primitive area)
(defconcept barracks-area :is-primitive area)

(defrelation polygon :characteristics :single-valued)
(defrelation color :characteristics :single-valued)
(defrelation fill-pattern :characteristics :single-valued)

(defrelation radius-object :characteristics :single-valued)


;;;
;;;  GEOMETRIC REASONING RELATIONS
;;;
;;;  These include containment, area and volume computations.  These relations
;;;  are linked to functions that use the Radius geometric object models to
;;;  solve the problems.
;;;

;; Note the use of "define-relation" instead of "defrelation".  This is
;; needed so that the "apply-to-radius-objects" macro will have its code
;; be evaluated to create the body for the :predicate or :function options.

(define-relation 'on :domain 'vehicle :range 'areal-object
  :predicate (apply-to-radius-objects (vehicle area)
		 (multiple-value-bind (x y z)
		     (cme::get-radius-object-location vehicle)
		   (cme::contains-point-p area x y z)))
  :characteristics :multiple-valued)

(define-relation 'in :domain 'physical-object :range 'container-object
    :predicate (apply-to-radius-objects (object container)
		    (multiple-value-bind (x y z)
			(cme::get-radius-object-location object)
		      (cme::contains-point-p container x y z)))
    :characteristics :multiple-valued)


(define-relation 'area :domain 'physical-object :range 'number
  :function (apply-to-radius-objects (object)
		(cme::compute-area object)))

(define-relation 'volume :domain 'physical-object :range 'number
  :function (apply-to-radius-objects (object)
		(cme::compute-volume object)))


;;;
;;;   DIRECTIONS
;;;

(define-relation 'north :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::north-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'northq :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::north-quadrant-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'south :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::south-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'southq :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::south-quadrant-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'east :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::east-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'eastq :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::east-quadrant-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'west :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::west-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'westq :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::west-quadrant-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'north-east
  :is '(:and north east) :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::north-east-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'north-west 
  :is '(:and north west) :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::north-west-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'south-east
  :is '(:and south east)  :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::south-east-p object1 object2))
  :characteristics :multiple-valued)

(define-relation 'south-west 
  :is '(:and south west) :domain 'visual-entity :range 'visual-entity
  :predicate (apply-to-radius-objects (object1 object2)
		(cme::south-west-p object1 object2))
  :characteristics :multiple-valued)

;; Need to develop some shape predicates:
;; Shape kludges
;(defconcept rectangular
;  :predicate ((x) (= (length (get-value x 'polygon)) 4)))
;(defconcept l-shaped
;  :predicate ((x) (= (length (get-value x 'polygon)) 6)))
;(defconcept u-shaped
;  :predicate ((x) (= (length (get-value x 'polygon)) 8)))
;(defconcept h-shaped
;  :predicate ((x) (= (length (get-value x 'polygon)) 12)))


;;
;;  Need to connect these to geometric operations:
;;

(defrelation adjacent :domain visual-entity :range visual-entity 
             :characteristics :symmetric)
(defrelation intersects :is (:and adjacent (:range road) (:domain road))
             :characteristics :symmetric)
(defrelation near :is (:satisfies (?x ?y)
                                  (or (adjacent ?x ?y)
                                      (:exists ?z
                                               (:and (adjacent ?x ?z)
                                                     (adjacent ?z ?y))))))
(defrelation close :is (:satisfies (?x ?y)
                                    (:same-as (contained-by ?x)
                                              (contained-by ?y))))
(defrelation nearby :is (:satisfies (?x ?y)
                                     (near (contained-by ?x)
                                           (contained-by ?y))))
                                              

(defrelation contained-by :domain physical-object)
(defrelation container-holds :is (:Inverse contained-by))

(define-relation 'location :characteristics :single-valued    ;; '(x y z)
   :function (apply-to-radius-objects (object)
	        (multiple-value-list (cme::get-radius-object-location object))))

;; Need to connect to a function:
;;
(defrelation radius :characteristics :single-valued)    ;; For circular structures

(defconcept construction-activity)
(defconcept ground-scarring :is-primitive construction-activity)
(defconcept excavation :is-primitive construction-activity)
(defconcept wall-raising :is-primitive construction-activity)

;;;
;;; Vehicles
;;;

(defconcept vehicle :is-primitive physical-object)

(defconcept drive-types :is (:one-of 'track 'wheel))
(defconcept gun-types :is (:one-of 'direct-fire 'indirect-fire))

(defrelation has-gun :domain vehicle :characteristics :single-valued)
(defrelation gun-type :domain vehicle :range gun-types)
(defrelation drive-type :domain vehicle :range drive-types 
             :characteristics :single-valued)
(defrelation personnel-capacity :range integer :characteristics :single-valued)
(defrelation cargo-capacity :range number :characteristics :single-valued)

(defconcept gun-carrying-vehicle :is (:and vehicle (:at-least 1 has-gun)))
(defconcept tracked-vehicle :is (:and vehicle (:the drive-type 'track)))
(defconcept wheeled-vehicle :is (:and vehicle (:the drive-type 'wheel)))

(defconcept tank :is (:and tracked-vehicle
                           gun-carrying-vehicle
                           (:all gun-type (:one-of 'direct-fire))))
(defconcept sp-artillery :is (:and tracked-vehicle 
                                   gun-carrying-vehicle
                                   (:some gun-type (:one-of 'indirect-fire))))
(defconcept apc :is (:and tracked-vehicle (:at-least 1 personnel-capacity)))

(defconcept crane :is-primitive wheeled-vehicle)
(defconcept truck :is (:and wheeled-vehicle (:at-least 1 cargo-capacity)))
(defconcept big-truck :is (:and truck (> cargo-capacity 5.0)))
(defconcept small-truck :is (:and truck (<= cargo-capacity 5.0)))
(defconcept car :is (:and wheeled-vehicle (:at-most 0 cargo-capacity)))

;;;
;;; Abstract Entities
;;;
;;;  Abstract entities are those which do not have a physical presence,
;;;   although some, like groups, can be represented visually by their
;;;   members.
;;;

(defconcept group)

(defrelation group-member :domain group)
(defrelation member-of-group :is (:inverse group-member))
(defrelation group-size :domain group
	     :range (:one-of 'empty 'singleton 'pair
			     'platoon 'platoon+ 'company 'company+
			     'battalion 'battalion+ 'brigade 'brigade+)
	     :characteristics :single-valued)


(defconcept vehicle-group :is (:and group
				    (:all group-member vehicle)))

;; VEHICLE GROUP SIZES
;;       0   Empty-group
;;       1   Singleton
;;       2   Pair
;;      3-5  Platoon
;;      6-9  Platoon+
;;     10-20 Company
;;     21-29 Company+
;;     30-55 Battalion
;;     56-69 Battalion+
;;     70-100 Brigade
;;     101+   Brigade+
;;
;; TO DO:  Make a Macro that can take a table and create these concepts
;;         since that will make maintainance easier
;;

(defconcept empty-group :is (:and group
				(:at-most 0 group-member)
				(:filled-by group-size 'empty)))
(defconcept singleton :is (:and group
				(:exactly 1 group-member)
				(:filled-by group-size 'singleton)))
(defconcept pair :is (:and group
			   (:exactly 2 group-member)
			   (:filled-by group-size 'pair)))

(defconcept platoon :is (:and vehicle-group
			      (:at-least 3 group-member)
			      (:at-most 5 group-member))
	    :implies (:filled-by group-size 'platoon))
(defconcept platoon+ :is (:and vehicle-group
			      (:at-least 6 group-member)
			      (:at-most 9 group-member))
	    :implies (:filled-by group-size 'platoon+))
(defconcept company :is (:and vehicle-group
			      (:at-least 10 group-member)
			      (:at-most 20 group-member))
	    :implies (:filled-by group-size 'company))
(defconcept company+ :is (:and vehicle-group
			      (:at-least 21 group-member)
			      (:at-most 29 group-member))
	    :implies (:filled-by group-size 'company+))
(defconcept battalion :is (:and vehicle-group
			      (:at-least 30 group-member)
			      (:at-most 55 group-member))
	    :implies (:filled-by group-size 'battalion))
(defconcept battalion+ :is (:and vehicle-group
			      (:at-least 56 group-member)
			      (:at-most 69 group-member))
	    :implies (:filled-by group-size 'battalion+))
(defconcept brigade :is (:and vehicle-group
			      (:at-least 70 group-member)
			      (:at-most 100 group-member))
	    :implies (:filled-by group-size 'brigade))
(defconcept brigade+ :is (:and vehicle-group
			      (:at-least 101 group-member))
	    :implies (:filled-by group-size 'brigade+))

(defconcept battery :is (:and company
			      (:at-least 5 group-member sp-artillery)))


;;
;;  FUNCTIONAL OR LOCATION DEFINED GROUPS
;;

(defconcept convoy
  :is (:and group
            (:at-least 5 group-member)
            (:all group-member vehicle)
            (:satisfies (?c)
                (> (/ (count (:collect ?x (:and (group-member ?c ?x)
                                               (:exists (?r) (:and (road ?r)
                                                                   (on ?x ?r))))))
	              (count (group-member ?c)))
                   .65))))


(defconcept deployed-unit
  :is (:and group
            (:at-least 1 group-member)
            (:satisfies (?c)
                (> (/ (count (:collect ?x
			        (:and (group-member ?c ?x)
				      (:exists (?a)
					(:and (field ?a)
					      (on ?x ?a))))))
	              (count (group-member ?c)))
                   .80))))
          
(defconcept in-garrison
  :is (:and group
            (:at-least 1 group-member)
            (:satisfies (?c)
                (> (/ (count (:collect ?x
			        (:and (group-member ?c ?x)
				      (:exists (?a)
					(:and (general-storage-area ?a)
					      (in ?x ?a))))))
	              (count (group-member ?c)))
                   .80))))

(defconcept under-repair
  :is (:and group
            (:at-least 1 group-member)
            (:all group-member (:and vehicle (:some in maintenance-area)))))

;;
;;  Composed relations for passing relations through to group members:
;;

(defrelation group-on
  :is (:compose group-member on))
(defrelation group-in
  :is (:compose group-member in))



;;;
;;;  Production Rules
;;;
;;;  These rules just note the existence of certain concepts in images and
;;;  print informative messages
;;;

(defproduction on-the-move
  :when (:detects (convoy ?c))
  :do ((let ((roads (get-values ?c 'group-on)))
         (format t "~%CONVOY (~A) DETECTED on road~P ~{~A~^, ~}."
                 ?c (length roads) roads)) ))

(defproduction announce-deployment
  :when (:detects (deployed-unit ?c))
  :do ((let ((loc1 (get-values ?c 'group-on))
             (loc2 (get-values ?c 'group-in)))
         (format t "~%UNIT ~A DEPLOYED~@[ on ~{~A~^, ~}~]~@[ in ~{~A~^, ~}~]."
               ?c loc1 loc2))  ))

(defproduction in-garrison
  :when (:detects (in-garrison ?c))
  :do ((format t "~%Unit ~A in Garrison in ~{~A~^, ~}." 
               ?c (get-values ?c 'group-in)))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;;  Common Model Assertions
;;;

(format t "~%Making Common assertions")

;; Area
;;  Note:  These 

(create 'Garage-1 'Area)
(create 'Garage-2 'Area)
(create 'Area-B1 'Area)
(create 'Area-B2 'Area)
(create 'Area-C1 'Area)
(create 'Area-C2 'Area)
(create 'Area-D 'Area)
(create 'Area-E 'Area)
(create 'Area-F 'Area)
(create 'Area-G 'Area)
(create 'Area-1 'Area)
(create 'Area-2 'Area)
(create 'Area-3 'Area)
(create 'Area-U 'Area)
(create 'Area-V 'Area)
(create 'Area-W 'Area)
(create 'Area-X 'Area)
(create 'Area-Y 'Area)
(create 'Area-Z 'Area)

;;
;; Note: Polygon information is only valid for the MCL mockup.  This
;;       was done before the link to radius.


(tellm (:about Garage-1 storage-area 
               #+:MCL (polygon '((153 150) (274 204) (256 326) (107 252))))
       (:about Garage-2 storage-area
               #+:MCL (polygon '((35 98) (153 150) (107 252) (1 202))))
       (:about Area-B1 maintenance-area
               #+:MCL (polygon '((166 122) (276 174) (273 208) (154 153))))
       (:about Area-B2 maintenance-area
               #+:MCL (polygon '((50 69) (166 122) (154 153) (36 98))))
       (:about Area-C1 barracks-area
               #+:MCL (polygon '((57 431) (104 335) (179 371) (131 388) (97 416) (91 429) (93 449))))
       (:about Area-C2 barracks-area
               #+:MCL (polygon '((1 357) (1 285) (95 331) (67 388))))
       (:about Area-D hq-area
               #+:MCL (polygon '((1 275) (1 213) (254 334) (191 367))))
       (:about Area-E #+:MCL (polygon '((272 102) (449 1) (544 1) (544 154) (284 152))))
       (:about Area-U #+:MCL (polygon '((126 539) (102 450) (103 430) (141 396)
                                 (188 378) (249 354) (261 340) (267 318)
                                 (305 389) (362 439) (397 464) (429 477) (429 539))))
       )


;; Buildings

(Create 'b1 'Building)
(Create 'b2 'Building)
(Create 'b3 'Building)
(Create 'b4 'Building)
(Create 'b5 'Building)
(Create 'b6 'Building)
(Create 'b7A 'Building)
(Create 'b7B 'Building)
(Create 'b8 'Building)
(Create 'b9 'Building)
(Create 'b10 'Building)
(Create 'b11 'Building)
(Create 'b12 'Building)
(Create 'b13A 'Building)
(Create 'b13B 'Building)
(Create 'b14 'Building)
(Create 'b15 'Building)                ; Invented number
(Create 'b16 'Building)                ; Invented number
(Create 'b17 'Building)                ; Invented number
(Create 'b19 'Building)
(Create 'b20 'Building)
(Create 'b21 'Building)
(Create 'b22 'Building)
(Create 'b23 'Building)
(Create 'b24 'Building)
(Create 'b25 'Building)
(Create 'b26 'Building)
(Create 'b27 'Building)
(Create 'b28 'Building)
(Create 'b29 'Building)
(Create 'b30 'Building)
(Create 'b31 'Building)
(Create 'b32 'Building)
(Create 'b33 'Building)
(Create 'b34 'Building)
(Create 'b35 'Building)
(Create 'b36 'Building)
(Create 'b38 'Building)
(Create 'b39A 'Building)
(Create 'b39B 'Building)
(Create 'b44 'Building)
(Create 'b45 'Building)
(Create 'b46 'Building)
(Create 'b51 'Building)
(Create 'b52 'Building)
(Create 'b53 'Building)
(Create 'b56 'Building)
(Create 'b57 'Building)
(Create 'b58 'Building)
(Create 'b59 'Building)
(Create 'b60 'Building)
(Create 'Tank-A 'Fuel-Tank)
(Create 'Tank-B 'Fuel-Tank)
(Create 'Tank-C 'Fuel-Tank)
(Create 'Tank-D 'Fuel-Tank)
(Create 'Stack-E 'Smoke-Stack)
(Create 'Stack-F 'Smoke-Stack)
(Create 'Fuel-Area-A 'Building)
(Create 'Fuel-Area-B 'Building)

;; Bush covered areas

(Create 'Bush-Area-1 'Growth-Area)
(Create 'Bush-Area-2 'Growth-Area)
(Create 'Bush-Area-3 'Growth-Area)
(Create 'Bush-Area-4 'Growth-Area)
(Create 'Bush-Area-5 'Growth-Area)
(Create 'Bush-Area-6 'Growth-Area)
(Create 'Bush-Area-7 'Growth-Area)
(Create 'Bush-Area-8 'Growth-Area)
(Create 'Bush-Area-9 'Growth-Area)
(Create 'Bush-Area-10 'Growth-Area)

(Create 'gubao 'Area)

;; Other Items

(Create 'Loading-Ramp 'Road)
(Create 'Training-Ground-1 'Field)
(Create 'Field-1 'Field)
(Create 'Field-2 'Field)
(Create 'Field-3 'Field)
(Create 'Motor-Pool 'Parking-Lot)
(Create 'Track-1 'Track)


;; Area Containment
;;
;;  Currently still needed.  Should be replaced by geometric predicates
;;    when they are ready and when the various areas are added into the
;;    underlying site model.

(tellm (:about Garage-1
	       (container-holds b8) (container-holds b10) (container-holds b11)
	       (container-holds b12)  (container-holds b13a))
       (:about Garage-2
	       (container-holds b3) (container-holds b4) (container-holds b5)
               (container-holds b6)  (container-holds b7a))
       (:about area-b1
	       (container-holds b9) (container-holds fuel-area-a)
	       (container-holds b13b))
       (:about area-b2
	       (container-holds b2) (container-holds fuel-area-b)
	       (container-holds b7b))
       (:about area-c1
	       (container-holds b51) (container-holds b52)
	       (container-holds b53))
       (:about area-c2
	       (container-holds b57) (container-holds b58)
	       (container-holds b59) (container-holds b60))
       (:about area-d
	       (container-holds b44) (container-holds b45)
	       (container-holds b46))
       (:about area-e
	       (container-holds b14) (container-holds b15)
	       (container-holds b16) (container-holds b17)
	       (container-holds field-2) (container-holds tank-a)
	       (container-holds tank-b) (container-holds tank-c)
               (container-holds tank-d) (container-holds stack-e)
	       (container-holds stack-f))
       (:about area-f
	       (container-holds track-1) (container-holds b33)
	       (container-holds b34) (container-holds b35))
       (:about area-g (container-holds motor-pool))
       (:about area-h
	       (container-holds b38) (container-holds b39a)
	       (container-holds b39b) (container-holds b56))
       (container-holds area-u field-1)
       (container-holds area-v b1)
       (:about area-w (container-holds loading-ramp) (container-holds field-3))
       (container-holds area-y b36)
       (:about area-z
	       (container-holds b30) (container-holds b31)
	       (container-holds b32))
       (:about area-1
	       (container-holds b26) (container-holds b27)
               (container-holds b28) (container-holds b29))
       (:about area-2
	       (container-holds b21) (container-holds b22)
	       (container-holds b23) (container-holds b24)
	       (container-holds b25))
       (:about area-3 (container-holds b19) (container-holds b20)))



;; Coordinates

#+:MCL (load "veil:home;mac-bldg-coords.lisp")


;;
;;  COLLATERAL FUNCTION INFORMATION:
;;

(tellm (:about b3 vehicle-shed)
       (:about b4 vehicle-shed)
       (:about b5 vehicle-shed)
       (:about b6 vehicle-shed)
       (:about b7a vehicle-shed)
       (:about b8 vehicle-shed)
       (:about b10 vehicle-shed)
       (:about b11 vehicle-shed)
       (:about b12 vehicle-shed)
       (:about b13a vehicle-shed)

       (:about b14 power-plant)

       (:about b26 headquarters)
       (:about b27 headquarters)
       (:about b28 headquarters)
       (:about b29 headquarters)

       (:about b44 headquarters)
       (:about b45 headquarters)
       (:about b46 headquarters)

       (:about b51 barracks)
       (:about b52 barracks)
       (:about b53 barracks)
       (:about b57 barracks)
       (:about b58 barracks)
       (:about b59 barracks)
       (:about b60 barracks)

  )

;; Link Buildings to underlying radius model objects.
;;  The link is done by name equivalence.

(loop for bldg in cme::*building-list*
      as instance = (find-instance (intern (cme::name bldg))
			 :no-warning-p t)
      when instance do (set-value instance 'radius-object bldg))

;; Roads

(loop for i from 1 to 10
      as instance = (create (intern (format nil "ACCESS-ROAD-~D" i)) 'Road)
      as object = (find (format nil "ACCESS ROAD ~D" i) cme::*road-list*
			:test #'string-equal :key #'cme::name)
      when object do (set-value instance 'radius-object object))

(Create 'foot-path 'Road)

;; Connectivity
;;
;; Should be replaced by geometric functions when they are available:
;;

(tellm (intersects access-road-1 access-road-2)
       (intersects access-road-1 access-road-3)
       (intersects access-road-2 foot-path)
       (intersects access-road-3 access-road-4)
       (intersects access-road-3 access-road-5)
       (intersects access-road-3 access-road-6)
       (intersects access-road-3 access-road-7)
       (intersects access-road-3 access-road-9)
       (intersects access-road-3 foot-path)
       (intersects access-road-4 access-road-5)
       (intersects access-road-7 access-road-10)
       (intersects access-road-8 access-road-10)
       (intersects access-road-9 access-road-10))

;;  Should be replaced by geometric functions when available:

(tellm (:about access-road-1 (adjacent area-e) (adjacent area-f) (adjacent area-3))
       (:about access-road-2 (adjacent area-f) (adjacent area-y) (adjacent area-z)
               (adjacent area-1) (adjacent area-2) (adjacent area-3))
       (:about access-road-3 (adjacent Garage-1) (adjacent area-b1) (adjacent area-c1)
               (adjacent area-d) (adjacent area-e) (adjacent area-g)
               (adjacent area-h) (adjacent area-u) (adjacent area-v)
               (adjacent area-w) (adjacent area-x))
       (:about access-road-4 (adjacent area-v) (adjacent area-w))
       (:about access-road-5 (adjacent area-b1) (adjacent area-b2)
               (adjacent area-v) (adjacent area-w))
       (:about access-road-5 (adjacent area-b1) (adjacent area-b2)
               (adjacent area-v) (adjacent area-w))
       (:about access-road-6 (adjacent Garage-1) (adjacent Garage-2) (adjacent area-d))
       (:about access-road-7 (adjacent area-c1) (adjacent area-c2) (adjacent area-d))
       (:about access-road-8 (adjacent area-c2))
       (:about access-road-9 (adjacent area-c1) (adjacent area-x))
       (:about access-road-10 (adjacent area-c1) (adjacent area-c2) (adjacent area-x))
       (:about foot-patch (adjacent area-f) (adjacent area-h) 
               (adjacent area-u) (adjacent area-y))
       (adjacent Garage-2 area-b2)
       (adjacent area-b2 area-b1)
       (adjacent Garage-1 area-b1)
       (adjacent area-1 area-2)
       (adjacent area-2 area-3)
       (adjacent area-z area-1)
       (adjacent area-h area-u)
       (adjacent area-y area-u))


;;
;;  Function for creating new vehicle instances and their associated radius objects
;;  This function is used in the files containing the individual image assertions.
;;

(defun new-vehicle (x y &optional (type 'vehicle))
  (let ((?location (list x y 0.0))
	instance)
    (or (car (retrieve ?x (:and (vehicle ?x) (location ?x ?location))))
	(progn
	  (setq instance (create nil type))
	  (set-value instance 'radius-object
		     (cme::make-vehicle-cube ?location
					     :name (string (object-name instance))))
	  instance)) ))


;; Groups

(create 'G-1 'group)
(create 'G-2 'group)
(create 'G-3 'group)
(create 'G-4 'group)
(create 'G-5 'group)


;;;
;;;  Event Context Information
;;;

(defun permute (list)
  (if (cdr list)
    (loop with first = (list (first list))
          for sl in (permute (rest list))
          append (loop for i from 0 below (length list)
                       collect (append (subseq sl 0 i) first (subseq sl i)))) 
    (list list)))
        

(cc event)

(defconcept scene)
(defrelation scene-name)
(defrelation viewable-area) ;; The area of map visible in the scene

(defconcept scenario)
(defrelation scene-sequence)
(defrelation scenario-type)

;; Area visible in each image.
;; Need CME version of this in world coordinates:
;(loop for ?name in '(m24 m33 m6 m16)
;      as ?area in '(((183 133) (544 110) (544 412) (195 428)) 
;                    ((0 489) (0 0) (348 0) (547  15) (547 540) (415 540))
;                    ((435 159) (451 527) (171 526) (169 173))
;                    ((0 0) (547 0) (547 540) (68 540) (0 511)))
;      as ?con = (find-context ?name)
;      as ?iname = (format nil "MB2-~(~A~)" ?name)
;      do (tell (scene ?con) (scene-name ?con ?iname) (viewable-area ?con ?area)))
;
;(let ((?sequence (list (find-context 'm24) 
;                       (find-context 'm33)
;                       (find-context 'm6)
;                       (find-context 'm16))))
; (tellm (:about armor-movement scenario (scene-sequence ?sequence)
;                (scenario-type 'armor-movement)))
; )



;;
;;  EVENT OBJECT CONCEPTS AND RELATIONS
;;
;;  These are used to store records of events that are found by the event
;;  parser.

(defconcept event)
(defrelation event-binding :domains (event SYMBOL) :arity 3)
(defrelation event-type :domain event :range SYMBOL :characteristics :single-valued)
(defrelation event-part :domain event)


(cc common)