;;; File: test-suite.km
;;; Build Date:  Mon Nov 2 10:58:23 PST 2009

(nocomments)
(fail-noisily)  ; (Report an error for NIL answers)

(print "userman.km")

;;; ======================================================================
;;;		 Demo KM commands from the KM User Manual
;;; To run the demo:
;;;	% lisp
;;;	> (load "km")
;;;	> (load-kb "userman.demo" :verbose 't)
;;; ======================================================================

(SETQ *LINEAR-PATHS* T)

(reset-kb)

(a Car)                     ; create an instance of a car

(Car has (superclasses (Vehicle)))

(every Car has
  (wheel-count (4))
  (parts ((a Engine) (a Chassis))))

(the parts of (a Car))

; ((a Car) parts)

(a Car)

(parts has
  (instance-of (Slot))
  (domain (Physobj))
  (range (Physobj))
  (cardinality (1-to-N))
  (inverse (part-of)))

(wheel-count has
  (instance-of (Slot))
  (domain (Vehicle))
  (range (Integer))
  (cardinality (N-to-1)))

(showme (thelast Car))     ; refers to the most recent instance of car

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

(Car has (superclasses (Vehicle)))

(every Car has
  (wheel-count (4))
  (fuel-type (*Gas))
  (parts ((a Engine) (a Chassis))))

(*Gas has       ; (NB no `every', as *Gas is an instance)
  (unit-cost (1.34)))

(Engine has (superclasses (Physobj)))

(every Engine has
  (material (*Metal)))

(Chassis has (superclasses (Physobj)))

(every Chassis has
  (material (*Metal *Plastic *Wood)))

(*Plastic has
  (instance-of (Synthetic-Material)))

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

(a Car)

(the unit-cost of (the fuel-type of (thelast Car)))

((thelast Car) fuel-type * unit-cost)

(the material of (the parts of (thelast Car)))

(the material of (the Engine parts of (thelast Car)))

((thelast Car) parts Engine material)

((thelast Car) parts Chassis material)

((thelast Car) parts Chassis material Synthetic-Material)

;(watchon)

((a Car) parts Chassis material Synthetic-Material)

;(watchoff)

(a Car)

(thelast Car)

(the Engine parts of (thelast Car))

(a Car with (color (*Red)))

(the color of (thelast Car))

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

(every Person has
  (favorite-color ((a Color))))

;; "All professors have (at least) one car which is old, is
;;  their favorite color, and was made in USA."
(Professor has (superclasses (Person)))

(every Professor has
  (owned-vehicle ((a Car with
    (age (*Old))
    (color ((the favorite-color of Self)))
    (made-by ((a Manufacturer with
      (location (*USA)))))))))

(a Professor with (favorite-color (*Blue)))

(the owned-vehicle of (thelast Professor))

(the color of (the owned-vehicle of (thelast Professor)))

(the location of (the made-by of 
	(the owned-vehicle of (a Professor))))

((a Professor) owned-vehicle * made-by * location)  ; alternative notation

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

(reset-kb)

(has-engine has
  (instance-of (Slot))
  (domain (Vehicle))
  (range (Engine))
  (cardinality (1-to-1))); ie. a Vehicle has exactly one engine
; (single-valued slot)

(every Vehicle has 
  (has-engine ((a Engine with
                   (strength (*Powerful))))))

(Car has (superclasses (Vehicle)))

(every Car has
  (has-engine ((a Engine with
                   (size (*Average))))))

(showme (the has-engine of (a Car)))

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

(reset-kb)

(has-engine has
  (instance-of (Slot))
  (domain (Vehicle))
  (range (Engine))
  (cardinality (1-to-1)))

(fuel has
  (instance-of (Slot))
  (domain (Vehicle))
  (range (Gas))
  (cardinality (1-to-1)))

(every Vehicle has 
  (has-engine ((a Engine with
                   (strength (*Powerful))
                   (fuel     ((a Gas with (combustibility (*Hi)))))))))

(Car has (superclasses (Vehicle)))

(every Car has
  (has-engine ((a Engine with
                  (size (*Average))
                  (fuel ((a Gas with (type (*Unleaded)))))))))

(showme (the has-engine of (a Car)))

(showme (the fuel of (thelast Engine)))

(showme (thelast Engine))

((a Pet with (color (*Green))) & (a Fish with (size (*Small))))

(showme (thelast Pet))

;;; (*Red & *Green)  ; should fail

(a Color)

((thelast Color) & *Red)

(thelast Color)

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

(every Person has
  (owns ((a Car))))

(Professor has (superclasses (Person)))

(every Professor has
  (owns ((a Car))))

((Cat Dog) && (Dog Elephant))

((Cat) && (Cat))

(color has 
 (instance-of (Slot)) 
 (cardinality (N-to-1)))      ; for demo, items have unique color

(((a Cat with (color (*Red)))) && ((a Cat with (color (*Blue)))))

(the color of (thelast Cat))

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

(every Animal has 
  (parts ((a Head) 
  (a Body with (covering (*Skin))))))

(Mammal has (superclasses (Animal)))

(every Mammal has
  (parts ((a Leg) (a Leg) (a Leg) (a Leg))))

(Dog has (superclasses (Mammal)))

(every Dog has 
  (parts ((a Tail) (a Body with (covering (*Skin *Fur))))))

(the parts of (a Dog))

(showme (thelast Body))

(the covering of (thelast Body))

;;; ----------
(Square has 
	(superclasses (Rectangle)))	; most specific superclass

(every Square has-definition	; `Definitional' properties
	  (instance-of (Shape))		; most general superclass
          (width ((Self length)))
          (length ((Self width))))

(every Square has			; `Incidental' properties
          (appearance (*Pretty)))

(Rectangle has (superclasses (Shape)))

((the appearance of (a Rectangle with (width (10)) (length (10)))) = *Pretty)

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

;;; Undo previous inverse declaration for parts:
(parts has 
   (instance-of (Slot))
   (inverse (parts-of)))

(Nissan-Wheel has
  (superclasses (Wheel)))

(every Nissan-Wheel has-definition
  (instance-of (Wheel))
  (parts-of ((a Nissan))))

(every Nissan-Wheel has
  (cost (100)))

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

(every Nissan has 
  (parts ((a Wheel) (a Wheel) (a Wheel) (a Wheel))))

(Nissan has (superclasses (Car)))

(the parts of (a Nissan))

; (the sum of (the cost of (the Wheel parts of (a Nissan))))
(the sum of (the cost of (the bag of (the Wheel parts of (a Nissan)))))

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

(every Smoker has-definition
   (instance-of (Person))
   (smokes (t)))

(every Smoker has
   (life-expectancy (70)))

(every Non-Smoker has-definition
   (instance-of (Person))
   (smokes (f)))

(every Non-Smoker has
   (life-expectancy (75)))

(the life-expectancy of (a Person with (smokes (t))))

(the life-expectancy of (a Person with (smokes (f))))

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

(*London has-definition
      (instance-of (City))		; most general class
      (capital-of (*UK)))

(*London has
     (instance-of (Big-City))		; most specific class
     (population (10000000)))

(Big-City has (superclasses (City)))

(the population of (a City with (capital-of (*UK))))

; ----------

(*USA has 
        (instance-of (Country)) 
        (cities (*Seattle *Austin)))             ; just use two cities for now!

(*Seattle has 
        (instance-of (City)) 
        (mean-temp (50)))

(*Austin has 
        (instance-of (City)) 
        (mean-temp (90)))

(the max of (the mean-temp of (the cities of *USA))) ; hottest temp


(*USA cities * mean-temp * max)                     ; equivalent `linear' notation

((allof (the cities of *USA)                        ; the hottest city(s)
     where ((the mean-temp of It) = 
        (the max of (the mean-temp of (the cities of *USA)))))
 = *Austin)

((allof ?x in (the cities of *USA)                        ; the hottest city(s)
     where ((the mean-temp of ?x) = 
        (the max of (the mean-temp of (the cities of *USA)))))
 = *Austin)

; ----------

(reset-kb)

(Vehicle has (superclasses (Thing)))

(Car has (superclasses (Vehicle)))

(every Car has
  (parts ((a Wheel) (a Wheel) (a Wheel) (a Wheel) (a Engine) (a Chassis))))

(the number of (the Wheel parts of (a Car)))

(Car has (superclasses (Vehicle)))

(every Car has
  (parts ((a Wheel) (a Wheel) (a Wheel) (a Wheel) (a Engine) (a Chassis)))
  (wheel-count ((the number of (the Wheel parts of Self)))))

(every Wheel has
 (weight (1)))

(every Engine has
  (weight (20)))

(every Chassis has
  (weight (10)))

;(the sum of (the weight of (the parts of (a Car))))
(the sum of (the weight of (the bag of (the parts of (a Car)))))

(weight has
  (instance-of (Slot))
  (cardinality (N-to-1))); ie. weight is a single-valued slot

(every Physobj has
;  (weight ((the sum of (the weight of (the parts of Self)))))
  (weight ((the sum of (the bag of (the weight of (the parts of Self)))))))

(Vehicle has (superclasses (Physobj)))

(the weight of (a Car))

(2 * 2)

(reset-kb)

 (*Bruce has
        (instance-of (Person))
        (vehicle ((a Car with (color (*Brown)) (age (*Old)))
                  (a Car with (color (*Red))   (age (*New)))
                  (a Van with (color (*Red))   (age (*Old))))))

 (Car has (superclasses (Passenger-Vehicle)))
 (Van has (superclasses (Passenger-Vehicle)))
 (*Red has (instance-of (Bright-Color)))
 (*Brown has (instance-of (Dark-Color)))

 (the vehicle of *Bruce)

 ((the Van vehicle of *Bruce) is '(a Passenger-Vehicle with (color ((a Bright-Color)))))

; ((the vehicle of *Bruce) are (a Passenger-Vehicle)); OLD

(allof (the vehicle of *Bruce)			     ; NEW - Version 1
  must (It is '(a Passenger-Vehicle)))

(Passenger-Vehicle subsumes (the vehicle of *Bruce)) ; NEW - version 2

; ((the vehicle of *Bruce) includes (a Car with (color ((a Bright-Color)))))   OLD
(has-value (oneof (the vehicle of *Bruce) 
	    where (It is '(a Car with (color ((a Bright-Color)))))))  ; NEW

(the Car with 
       (vehicle-of (*Bruce)) 
       (color (*Brown)))

(the color of (thelast Car))

(the Person with
       (vehicle ((a Van with 
                     (color (*Red))))))

(every Person with
       (vehicle ((a Van with 
                     (color (*Red))))))

 (every Passenger-Vehicle with 
        (vehicle-of (*Bruce)) 
        (color (*Red)))

(the+ Car with (vehicle-of (*Bruce)) (color (*Red)))

(the+ Car with (vehicle-of (*Bruce)) (color (*Blue)))

(showme *Bruce)

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

(every Journey has
  (time-taken (((Self distance) / (Self speed))))
  (speed ((the typical-speed of (the owned-vehicle of Self))))
  (distance ((the abs of ((Self from * position) - (Self to * position))))))

(*Seattle has
  (instance-of (Place))
  (position (100)))

(*Boston has
  (instance-of (Place))
  (position (3000)))

(Nissan has (superclasses (Car)))

(every Nissan has (typical-speed (55.0)))

(Porsche has (superclasses (car)))

(every Porsche has (typical-speed (90.0)))

(the time-taken of (a Journey with 
(from (*Seattle)) 
(to (*Boston)) 
(owned-vehicle ((a Nissan)))))

(the time-taken of (a Journey with 
(from (*Seattle)) 
(to (*Boston)) 
(owned-vehicle ((a Porsche)))))

(*Seattle has
  (instance-of (Place))
  (position ((a Coordinate with
(lat (100))
(lng (234))))))

;;; ----------------------------------------
;;; "If the car is domestic then spare parts will be cheap, 
;;;  otherwise they'll be expensive."
(every Car has
  (cost-of-parts (
(if    ((Self made-by * location) = (Self owner Person lives-in))
 then  *Low
 else  *High))))

(Sentra has (superclasses (Car)))

(every Sentra has (made-by (*Nissan)))

(Geo-Metro has (superclasses (Car)))

(every Geo-metro has (made-by (*Chrysler)))

(*Nissan has
  (instance-of (Manufacturer))
  (location (*Japan)))

(*Chrysler has
  (instance-of (Manufacturer))
  (location (*USA)))

(a Sentra with (owner ((a Person with (lives-in (*USA))))))

(the cost-of-parts of (thelast Sentra))

(a Person with 
(lives-in (*USA))
(owned-vehicle (Sentra)))

(owned-vehicle has
       (instance-of (Slot))
       (domain (Person))
       (range (Vehicle))
       (inverse (owner))
       (cardinality (1-to-N)))

 (a Person with 
(lives-in (*USA))
(owned-vehicle (Sentra)))

(the owned-vehicle of (thelast Person))

(showme (thelast Sentra))

(the cost-of-parts of (thelast Sentra))

(every Tree has
  (parts ((a Root-system))))

(every Root-system has
  (feeds ((Self parts-of Tree))))

(a Tree)

;; "What does the tree's root-system parts feed?"
((thelast Tree) parts Root-system feeds)

;;; ----------------------------------------
;;; "A Car's engine turns the front wheels."
(every Car has
  (parts ((a Wheel with (position (*Front)) (side (*Left)))
  (a Wheel with (position (*Front)) (side (*Right)))
  (a Wheel with (position (*Back)) (side (*Left)))
  (a Wheel with (position (*Back)) (side (*Right)))
  (a Chassis)
  (Self has-engine)))
  (has-engine ((a Engine with
                  (powers-wheels ((allof (the Wheel parts of Self)
                                   where ((the position of It) = *Front))))))))

; "Which wheels does a car's engine turn?"
((a Car) parts Engine powers-wheels Wheel)

;;; Has two powered wheels
((the number of (allof (the Wheel parts of (a Car))
     where ((the position of It) = *Front)))
 = 2)

((forall (the Wheel parts of (a Car))
      where ((the position of It) = *Front) 
            (the side of It)) = (:set *Left *Right))

((forall ?x in (the Wheel parts of (a Car))
      where ((the position of ?x) = *Front) 
            (the side of ?x)) = (:set *Left *Right))

;;; ======================================================================

(reset-kb)

(every Airplane has
  (speed (300))
  (the-range (1000))
  (cost-per-mile (1)))

(every Car has
  (speed (60))
  (the-range (300))
  (cost-per-mile (0.01)))

(every Bicycle has
  (speed (20))
  (the-range (20))
  (cost-per-mile (0)))

(a Journey with 
(distance (100))
(max-travel-time (2)))

;; "Find which modes of transport have enough range and are
;;  fast enough for my journey..."
(oneof ?x in (allof  (:set (a Airplane) (a Car) (a Bicycle))
     where  (    ((the the-range of It) >= (the distance of (thelast Journey)))
             and (((the distance of (thelast Journey)) / (the speed of It)) 
                        <= (the max-travel-time of (thelast Journey)))))
 where (?x isa Airplane))
; includes (a Airplane))		; check I get the right answer
; covers '(a Airplane))		; NEW

(every Journey has
  (possible-modes-of-transport (                ;; repeat the above expression
     (allof (:set (a Airplane) (a Car) (a Bicycle))
      where  (    ((the the-range of It) >= (the distance of Self))
              and (((the distance of Self) / (the speed of It)) 
                        < (the max-travel-time of Self))))))
  (cheapest-mode-of-transport (
    (allof (the possible-modes-of-transport of Self)
     where (  (the cost-per-mile of It) 
            = (the min of (the cost-per-mile of
		(the bag of (the possible-modes-of-transport of Self)))))))))

((the cheapest-mode-of-transport of
	(a Journey with (distance (10))
			(max-travel-time (1))))
 isa Bicycle)

((the cheapest-mode-of-transport of
	(a Journey with (distance (300))
			(max-travel-time (10))))
 isa Car)

((the cheapest-mode-of-transport of
	(a Journey with (distance (300))
			(max-travel-time (2))))
 isa Airplane)

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

(*Pete has
       (instance-of (Person))
       (likes (*Sue *Sue)))

(*Pete likes)

(*Pete has
       (instance-of (Person))
       (parts ((a Leg) (a Leg))))       ; NB *not* duplicate instances!

(the parts of *Pete)

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

(*Pete has (salary (100)))

(*Joe  has (salary (100)))

(*Mycompany has 
       (instance-of (Company))
       (employees (*Pete *Joe)))

(every Company has 
	(salaries ((the salary of (the bag of (the employees of Self)))))
	(total-payroll ((the sum of (the salaries of Self)))))

((the total-payroll of *Mycompany) = 200)

(*Pete has (salary ((a MoneyUnit with (magnitude (100)) (units (*dollar))))))

(*Joe  has (salary ((a MoneyUnit with (magnitude (100)) (units (*dollar))))))

(100 = 100)

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

(every Square has
  (length ((Self width)))
  (width  ((Self length))))

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

(reset-kb)

(every Physobj has
  (parts ((Self d-parts) (Self d-parts * parts))))

(Car has (superclasses (Physobj)))

(every Car has (d-parts ((a Engine) (a Chassis) (a Body))))

(Engine has (superclasses (Physobj)))

(every Engine has 
    (d-parts ((a Carburetor) (a Battery) (a Combustion-chamber))))

(Body has (superclasses (Physobj)))

(every Body has 
  (d-parts ((a Door) (a Door) (a Frame) (a Windshield))))

(Door has (superclasses (Physobj)))

(every Door has
  (d-parts ((a Handle) (a Window) (a Panel))))

(every Physobj has
          (parts ((the d-parts of Self)
		  (the parts of (the d-parts of Self))))
          (leaf-parts ((allof (the parts of Self) 			; [1]
			 where (not (the d-parts of It))))))		; [2]

;;; Check all the leaf parts are there!
((the number of (the leaf-parts of (a Car))) = 12)

((the number of (the parts of (a Car))) = 16)

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

(Vehicle has (superclasses (Physobj)))

(every Vehicle has
  (body-parts ((a Frame) (a Fender)))
  (parts ((a Steering-wheel))))

(Car has (superclasses (Vehicle)))

(every Car has
  (mechanical-parts ((a Engine)))
  (body-parts ((a Frame))))

;;; SLOT HIERARCHY:
;;;   parts
;;;  /     \
;;; body-parts    mechanical-parts
(parts has 
  (instance-of (Slot))
  (subslots (mechanical-parts body-parts)))

(the parts of (a Car))

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

(likes has
  (instance-of (Slot))
  (inverse (liked-by)))

(every Professor has      ; all professors...
   (spouse ((a Person with (pets ((a Dog))))))    ; ...have a spouse with a dog
   (likes ((the pets of (the spouse of Self)))))  ; ...and like that dog.

(*Fred has (instance-of (Professor)))  ; Fred is a professor

(the pets of (the spouse of *Fred))    

(*Fred likes)

((thelast Dog) liked-by)     ; ...thus the query now succeeds.

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

(every Professor has
      (spouse ((a Person with
   (pets ((a Dog with 
       (liked-by (Self))))))))  ; `liked-by' defined
      (likes ((the pets of (the spouse of Self)))))     ; `likes' defined

(*Joe has (instance-of (Professor)))

(the pets of (the spouse of *Joe))     

((thelast Dog) liked-by)

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

#|
Now superceded by :seq operation

(rota has
	(instance-of (Slot))
	(duplicate-valued (t)))

(My-Coffee-Club has
       (rota (Pete Joe Pete Joe Pete)))

((the number of (the rota of My-Coffee-Club)) = 5)

((the number of (remove-dups (the rota of My-Coffee-Club))) = 2)
|#

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

(reset-kb)

(length has 
  (instance-of (Slot))
  (cardinality (N-to-1)))

(width has 
  (instance-of (Slot))
  (cardinality (N-to-1)))

(every Square has
  (length ((a Number)))
  (width ((Self length))))

(the width of (a Square with (length (1))))

(the length of (a Square with (width (1))))

(a Square with (width (1)))

(the length of (thelast Square))

(the width of (thelast Square))

(the length of (thelast Square))

(every Square has
  (length ((Self width)))
  (width  ((Self length))))

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

(a House)

(the name of *Pete)

(Remove has (superclasses (Activity)))

(every Remove has
  (text ("Remove" (Self object) "from" (Self location) ".")))

(the text of (a Remove with 
		(object ((a Sample)))
		(location ((a Box)))))

(make-sentence (the text of (a Remove with 
		(object ((a Sample)))
		(location ((a Box))))))

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

(Remove has (superclasses (Activity)))

(every Remove has
  (text ("Remove" (Self object) "from" (Self location) ".")))

(every Electrophoresis has
  (sample ((a Chemical)))
  (equipment ((a Separation-unit) (a Syringe)))
  (first-task (
    (a Remove with
	(object ((Self sample)))
	(location ((Self sample * delivery-medium)))))))

(Albumin has (superclasses (Chemical)))

(every Albumin has
  (delivery-medium ((a Bottle))))

(the text of (the first-task of (a Electrophoresis with 
	(sample ((a Albumin))))))

(make-sentence (the text of (the first-task of (a Electrophoresis 
	with (sample ((a Albumin)))))))

;;; ==================================================================
;;;                       START OF DEMO KB
;;; ==================================================================

(reset-kb)

(every Electrophoresis has
  (sample ((a Chemical)))
  (equipment ((a Separation-unit) (a Syringe)))
  (subevents (
    (a Remove with
        (object ((the sample of Self)))
        (location ((the delivery-medium of (the sample of Self)))))
    (a Insert with
        (object ((the sample of Self)))
        (destination ((the Separation-unit equipment of Self)))
        (equipment ((the Syringe equipment of Self))))
    (if   ((the density of (the sample of Self)) >= 3)
     then ((a Add with
                (object ((a Dilutant)))
                (destination ((the Separation-unit equipment of Self))))))
    (a Wait with
        (duration ((the floor of ((the density of (the sample of Self)) * 30))))
        (units (*Seconds)))
    (a Remove with
        (object ((the sample of Self)))
        (location ((the Separation-unit equipment of Self))))
    (a Store with 
        (object ((the sample of Self)))
        (destination ((the storage-medium of (the sample of Self))))))))

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

(Remove has (superclasses (Activity)))
(every Remove has
  (text ((:seq "Remove" (the object of Self) "from" (the location of Self)))))

(Insert has (superclasses (Activity)))
(every Insert has
  (text ((:seq "Insert" (the object of Self) "into" (the destination of Self) 
                "using" (Self equipment)))))

(Add has (superclasses (Activity)))
(every Add has
  (text ((:seq "Add" (the object of Self) "to" (the destination of Self)))))

(Wait has (superclasses (Activity)))
(every Wait has
  (text ((:seq "Wait" (the duration of Self) (the units of Self)))))

(Store has (superclasses (Activity)))
(every Store has
  (text ((:seq "Store" (the object of Self) "in" (the destination of Self)))))

;;; ----------
(Albumin has (superclasses (Chemical)))
(every Albumin has
  (density (1.2))
  (delivery-medium ((a Bottle)))
  (storage-medium ((a Fridge))))

(Endoprotein has (superclasses (Chemical)))
(every Endoprotein has
  (density (4.2))
  (delivery-medium ((a Box)))
  (storage-medium ((a Vacuum-flask))))

;;; ======================= END ==============================

(forall (the subevents of (a Electrophoresis with (sample ((a Albumin)))))
            (make-sentence (the text of It)))

(forall (the subevents of (a Electrophoresis with (sample ((a Endoprotein)))))
            (make-sentence (the text of It)))

(SETQ *LINEAR-PATHS* NIL)

;;; ======================================================================

;;; Test leaf-subevent definition:

(reset-kb)
(X has (subevent (SubX SubY)))
(SubX has (subevent (SubSubX SubSubX2)))
(SubSubX2 has (subevent (SubSubSubX SubSubSubX2)))
(SubY has (subevent (SubSubY SubSubY2 SubSubY3)))
(forall (:set X SubX SubY SubSubX SubSubX2 SubSubSubX SubSubSubX2 SubSubY SubSubY2 SubSubY3) (It has (instance-of (Event))))
(every Event has (leaf-subevents (((the leaf-subevents of (the subevent of Self)) or Self))))

((the leaf-subevents of X) = 
 (:set SubSubX SubSubSubX SubSubSubX2 SubSubY SubSubY2 SubSubY3))

(print "refman.km")

(SETQ *LINEAR-PATHS* T)

(reset-kb)

*Pete

34

Car

(a Car)

(an instance of Car)               ; equivalent

(a Car with (color (*Red)))

 (a Car with (color (*Blue)) (parts ((a Engine))))

 (showme (thelast Car))

(Car has (superclasses (Vehicle)))        ; Property of class Car

(every Car has                            ; Property of members of class Car
        (wheels (4)))

(Car has (superclasses (Vehicle)))

(every Car has (wheels (4)))

(showme Car)

(every Car has 
        (parts ((a Engine with (fuel-type (*Gasoline))))))

(every Car-maker has (product-type (Car)))

(*Pete has
        (owns ((an instance of (the product-type of (a Car-maker))))))

(the owns of *Pete)        ; generate an instance of the product-type

(a Car with (color (*White)))              

(thelast Car)                            ; the most recent car

(show-obj-stack)                     ; display the entire stack

(every Car has (parts ((a Hood) (a Engine with (fuel-type (*Gasoline))))))

((a Car) parts)                    ; create a car and find its parts

((a Car) parts Hood)               ; just the hood parts 

((a Car) parts Engine fuel-type)

((a Car) parts * fuel-type)        ; * is a wild-card

(the parts of (a Car))             ; alternative syntax
 
(the Hood parts of (a Car))         ; select just parts of type hood

(the fuel-type of (the Engine parts of (a Car)))   ; alternative syntax

(a Person with (parts ((a Leg) (a Leg))))       ; a two-legged person

(the Leg parts of (thelast Person))

(the first of (the Leg parts of (thelast Person)))  ; 'first' is a special slot

(the second of (the Leg parts of (thelast Person)))

(every Person has (parts ((a Head) (a Leg) (a Leg))))

(the parts of (a Person))

(showme (thelast Head))

((thelast Head) parts-of)                  ; Can see who _head151 belongs to

(*UT-net has 
        (instance-of (Network))
        (servers ((a Server) (a Server) (a Server))))

(*UT-net servers)

((thelast Server) servers-of)      ; Similarly, can find the network of _server154

(loves has
      (instance-of (Slot))
      (inverse (loved-by)))

(every Person has (loves ((Self pets))))

(*Fred has
      (instance-of (Person))
      (pets ((a Dog))))

(*Fred loves)

((thelast Dog) loved-by)          ; shows inverse was automatically installed

;;; ----------------------------------------
;;;		SUBSUMPTION
;;; ----------------------------------------

(reset-kb)

 (Airplane has (superclasses (Vehicle)))
 (every Airplane has 
        (parts ((a Engine with (connects-to ((a Heater)
                                             (a Pump with (size (*Big))))))
                (a Engine with (connects-to ((a Pump with (size (*Small)))))))))

 (*Airplane1 has (instance-of (Airplane)))

; (*Airplane1 is (a Vehicle with (parts ((a Engine)))))  ; OLD
(*Airplane1 is '(a Vehicle with (parts ((a Engine)))))  ; NEW (quote ' added)

; ((the parts of *Airplane1) are (a Engine with (connects-to ((a Pump))))) ; OLD
('(every Engine with (connects-to ((a Pump)))) subsumes (the parts of *Airplane1))  ; NEW

; ((the parts of *Airplane1) includes (a Engine with (connects-to ((a Heater))))) ; OLD
; ((the parts of *Airplane1) covers '(a Engine with (connects-to ((a Heater))))) ; NEW

;;; "The engine connected to the heater"
 (the Engine with
        (parts-of (*Airplane1))
        (connects-to ((a Heater))))

;;; "The engine connected to the big pump"
 (the Engine with
        (parts-of (*Airplane1))
        (connects-to ((a Pump with
                          (size (*Small))))))

 (the parts of *Airplane1)

;;; ----------
(the+ Car with (color (Red)))

(the+ Car with (color (Red)))

(Red has (instance-of (Bright-Color)))

(the+ Car with (color ((a Bright-Color))))

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

(every Person has 
          (happiness ((if (Self owns Chocolate) then *Hi else *Lo))))

(the happiness of (a Person with (owns ((a Chocolate)))))

(the happiness of (a Person)) ; a different person (NB closed-world assumption)

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

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

(every Tourist has
       (carries ((if (((the restricted-countries of (the visited-country of Self)))
                      includes (Self nationality))
                  then ((a Visa with (stamp ((Self visited-country)))))))))

(*USA has 
       (instance-of (Country)) 
       (restricted-countries (*Cuba *Korea *China)))

(the carries of (a Tourist with (nationality (*Cuba))
                                    (visited-country (*USA))))

(the stamp of (thelast Visa))    ; The Cuban tourist needs a USA visa to visit USA

;;; ======================================================================

(reset-kb)

 (*Porter has
        (owns ((a Car with (color (*Brown)) (age (*Old)))
               (a Car with (color (*Red))   (age (*New)))
               (a Van with (color (*Red))   (age (*Old))))))

 (allof (the owns of *Porter)
     where ((the color of It) = *Red))       ; all Porter's red things

 (oneof (the owns of *Porter)
     where ((the color of It) = *Red))       ; one of Porter's red things

(forall (the owns of *Porter)            ; the age(s) of all Porter's red things
      where ((the color of It) = *Red) 
            (the age of It))

; no longer used
; (forone (the owns of *Porter)            ; the age(s) of one of Porter's red things
;      where ((the color of It) = *Red) 
;            (the age of It))

 (allof (the owns of *Porter)             ; Porter's van(s)
     where (It isa Van)) 

 (the Van owns of *Porter)                ; Porter's van(s) (alternative formulation)

 (allof (the owns of *Porter)             ; Porter's new car(s)
     where ((It isa Car) and ((the age of It) = *New)))

((the color of (allof (the owns of *Porter)   ; The color(s) of Porter's new car(s)
            where ((It isa Car) and ((the age of It) = *New)))) = *Red)

(*Red has (instance-of (Pretty-color)))

((the number of
  (allof (the owns of *Porter)            ; all of Porter's pretty-colored things
     where ((the color of It) isa Pretty-color))) = 2)

;;; ----------
#|
The following forms need to be tested:
1     (#$allof ?var #$in  ?set #$where ?test)	
2     (#$allof ?var #$in ?set #$must ?test)	
3     (#$allof ?var #$in ?set #$where ?test2 #$must ?test)	
4     (#$oneof ?var #$in ?set #$where ?test)	
5     (#$theoneof ?var #$in ?set #$where ?test)	
6     (#$forall ?var #$in ?set ?value)
7     (#$forall-seq ?var #$in ?seq ?value)
8     (#$forall-bag ?var #$in ?bag ?value)
9     (#$forall ?var #$in ?set #$where ?constraint ?value)
10    (#$forall-bag ?var #$in ?bag #$where ?constraint ?value)
11    (#$forall-seq ?var #$in ?seq #$where ?constraint ?value)
|#


(allof ?x in (the owns of *Porter) where ((the color of ?x) = *Red))       ; 1. all Porter's red things
(allof ?x in (the owns of *Porter)  where (?x isa Van))            	   ; 1. Porter's van(s)
(oneof ?x in (the owns of *Porter) where ((the color of ?x) = *Red))       ; 4. one of Porter's red things
(theoneof ?x in (the owns of *Porter) where ((?x isa Van)))		   ; 5.
(forall ?x in (the owns of *Porter)     			           ; 9. the age(s) of all Porter's red things
      where ((the color of ?x) = *Red) 
            (the age of ?x))

((forall-seq ?x in (:seq 1 2 3 3) (?x + 1)) 				   ; 7
	= (:seq 2 3 4 4))

((forall-seq ?x in (:seq 1 2 3 3) where (?x >= 2) (?x + 1))		   ; 11
	= (:seq 3 4 4))

((forall-bag ?x in (:bag 1 2 3 3) (?x + 1)) 				   ; 8
	= (:bag 2 3 4 4))

((forall-bag ?x in (:bag 1 2 3 3) where (?x >= 2) (?x + 1))		   ; 10
	= (:bag 3 4 4))

(allof ?x in (:set 1 2 3) must (?x > 0))				   ; 2
(allof ?x in (:set 1 2 3 4 5 6 7 8 9 10) where (?x > 5) must (?x > 5))	   ; 3
 ((forall ?x in (:set 1 2 3) (?x * 2)) = (:set 2 4 6))			   ; 6

;;; ======================================================================

(reset-kb)

(every Person has 
       (favorite-clothes ((allof (the clothes of Self)
                           where ((the color of It) = 
                                        (the favorite-color of Self))))))
 (*Pete has
        (instance-of (Person))
        (favorite-color (*Black))
        (clothes ((a T-shirt with 
                        (color (*Black)) (cost (40)) (brand (*Levi)))
                  (a Hat with 
                        (color (*Pink))  (cost (10)) (brand (*Bambi)))
                  (a Sweater with 
                        (color (*Black)) (cost (20)) (brand (*Joeblo))))))


 (the favorite-clothes of *Pete)

;;; "A person's favorite brands are those of his cheap, favorite clothes."
 (every Person has 
       (favorite-brands ((forall (the favorite-clothes of Self)
                           where ((the cost of It) < 30)
                                 (the brand of It)))))

( (the favorite-brands of *Pete) = *Joeblo)

(reset-kb)

(a Network with (servers ((a Server) (a Server) (a Server))))

(servers has 
        (instance-of (Slot))
        (inverse (networked-to)))	    ; declare servers/networked-to as inverses

 (the servers of (thelast Network))

;;; "A server will poll all the other servers in it's network."
;;; Note: in (Self agent Server servers-of Network servers), servers-of is
;;;    the automatically installed inverse of servers.
;;;    Thus (Self agent Server servers-of Network) finds the polling server's network, 
;;;    and from there we can find all the servers in that network.
 (every Poll-event has 
        (agent  ((a Server)))
        (polled ((allof (the servers of 			; the servers...
				(the networked-to of 		; on the network of...
					(the agent of Self)))   ; the agent in this event..
                  where  (It /= (the agent of Self))))))	; except that agent itself.

;;; "Which server(s) does _Server114 poll?"
((the number of (the polled of (a Poll-event with (agent ((thelast Server)))))) = 2)

;;; ======================================================================

(*Joe has 
        (instance-of (Person))
        (beliefs ((a Triple with
                        (frame (*Fred))
                        (slot (loves))
                        (value (*Sue))))))

(the beliefs of *Joe)

(*Pete has (belief ((:triple *John owns (a Car)))))

(the belief of *Pete)

; No longer supported
;(the frame of (the belief of *Pete))
;(the slot of (the belief of *Pete))
;(the value of (the belief of *Pete))

(new-situation)

(every Putting has
	  (object ((a Thing)))
	  (destination ((a Box)))
	  (add-list ((:triple (the destination of Self) contents (the object of Self)))))

(the add-list of (a Putting with (object ((a Block))) (destination ((a Box)))))

;;; No longer supported
;(the frame of (the first of (the add-list of (thelast Putting))))
;(the slot of (the first of (the add-list of (thelast Putting))))
;(the value of (the first of (the add-list of (thelast Putting))))

(reset-kb)

(1 + 2)

(1 + 2 + 3)

;(the sum of (:set 1 2))
(the sum of (:bag 1 2))

; no longer supported
;(the difference of (:set 100 10 1))

(the number of (:set 100 10 1))  ; set cardinality

(every Car has (cost (10000)))
(every Dog has (cost (100)))
(every Book has (cost (10)))
(a Person with (possessions ((a Car) (a Dog) (a Book))))

(the possessions of (thelast Person))

(the number of (the possessions of (thelast Person)))

((thelast Person) possessions Thing number) ; KM-style path

;(the sum of (the cost of (the possessions of (thelast Person))))
(the sum of (the cost of (the bag of (the possessions of (thelast Person)))))

(every Thing has (cost ((a Number))))

(the sum of (:bag (the cost of (a Car)) 
                      (the cost of (a Book))))

(the sum of (:bag (the cost of (a Car)) 
                      (the cost of (a Elephant))))

;;; ----------------------------------------
;;;	aggregation slots:
;;; ----------------------------------------

(mysum has 
	(instance-of (Set-Aggregation-Slot)) 
	(aggregation-function ('#'(LAMBDA (VALS) (APPLY #'+ VALS)))))

((the mysum of (:set 1 2 3)) = 6)

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

((a Pet with (color (*Green))) & (a Fish with (size (*Small))))

(((a Cat) (a Dog)) && ((a Dog) (a Elephant)))   ; ie. {cat dog} && {dog elephant}

(((a Cat)) && ((a Cat)))

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

(every Mexican has-definition
       (instance-of (Person))			; most general superclass
       (lives-in (*Mexico)))

(Mexican has 
       (superclasses (North-American)))		; most specific superclass

(every Mexican has
       (temperament (*Cheerful)))

 (the temperament of (a Person with (lives-in (*Mexico))))

(*UK has-definition
        (instance-of (Country))
        (capital (*London)))

(*UK has
        (country-name ("the United Kingdom")))

(the country-name of (a Country with (capital (*London))))

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

(reset-kb)

(every Send has                    ; the "text" slot contains a template
        (text ((:seq (Self agent) "sends" (Self object) "to" (Self recipient)))))
        
(a Send with 
       (agent ((a Professor)))
       (object ((a Letter)))
       (recipient (*Joe)))

(the text of (thelast Send))

(make-sentence (the text of (thelast Send)))

(every Hole has
	(text ((:seq "a hole with depth" (Self depth) "nospace" "cm"))))

(make-sentence (the text of (a Hole with (depth (43)))))

(reset-kb)

(every Send has
       (text ((:seq "Send" (andify (Self objects)) "to" (Self destination)))))

((make-sentence (the text of (a Send with 
                                (objects ((a Box) (a Cat) (a Dog))) 
                                (destination (*London)))))
 = "Send the box, the cat, and the dog to london.")

;(every Group has
;	  (name ((make-phrase (:seq "a group of" (pluralize (the name of (Self member-type))))))))

(every Group has
	  (name ((:seq "a group of" (Self member-type) "nospace" "s"))))

(MyBooks has
	  (instance-of (Group))
	  (member-type (Book)))

((make-phrase (the name of MyBooks)) = "a group of books")

;;; ======================================================================
;;;		SITUATIONS
;;; ======================================================================

(reset-kb)

(Action has (superclasses (Event)))
(Putting has (superclasses (Action)))

(every Putting has
      (object ((a Thing)))
      (destination ((a Container)))
      (add-list ((:triple (the destination of Self) contents (the object of Self)))))

 (*My-Box has (instance-of (Container)))             ; Create a box...

 (*BlockA has (instance-of (Block)))                 ; and two blocks...

 (*BlockB has (instance-of (Block)))

(Situation1 has (instance-of (Situation)))

(in-situation Situation1)

(do-and-next (a Putting with          ; Put *BlockA in...
                                    (object (*BlockA))              
                                    (destination (*My-Box))))

 (the contents of *My-Box)           ; What is now in the box?

(curr-situation)			; Which situation am I in?

(global-situation)			; Return to the global KB

;;; "What was in *My-Box at the start?"
(not (in-situation Situation1 (the contents of *My-Box)))

;;; "What was in *My-Box at the end?"
((in-situation (the next-situation of Situation1) (the contents of *My-Box)) = *BlockA)

(SETQ *LINEAR-PATHS* NIL)
(print "situations.km")

;;; Test suite for new situations manual...

(reset-kb)

(*Joe has                                           ; Global KB assertion
        (instance-of (Person))                          ; (visible to all Situations)
        (birthdate (1963)))

(S == (a Situation))

(in-situation S)

((the birthdate of *Joe) = 1963)               ; Global facts are visible

(*Joe has (mood (*Happy)))            ; Make a local assertion

((the mood of *Joe) = *Happy)

; (in-situation *Global)

; (not (the mood of *Joe))                                  ; Local assertions are not

(S2 == (a Situation))

(in-situation S2)

(*Joe has (mood (*Sad)))              ; Alternative assertion

((the mood of *Joe) = *Sad)

(in-situation *Global)

(new-situation)
(curr-situation)
(global-situation)

(in-situation S ((the mood of *Joe) = *Happy))
(in-situation S2 ((the mood of *Joe) = *Sad))

((oneof (the all-instances of Situation)
     where (in-situation It ((the mood of *Joe) = *Happy))) = S)

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

(every Person has
      (year-of-birth ((a Number)))                                 ; (in years)
      (age (((the year of *Todays-Date) - (the year-of-birth of Self)))))

(*Fred has
      (instance-of (Person))
      (year-of-birth (1963)))

(new-situation)

(*Todays-Date has
                      (year (2000)))

((the year-of-birth of *Fred) = 1963)
((the age of *Fred) = 37)

(year-of-birth has
       (instance-of (Slot))
       (fluent-status (*Non-Fluent)))

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

(a Situation with
       (date (4-20-00))
       (time (*Morning)))

(*Petes-Thursday-Morning has
        (instance-of (Situation))
        (date (4-20-00))
        (time (*Morning)))

(in-situation *Petes-Thursday-Morning)

 (*Pete has
                                (location ((a Chair with 
                                              (in-front-of ((a Computer)))))))

(global-situation)

(*Petes-Thursday-Morning has
       (main-participant (*Pete)))

(S4 == (a Situation with
      (main-participant ((a Person)))))

(in-situation S4
        ((the main-participant of S4) has (location ((a Chair)))))

(S4b == (a Situation with
          (main-participant ((a Person)))
          (assertions ('((the main-participant of #,Self) has (location ((a Chair))))))))

(in-situation S4 ((the location of (the main-participant of S4)) isa Chair))
(in-situation S4b ((the location of (the main-participant of S4b)) isa Chair))

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

(Falling-Situation has (superclasses (Situation)))

(every Falling-Situation has
      (agent ((a Person))))

(in-every-situation Falling-Situation
        ((the agent of TheSituation) has (feelings (*Scared))))

;;; This is the internal representation, which the above generates. Note the #, unquoting is needed now.
(every Falling-Situation2 has
       (assertions ('((the agent of #,Self) has (feelings (*Scared))))))

(*Pete has (instance-of (Person)))

(FS == (a Falling-Situation with (agent (*Pete))))
(in-situation FS ((the feelings of *Pete) = *Scared))

(FS2 == (a Falling-Situation with (agent (*Pete))))
(in-situation FS2 ((the feelings of *Pete) = *Scared))

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

(:triple *Pete state *Happy)

(every Person has
      (belief ((:triple Self state *Happy))))

(reset-kb)

(every Person has
      (belief ((forall (the has-pets of Self)
                       (:triple It state *Happy)))))

((the belief of (a Person with (has-pets (*Fido)))) = (:triple *Fido state *Happy))

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

(every Person has
      (belief ((:triple (the house-lived-in of Self) appearance *Beautiful))))

;To do ...
;(not (is-true (:triple *Pete state *Happy)))

;(assert (:triple *Pete state *Happy))
;
;(is-true (:triple *Pete state *Happy))
;
;((the state of *Pete) = *Happy)

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

(Switching-On has (superclasses (Action)))

(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

;;; ----------
;;; This should become built-in:

(_Situation01 has (instance-of (Situation)))
(_Situation02 has (instance-of (Situation)))

(_Situation01 has
      (next-situation ((:args _Situation02 _Action01))))

((the next-situation of _Situation01) = (:args _Situation02 _Action01))

((the before-situation of _Action01) = (:args _Situation01 _Situation02))

((the1 next-situation of _Situation01) = _Situation02)

((the2 next-situation of _Situation01) = _Action01)

((the1 of                                         ; Take first element of ...
       (theoneof (the next-situation of _Situation01) ; the next-situation structure..
           where ((the2 of It) = _Action01)))       ; whose second element is _Action01
  = _Situation02)

;;; ---------- another one

(S has (instance-of (Situation)))
(S2 has (instance-of (Situation)))
(S has (next-situation ((:args S2 A))))

(in-situation (the next-situation of S))

((the prev-situation of S2) = (:args S A))

((the prev-situation of (curr-situation)) = (:args S A))

(in-situation (the prev-situation of (curr-situation)))

((curr-situation) = S)

;;; ----------
;;; A little KB...
;;; ----------

(reset-kb)

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(new-situation)                             ; Create initial situation

(*Switch1 has (position (*Down)))  ; initial switch position

((the brightness of *Light1) = *Dark)

(S0 == (a Switching-On with (object (*Switch1))))

(do-and-next S0)    ; Do it!!

((the position of *Switch1) = *Up)

((the brightness of *Light1) = *Bright)                                       ; ...and its ramifications

(in-situation (the prev-situation of (curr-situation)) 
	((the brightness of *Light1) = *Dark))

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

(reset-kb)

(contents has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Getting has (superclasses (Action)))

(every Getting has
  (object ((a Thing)))
  (source ((a Box)))
  (pcs-list ((:triple (the source of Self) contents (the object of Self))))    ; [1]
  (del-list ((:triple (the source of Self) contents (the object of Self)))))

(Putting has (superclasses (Action)))

(every Putting has
  (object ((a Thing)))
  (destination ((a Box)))
  (ncs-list ((:triple (the destination of Self) contents (the object of Self))))  ; [1]
  (add-list ((:triple (the destination of Self) contents (the object of Self)))))

(*My-Box has (instance-of (Box))) 	            ; Create a box...

(*BlockA has (instance-of (Block)))                 ; and two blocks...

(*BlockB has (instance-of (Block)))

;;; ----------
;;; Extra test of ncs and pcs here:
;;; ----------

(new-situation)

(do-and-next (a Getting with          ; Take *BlockA out...
                                    (object (*BlockA))              
                                    (source (*My-Box))))

(not (the contents of *My-Box))

;;; Implied by pcs
(in-situation (the prev-situation of (curr-situation))
	((the contents of *My-Box) = *BlockA))

(do-and-next (a Getting with          ; Take *BlockB out...
                                    (object (*BlockB))              
                                    (source (*My-Box))))

;;; Now we have a changed information implied. 
;;; But KM won't project BlockB right back to the first situation
(in-situation (the prev-situation of (curr-situation))
	((the contents of *My-Box) = *BlockB))

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

(new-situation)
;(*My-Box has (contents (*BlockA)))
;(next-situation)

(do-and-next (a Putting with          ; Put *BlockA in...
                                    (object (*BlockA))              
                                    (destination (*My-Box))))

;;; Actually, can't test like this, I get NIL &? *BlockA, which succeeds.
;;; Implied by ncs
;(in-situation (the prev-situation of (curr-situation))
;	(not ((the contents of *My-Box) &? *BlockA)))

;;; Instead, check constraint is there by checking projection is blocked...
;;; Here I check *BlockA "disappears"...slightly strange as a test, but
;;; it'll do...

(in-situation (the prev-situation of (curr-situation))
	(not (the contents of *My-Box)))

;;; ======================================================================

;;; back to the manual...

(new-situation)                                     ; Enter a situation...

(do-and-next (a Putting with          ; Put *BlockA in...
                                    (object (*BlockA))              
                                    (destination (*My-Box))))

((the contents of *My-Box) = *BlockA)                              ; *BlockA there!

(do-and-next (a Putting with          ; Put *BlockB in...
                                      (object (*BlockB))                       
                                      (destination (*My-Box))))

((the contents of *My-Box) = (:set *BlockA *BlockB))

(do-and-next (a Getting with          ; Take *BlockA out...
                                      (object (*BlockA))                        
                                      (source (*My-Box))))

((the contents of *My-Box) = *BlockB)                                 ; Just *BlockB left

(do-and-next (a Getting with          ; Take *BlockB out
                                     (object (*BlockB))
                                     (source (*My-Box))))

(not (the contents of *My-Box))

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

(Switching-On has (superclasses (Action)))

;;; trivial demo of projection...

(color has
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(new-situation)

(*Switch1 has (position (*Down)))

(*Switch1 has (color (*Red)))

(do-and-next  (a Switching-On with (object (*Switch1))))

((the color of *Switch1) = *Red)

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

(global-situation)

(possible-actions has
      (instance-of (Slot))
      (fluent-status (*Fluent)))

(every Action has
      (is-possible ((    (all-true (the pcs-list of Self))
                     and (not (some-true (the ncs-list of Self)))))))

(is-possible has
       (instance-of (Slot))
       (fluent-status (*Fluent))
       (situation-specific (t)))

(*My-Box has (instance-of (Container)))

(*BlockA has (instance-of (Block)))

(*BlockB has (instance-of (Block)))

(new-situation)

(not (the contents of *My-Box))

((the number of
  (allof (:set (a Getting with (object (*BlockA)) (source (*My-Box)))
               (a Getting with (object (*BlockB)) (source (*My-Box)))
               (a Putting with (object (*BlockA)) (destination (*My-Box)))
               (a Putting with (object (*BlockB)) (destination (*My-Box))))
   where (the is-possible of It))) = 2)
; (_Putting32 _Putting33)                         ; Can put *BlockA or *BlockB in *My-Box

; [_Situation29] KM> (do-and-next _Putting32)
(do-and-next                (a Putting with (object (*BlockA)) (destination (*My-Box))))

((the contents of *My-Box) = *BlockA)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where (the is-possible of It))) = 2)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where ((the is-possible of It) and (It isa Getting)))) = 1)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where ((the is-possible of It) and (It isa Putting)))) = 1)

; (_Getting41 _Putting44)                         ; Either you can get *BlockA out, or 
;                                                ; put *BlockB back in.

;;; ======================================================================
;;;			DEMO KB
;;; ======================================================================

(reset-kb)

(subevents has (fluent-status (*Non-Fluent)))

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(*My-Circuit has
  (instance-of (Circuit))
  (switches (*Switch1 *Switch2))
  (lights (*Light1 *Light2))
  (parts ((the lights of Self) (the switches of Self))))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(*Light2 has 
  (instance-of (Light))
  (controlled-by (*Switch2)))

(*Switch1 has (instance-of (Switch)))
(*Switch2 has (instance-of (Switch)))

(illuminated-lights has (instance-of (Slot)) (fluent-status (*Fluent)))
(brightness         has (instance-of (Slot)) (fluent-status (*Fluent)))
(possible-actions   has (instance-of (Slot)) (fluent-status (*Fluent)))
(applicable-actions has (instance-of (Slot)) (fluent-status (*Fluent)))
(is-possible        has (instance-of (Slot)) (fluent-status (*Fluent)))

(is-possible        has (situation-specific (t)))

(Circuit has (superclasses (Physobj)))

(every Circuit has
  (illuminated-lights (
        (allof (the lights of Self)
         where ((the brightness of It) = *Bright)))))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright 
                else (if   ((the position of (the controlled-by of Self)) = *Down)
                      then *Dark)))))

(Action has (superclasses (Event)))

(every Action has
  (is-possible ((    (all-true (the pcs-list of Self))
                 and (not (some-true (the ncs-list of Self)))))))

(Switching-On has (superclasses (Action)))

(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))


(Switch has (superclasses (Physobj)))

(every Switch has
  (applicable-actions (
    (a Switching-Off with (object (Self)))
    (a Switching-On  with (object (Self))))))

(every Physobj has
  (possible-actions (
     (allof (the applicable-actions of Self) 
      where (the is-possible of It))                           ; [1]
     (the possible-actions of (the parts of Self)))))          ; [2]

(My-Plan has (superclasses (Plan)))
(every My-Plan has
  (subevents (
    (a Switching-On with (object (*Switch1)))           ; step 1
    (a Switching-On with (object (*Switch2)))           ; step 2
    (a Switching-Off with (object (*Switch1)))          ; step 3
        )))

(*My-Plan has (instance-of (My-Plan)))
(*My-Plan2 has (instance-of (My-Plan)))

((the number of (the subevents of *My-Plan)) = 3)

; (_Switching-On2 _Switching-On3 _Switching-Off4)           ; The three steps

(new-situation)                                       ; Define initial situation

 (*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

(do-and-next (the first of (the subevents of *My-Plan)))

(do-and-next (the second of (the subevents of *My-Plan)))

(do-and-next (the third of (the subevents of *My-Plan)))

((the illuminated-lights of *My-Circuit) = *Light2)                        ; Just *Light2 on

(new-context)

(in-situation *Global (NS == (a Situation)))

(in-situation NS)

(*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

(forall (in-situation *Global (the subevents of *My-Plan2))
                      (do-and-next It))

((the illuminated-lights of *My-Circuit) = *Light2)

;;; Note - two answers, from the two simulations separate simulations run above
((the number of
  (allof (the all-instances of Situation)
     where (in-situation It (    ((the position of *Switch1) = *Up)
                             and ((the position of *Switch2) = *Up)))))
 = 2)

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

(global-situation)

(future-situations has (fluent-status (*Non-Fluent)))

(every Situation has 
        (future-situations ((the next-situation of Self)
                            (the future-situations of (the next-situation of Self)))))

((the number of (the future-situations of NS)) = 3)

;;; should be one!
((the number of
    (allof (:set NS (the future-situations of NS))
     where (in-situation It (    ((the position of *Switch1) = *Up)
                             and ((the position of *Switch2) = *Up)))))
 = 1)

;;; --------------------
;;;	POSSIBLE WORLDS
;;; --------------------

(S7 == (a Situation))

(in-situation S7)                     ; Define initial situation

(*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

((the number of (the possible-actions of *My-Circuit)) = 2)
; (_Switching-On246 _Switching-On250)

;(trace)

;;; This should work, to give names to the resulting situations
(((forall (the possible-actions of *My-Circuit) (do It))) === (S8 S9))


(showme S7)             ; Note: Still in initial situation
; (_Situation7 has
;  (next-situation ((:args _Situation8 _Switching-On246)
;                   (:args _Situation9 _Switching-On250))))

((the1 next-situation of S7) = (:set S8 S9))

(in-situation S8 ((the brightness of *Light1) = *Bright))          ; (i.e., yes)

(in-situation S9 ((the brightness of *Light1) = *Dark))             ; (i.e., no)

((oneof (the1 next-situation of S7)
     where (in-situation It ((the brightness of *Light1) = *Bright))) = S8)

((the2 prev-situation of S8) isa Switching-On)

((the2 prev-situation of S8) == *My-Switching-On)

(in-situation S7 ((the object of *My-Switching-On) = *Switch1))

;;; ----------
;;; Creation and Destruction...
;;; ----------

(reset-kb)

(is-material has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Baking has (superclasses (Action)))
(every Baking has
      (agent ((a Person)))
      (ingredients ((must-be-a Food)))
      (result ((must-be-a Food)))           ; (sometimes violated in practice... :-))
      (pcs-list ((forall (the ingredients of Self)
                     (:triple It is-material t))))             			; [1]
      (ncs-list ((:triple (the result of Self) is-material t)))                 ; [2]
      (add-list ((:triple (the result of Self) is-material t)))                 ; [3]
      (del-list ((forall (the ingredients of Self)
                     (:triple It is-material t)))))                             ; [4]

(Baking-A-Cake has (superclasses (Baking)))

(every Baking-A-Cake has
      (ingredients ((a Piece-Of-Flour) (a Piece-Of-Sugar) (a Piece-Of-Butter) 
                    (a Egg) (a Egg)))
      (result ((a Cake))))

(agent has (instance-of (Slot)) (fluent-status (*Non-Fluent)))
(result has (instance-of (Slot)) (fluent-status (*Non-Fluent)))

(*Pete has (instance-of (Person)))

(a Baking-A-Cake with
                  (agent (*Pete)))

(new-situation)

(do-and-next (the Baking-A-Cake))

(the is-material of (the result of (thelast Baking-A-Cake)))

(not (the is-material of
                        (the Piece-Of-Four ingredients of (thelast Baking-A-Cake))))

(in-situation (the prev-situation of (curr-situation))
                                (the is-material of
                                  (the Piece-Of-Flour ingredients of 
                                    (thelast Baking-A-Cake))))
; (t)

;;; ======================================================================
;;;	THE MAGICIAN'S RABBIT
;;; ======================================================================

(reset-kb)

(instance-of-is-fluent)

(Action has (superclasses (Event)))

(Create has (superclasses (Action)))
(Change has (superclasses (Action)))
(Destroy has (superclasses (Action)))

(new-situation)

(do-and-next
   (a Create with 
     (created (*MyThing))
     (will-be-a (Rabbit))
     (add-list ((:triple (the created of Self) instance-of (the will-be-a of Self))))))

(do-and-next
   (a Change with 
     (changed (*MyThing))
     (will-be-a (Dove))
     (del-list ((:triple (the changed of Self) instance-of 
                                          (the instance-of of (the changed of Self)))))
     (add-list ((:triple (the changed of Self) instance-of (the will-be-a of Self))))))

(do-and-next
  (a Destroy with 
     (destroyed (*MyThing))
     (del-list ((:triple (the destroyed of Self) instance-of 
                                       (the instance-of of (the destroyed of Self)))))))

((forall (the instances of Situation)
	 (in-situation It (the instance-of of *MyThing))) = 
 (:set Thing Rabbit Dove))

;;; ======================================================================
;;;	try-do, and try-do-and-next, and checking for consistency of PCs:
;;; ======================================================================

(reset-kb)

(position has 
  (instance-of (Slot))
  (cardinality (N-to-1))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(object has (fluent-status (*Inertial-Fluent)))		; New: 2/8/00

(new-situation)                             ; Create initial situation

(S0 == (a Switching-On with (object (*Switch1))))

;;; Preconditions not satisfied...
(not (try-do S0))
(not (try-do-and-next S0))

;;; so assume them...
(do-and-next S0)

;;; Can't do this action again, as the preconditions would be inconsistent...
(not (do-and-next S0))

;;; null action...
(next-situation)

;;; Still can't do them...
(not (do-and-next S0))

;;; But can do this...
(do-and-next (a Switching-Off with (object (*Switch1))))

;;; But not a second time
(not (do-and-next (a Switching-Off with (object (*Switch1)))))

;;; ----------------------------------------
;;; Alternative formulation, using ncs-list:

(reset-kb)

(position has 
  (instance-of (Slot))
  (cardinality (N-to-1))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (ncs-list ((:triple (the object of Self) position *Up)))	; NB ncs-list
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (ncs-list ((:triple (the object of Self) position *Down)))	; NB ncs-list
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(object has (fluent-status (*Inertial-Fluent)))		; New: 2/8/00

(new-situation)                             ; Create initial situation

(S0 == (a Switching-On with (object (*Switch1))))

(do-and-next S0)

;;; Can't do this action again, as the preconditions would be inconsistent...
(not (do-and-next S0))

;;; null action...
(next-situation)

;;; Still can't do them...
(not (do-and-next S0))

;;; But can do this...
(do-and-next (a Switching-Off with (object (*Switch1))))

;;; But not a second time
(not (do-and-next (a Switching-Off with (object (*Switch1)))))

;;; ======================================================================
;;;	TEST SITUATION-SPECIFIC:
;;; ======================================================================
#|
Redundant now
(reset-kb)

(location has
  (situation-specific (t)))

(every Car has (location ((a Place))))

;;; This should fail in the global situation!
(not (the location of (a Car)))
|#

;;; ======================================================================
;;;		AGAIN...
;;; ======================================================================

;;; Test suite for new situations manual...

(reset-kb)

(*Joe has                                           ; Global KB assertion
        (instance-of (Person))                          ; (visible to all Situations)
        (birthdate (1963)))

(S == (a Situation))

(in-situation S)

((the birthdate of *Joe) = 1963)               ; Global facts are visible

(*Joe has (mood (*Happy)))            ; Make a local assertion

((the mood of *Joe) = *Happy)

; (in-situation *Global)

; (not (the mood of *Joe))                                  ; Local assertions are not

(S2 == (a Situation))

(in-situation S2)

(*Joe has (mood (*Sad)))              ; Alternative assertion

((the mood of *Joe) = *Sad)

(in-situation *Global)

(new-situation)
(curr-situation)
(global-situation)

(in-situation S ((the mood of *Joe) = *Happy))
(in-situation S2 ((the mood of *Joe) = *Sad))

((oneof (the all-instances of Situation)
     where (in-situation It ((the mood of *Joe) = *Happy))) = S)

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

(every Person has
      (year-of-birth ((a Number)))                                 ; (in years)
      (age (((the year of *Todays-Date) - (the year-of-birth of Self)))))

(*Fred has
      (instance-of (Person))
      (year-of-birth (1963)))

(new-situation)

(*Todays-Date has
                      (year (2000)))

((the year-of-birth of *Fred) = 1963)
((the age of *Fred) = 37)

(year-of-birth has
       (instance-of (Slot))
       (fluent-status (*Non-Fluent)))

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

(a Situation with
       (date (4-20-00))
       (time (*Morning)))

(*Petes-Thursday-Morning has
        (instance-of (Situation))
        (date (4-20-00))
        (time (*Morning)))

(in-situation *Petes-Thursday-Morning)

 (*Pete has
                                (location ((a Chair with 
                                              (in-front-of ((a Computer)))))))

(global-situation)

(*Petes-Thursday-Morning has
       (main-participant (*Pete)))

(S4 == (a Situation with
      (main-participant ((a Person)))))

(in-situation S4
        ((the main-participant of S4) has (location ((a Chair)))))

(S4b == (a Situation with
          (main-participant ((a Person)))
          (assertions ('((the main-participant of #,Self) has (location ((a Chair))))))))

(in-situation S4 ((the location of (the main-participant of S4)) isa Chair))
(in-situation S4b ((the location of (the main-participant of S4b)) isa Chair))

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

(Falling-Situation has (superclasses (Situation)))

(every Falling-Situation has
      (agent ((a Person))))

(in-every-situation Falling-Situation
        ((the agent of TheSituation) has (feelings (*Scared))))

;;; This is the internal representation, which the above generates. Note the #, unquoting is needed now.
(every Falling-Situation2 has
       (assertions ('((the agent of #,Self) has (feelings (*Scared))))))

(*Pete has (instance-of (Person)))

(FS == (a Falling-Situation with (agent (*Pete))))
(in-situation FS ((the feelings of *Pete) = *Scared))

(FS2 == (a Falling-Situation with (agent (*Pete))))
(in-situation FS2 ((the feelings of *Pete) = *Scared))

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

(:triple *Pete state *Happy)

(every Person has
      (belief ((:triple Self state *Happy))))

(reset-kb)

(every Person has
      (belief ((forall (the has-pets of Self)
                       (:triple It state *Happy)))))

((the belief of (a Person with (has-pets (*Fido)))) = (:triple *Fido state *Happy))

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

(every Person has
      (belief ((:triple (the house-lived-in of Self) appearance *Beautiful))))

;To do ...
;(not (is-true (:triple *Pete state *Happy)))

;(assert (:triple *Pete state *Happy))
;
;(is-true (:triple *Pete state *Happy))
;
;((the state of *Pete) = *Happy)

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

(Switching-On has (superclasses (Action)))

(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

;;; ----------
;;; This should become built-in:

(_Situation01 has (instance-of (Situation)))
(_Situation02 has (instance-of (Situation)))

(_Situation01 has
      (next-situation ((:args _Situation02 _Action01))))

((the next-situation of _Situation01) = (:args _Situation02 _Action01))

((the before-situation of _Action01) = (:args _Situation01 _Situation02))

((the1 next-situation of _Situation01) = _Situation02)

((the2 next-situation of _Situation01) = _Action01)

((the1 of                                         ; Take first element of ...
       (theoneof (the next-situation of _Situation01) ; the next-situation structure..
           where ((the2 of It) = _Action01)))       ; whose second element is _Action01
  = _Situation02)

;;; ---------- another one

(S has (instance-of (Situation)))
(S2 has (instance-of (Situation)))
(S has (next-situation ((:args S2 A))))

(in-situation (the next-situation of S))

((the prev-situation of S2) = (:args S A))

((the prev-situation of (curr-situation)) = (:args S A))

(in-situation (the prev-situation of (curr-situation)))

((curr-situation) = S)

;;; ----------
;;; A little KB...
;;; ----------

(reset-kb)

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(new-situation)                             ; Create initial situation

(*Switch1 has (position (*Down)))  ; initial switch position

((the brightness of *Light1) = *Dark)

(S0 == (a Switching-On with (object (*Switch1))))

(do-and-next S0)    ; Do it!!

((the position of *Switch1) = *Up)

((the brightness of *Light1) = *Bright)                                       ; ...and its ramifications

(in-situation (the prev-situation of (curr-situation)) 
	((the brightness of *Light1) = *Dark))

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

(reset-kb)

(contents has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Getting has (superclasses (Action)))

(every Getting has
  (object ((a Thing)))
  (source ((a Box)))
  (pcs-list ((:triple (the source of Self) contents (the object of Self))))    ; [1]
  (del-list ((:triple (the source of Self) contents (the object of Self)))))

(Putting has (superclasses (Action)))

(every Putting has
  (object ((a Thing)))
  (destination ((a Box)))
  (ncs-list ((:triple (the destination of Self) contents (the object of Self))))  ; [1]
  (add-list ((:triple (the destination of Self) contents (the object of Self)))))

(*My-Box has (instance-of (Box))) 	            ; Create a box...

(*BlockA has (instance-of (Block)))                 ; and two blocks...

(*BlockB has (instance-of (Block)))

;;; ----------
;;; Extra test of ncs and pcs here:
;;; ----------

(new-situation)

(do-and-next (a Getting with          ; Take *BlockA out...
                                    (object (*BlockA))              
                                    (source (*My-Box))))

(not (the contents of *My-Box))

;;; Implied by pcs
(in-situation (the prev-situation of (curr-situation))
	((the contents of *My-Box) = *BlockA))

(do-and-next (a Getting with          ; Take *BlockB out...
                                    (object (*BlockB))              
                                    (source (*My-Box))))

;;; Now we have a changed information implied. 
;;; But KM won't project BlockB right back to the first situation
(in-situation (the prev-situation of (curr-situation))
	((the contents of *My-Box) = *BlockB))

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

(new-situation)
;(*My-Box has (contents (*BlockA)))
;(next-situation)

(do-and-next (a Putting with          ; Put *BlockA in...
                                    (object (*BlockA))              
                                    (destination (*My-Box))))

;;; Actually, can't test like this, I get NIL &? *BlockA, which succeeds.
;;; Implied by ncs
;(in-situation (the prev-situation of (curr-situation))
;	(not ((the contents of *My-Box) &? *BlockA)))

;;; Instead, check constraint is there by checking projection is blocked...
;;; Here I check *BlockA "disappears"...slightly strange as a test, but
;;; it'll do...

(in-situation (the prev-situation of (curr-situation))
	(not (the contents of *My-Box)))

;;; ======================================================================

;;; back to the manual...

(new-situation)                                     ; Enter a situation...

(do-and-next (a Putting with          ; Put *BlockA in...
                                    (object (*BlockA))              
                                    (destination (*My-Box))))

((the contents of *My-Box) = *BlockA)                              ; *BlockA there!

(do-and-next (a Putting with          ; Put *BlockB in...
                                      (object (*BlockB))                       
                                      (destination (*My-Box))))

((the contents of *My-Box) = (:set *BlockA *BlockB))

(do-and-next (a Getting with          ; Take *BlockA out...
                                      (object (*BlockA))                        
                                      (source (*My-Box))))

((the contents of *My-Box) = *BlockB)                                 ; Just *BlockB left

(do-and-next (a Getting with          ; Take *BlockB out
                                     (object (*BlockB))
                                     (source (*My-Box))))

(not (the contents of *My-Box))

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

(Switching-On has (superclasses (Action)))

;;; trivial demo of projection...

(color has
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(new-situation)

(*Switch1 has (position (*Down)))

(*Switch1 has (color (*Red)))

(do-and-next  (a Switching-On with (object (*Switch1))))

((the color of *Switch1) = *Red)

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

(global-situation)

(possible-actions has
      (instance-of (Slot))
      (fluent-status (*Fluent)))

(every Action has
      (is-possible ((    (all-true (the pcs-list of Self))
                     and (not (some-true (the ncs-list of Self)))))))

(is-possible has
       (instance-of (Slot))
       (fluent-status (*Fluent))
       (situation-specific (t)))

(*My-Box has (instance-of (Container)))

(*BlockA has (instance-of (Block)))

(*BlockB has (instance-of (Block)))

(new-situation)

(not (the contents of *My-Box))

((the number of
  (allof (:set (a Getting with (object (*BlockA)) (source (*My-Box)))
               (a Getting with (object (*BlockB)) (source (*My-Box)))
               (a Putting with (object (*BlockA)) (destination (*My-Box)))
               (a Putting with (object (*BlockB)) (destination (*My-Box))))
   where (the is-possible of It))) = 2)
; (_Putting32 _Putting33)                         ; Can put *BlockA or *BlockB in *My-Box

; [_Situation29] KM> (do-and-next _Putting32)
(do-and-next                (a Putting with (object (*BlockA)) (destination (*My-Box))))

((the contents of *My-Box) = *BlockA)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where (the is-possible of It))) = 2)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where ((the is-possible of It) and (It isa Getting)))) = 1)

((the number of (allof (:set
                           (a Getting with (object (*BlockA)) (source (*My-Box)))
                           (a Getting with (object (*BlockB)) (source (*My-Box)))
                           (a Putting with (object (*BlockA)) (destination (*My-Box)))
                           (a Putting with (object (*BlockB)) (destination (*My-Box))))
                    where ((the is-possible of It) and (It isa Putting)))) = 1)

; (_Getting41 _Putting44)                         ; Either you can get *BlockA out, or 
;                                                ; put *BlockB back in.

;;; ======================================================================
;;;			DEMO KB
;;; ======================================================================

(reset-kb)

(subevents has (fluent-status (*Non-Fluent)))

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(*My-Circuit has
  (instance-of (Circuit))
  (switches (*Switch1 *Switch2))
  (lights (*Light1 *Light2))
  (parts ((the lights of Self) (the switches of Self))))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(*Light2 has 
  (instance-of (Light))
  (controlled-by (*Switch2)))

(*Switch1 has (instance-of (Switch)))
(*Switch2 has (instance-of (Switch)))

(illuminated-lights has (instance-of (Slot)) (fluent-status (*Fluent)))
(brightness         has (instance-of (Slot)) (fluent-status (*Fluent)))
(possible-actions   has (instance-of (Slot)) (fluent-status (*Fluent)))
(applicable-actions has (instance-of (Slot)) (fluent-status (*Fluent)))
(is-possible        has (instance-of (Slot)) (fluent-status (*Fluent)))

(is-possible        has (situation-specific (t)))

(Circuit has (superclasses (Physobj)))

(every Circuit has
  (illuminated-lights (
        (allof (the lights of Self)
         where ((the brightness of It) = *Bright)))))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright 
                else (if   ((the position of (the controlled-by of Self)) = *Down)
                      then *Dark)))))

(Action has (superclasses (Event)))

(every Action has
  (is-possible ((    (all-true (the pcs-list of Self))
                 and (not (some-true (the ncs-list of Self)))))))

(Switching-On has (superclasses (Action)))

(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))


(Switch has (superclasses (Physobj)))

(every Switch has
  (applicable-actions (
    (a Switching-Off with (object (Self)))
    (a Switching-On  with (object (Self))))))

(every Physobj has
  (possible-actions (
     (allof (the applicable-actions of Self) 
      where (the is-possible of It))                           ; [1]
     (the possible-actions of (the parts of Self)))))          ; [2]

(My-Plan has (superclasses (Plan)))
(every My-Plan has
  (subevents (
    (a Switching-On with (object (*Switch1)))           ; step 1
    (a Switching-On with (object (*Switch2)))           ; step 2
    (a Switching-Off with (object (*Switch1)))          ; step 3
        )))

(*My-Plan has (instance-of (My-Plan)))
(*My-Plan2 has (instance-of (My-Plan)))

((the number of (the subevents of *My-Plan)) = 3)

; (_Switching-On2 _Switching-On3 _Switching-Off4)           ; The three steps

(new-situation)                                       ; Define initial situation

 (*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

(do-and-next (the first of (the subevents of *My-Plan)))

(do-and-next (the second of (the subevents of *My-Plan)))

(do-and-next (the third of (the subevents of *My-Plan)))

((the illuminated-lights of *My-Circuit) = *Light2)                        ; Just *Light2 on

(new-context)

(in-situation *Global (NS == (a Situation)))

(in-situation NS)

(*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

(forall (in-situation *Global (the subevents of *My-Plan2))
                      (do-and-next It))

((the illuminated-lights of *My-Circuit) = *Light2)

;;; Note - two answers, from the two simulations separate simulations run above
((the number of
  (allof (the all-instances of Situation)
     where (in-situation It (    ((the position of *Switch1) = *Up)
                             and ((the position of *Switch2) = *Up)))))
 = 2)

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

(global-situation)

(future-situations has (fluent-status (*Non-Fluent)))

(every Situation has 
        (future-situations ((the next-situation of Self)
                            (the future-situations of (the next-situation of Self)))))

((the number of (the future-situations of NS)) = 3)

;;; should be one!
((the number of
    (allof (:set NS (the future-situations of NS))
     where (in-situation It (    ((the position of *Switch1) = *Up)
                             and ((the position of *Switch2) = *Up)))))
 = 1)

;;; --------------------
;;;	POSSIBLE WORLDS
;;; --------------------

(S7 == (a Situation))

(in-situation S7)                     ; Define initial situation

(*Switch1 has (position (*Down)))
(*Switch2 has (position (*Down)))

((the number of (the possible-actions of *My-Circuit)) = 2)
; (_Switching-On246 _Switching-On250)

;;; This should work, to give names to the resulting situations
(((forall (the possible-actions of *My-Circuit) (do It))) === (S8 S9))


(showme S7)             ; Note: Still in initial situation
; (_Situation7 has
;  (next-situation ((:args _Situation8 _Switching-On246)
;                   (:args _Situation9 _Switching-On250))))

((the1 next-situation of S7) = (:set S8 S9))

(in-situation S8 ((the brightness of *Light1) = *Bright))          ; (i.e., yes)

(in-situation S9 ((the brightness of *Light1) = *Dark))             ; (i.e., no)

((oneof (the1 next-situation of S7)
     where (in-situation It ((the brightness of *Light1) = *Bright))) = S8)

((the2 prev-situation of S8) isa Switching-On)

((the2 prev-situation of S8) == *My-Switching-On)

(in-situation S7 ((the object of *My-Switching-On) = *Switch1))

;;; ----------
;;; Creation and Destruction...
;;; ----------

(reset-kb)

(is-material has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Baking has (superclasses (Action)))
(every Baking has
      (agent ((a Person)))
      (ingredients ((must-be-a Food)))
      (result ((must-be-a Food)))           ; (sometimes violated in practice... :-))
      (pcs-list ((forall (the ingredients of Self)
                     (:triple It is-material t))))             			; [1]
      (ncs-list ((:triple (the result of Self) is-material t)))                 ; [2]
      (add-list ((:triple (the result of Self) is-material t)))                 ; [3]
      (del-list ((forall (the ingredients of Self)
                     (:triple It is-material t)))))                             ; [4]

(Baking-A-Cake has (superclasses (Baking)))

(every Baking-A-Cake has
      (ingredients ((a Piece-Of-Flour) (a Piece-Of-Sugar) (a Piece-Of-Butter) 
                    (a Egg) (a Egg)))
      (result ((a Cake))))

(agent has (instance-of (Slot)) (fluent-status (*Non-Fluent)))
(result has (instance-of (Slot)) (fluent-status (*Non-Fluent)))

(*Pete has (instance-of (Person)))

(a Baking-A-Cake with
                  (agent (*Pete)))

(new-situation)

(do-and-next (the Baking-A-Cake))

(the is-material of (the result of (thelast Baking-A-Cake)))

(not (the is-material of
                        (the Piece-Of-Four ingredients of (thelast Baking-A-Cake))))

(in-situation (the prev-situation of (curr-situation))
                                (the is-material of
                                  (the Piece-Of-Flour ingredients of 
                                    (thelast Baking-A-Cake))))
; (t)

;;; ======================================================================
;;;	THE MAGICIAN'S RABBIT
;;; ======================================================================

(reset-kb)

(instance-of-is-fluent)

(Action has (superclasses (Event)))

(Create has (superclasses (Action)))
(Change has (superclasses (Action)))
(Destroy has (superclasses (Action)))

(new-situation)

(do-and-next
   (a Create with 
     (created (*MyThing))
     (will-be-a (Rabbit))
     (add-list ((:triple (the created of Self) instance-of (the will-be-a of Self))))))

(do-and-next
   (a Change with 
     (changed (*MyThing))
     (will-be-a (Dove))
     (del-list ((:triple (the changed of Self) instance-of 
                                          (the instance-of of (the changed of Self)))))
     (add-list ((:triple (the changed of Self) instance-of (the will-be-a of Self))))))

(do-and-next
  (a Destroy with 
     (destroyed (*MyThing))
     (del-list ((:triple (the destroyed of Self) instance-of 
                                       (the instance-of of (the destroyed of Self)))))))

((forall (the instances of Situation)
	 (in-situation It (the instance-of of *MyThing))) = 
 (:set Thing Rabbit Dove))

;;; ======================================================================
;;;	try-do, and try-do-and-next, and checking for consistency of PCs:
;;; ======================================================================

(reset-kb)

(position has 
  (instance-of (Slot))
  (cardinality (N-to-1))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Down)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (pcs-list ((:triple (the object of Self) position *Up)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(object has (fluent-status (*Inertial-Fluent)))		; New: 2/8/00

(new-situation)                             ; Create initial situation

(S0 == (a Switching-On with (object (*Switch1))))

;;; Preconditions not satisfied...
(not (try-do S0))
(not (try-do-and-next S0))

;;; so assume them...
(do-and-next S0)

;;; Can't do this action again, as the preconditions would be inconsistent...
(not (do-and-next S0))

;;; null action...
(next-situation)

;;; Still can't do them...
(not (do-and-next S0))

;;; But can do this...
(do-and-next (a Switching-Off with (object (*Switch1))))

;;; But not a second time
(not (do-and-next (a Switching-Off with (object (*Switch1)))))

;;; ----------------------------------------
;;; Alternative formulation, using ncs-list:

(reset-kb)

(position has 
  (instance-of (Slot))
  (cardinality (N-to-1))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (ncs-list ((:triple (the object of Self) position *Up)))	; NB ncs-list
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(Switching-Off has (superclasses (Action)))

(every Switching-Off has
  (object ((a Switch)))
  (ncs-list ((:triple (the object of Self) position *Down)))	; NB ncs-list
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(Switch has (superclasses (Physobj)))

(*Up   has (instance-of (Switch-Position)))
(*Down has (instance-of (Switch-Position)))

(every Light has
  (brightness ((if   ((the position of (the controlled-by of Self)) = *Up) 
                then *Bright
                else (if   ((the position of (the controlled-by of Self)) = *Down) 
                      then *Dark)))))

; new
(brightness has 
  (instance-of (Slot))
  (fluent-status (*Fluent)))

(*Switch1 has (instance-of (Switch)))

(*Light1 has 
  (instance-of (Light))
  (controlled-by (*Switch1)))

(object has (fluent-status (*Inertial-Fluent)))		; New: 2/8/00

(new-situation)                             ; Create initial situation

(S0 == (a Switching-On with (object (*Switch1))))

(do-and-next S0)

;;; Can't do this action again, as the preconditions would be inconsistent...
(not (do-and-next S0))

;;; null action...
(next-situation)

;;; Still can't do them...
(not (do-and-next S0))

;;; But can do this...
(do-and-next (a Switching-Off with (object (*Switch1))))

;;; But not a second time
(not (do-and-next (a Switching-Off with (object (*Switch1)))))

;;; ======================================================================
;;;	TEST SITUATION-SPECIFIC:
;;; ======================================================================
#|
REDUNDANT NOW
(reset-kb)

(location has
  (situation-specific (t)))

(every Car has (location ((a Place))))

;;; This should fail in the global situation!
(not (the location of (a Car)))
|#


;;; ======================================================================
;;; as we're in situations, we DON'T want to try evaluating
;;; the age slot in *Global, normally a side-effect of performing "=="
;;; ======================================================================

(reset-kb)

(age has
  (cardinality (N-to-1)))

(pet has
  (cardinality (N-to-1))
  (fluent-status (*Non-Fluent)))

(_Man1 has 
	(instance-of (Man))
	(pet ((a Dog)))
	(age ((the age of _Man3) (must-be-a Number))))

(_Man2 has 
	(instance-of (Man))
	(pet (*Fido))
	(age ((the age of _Man4))))

(new-situation)

; (trace)

(_Man1 == _Man2)

(reset-kb)

(age has
  (cardinality (N-to-1)))

(pet has
  (cardinality (N-to-1))
  (fluent-status (*Non-Fluent)))

(_Man1 has 
	(instance-of (Man))
	(pet ((mustnt-be-a Dog)))
	(age ((the age of _Man3) (must-be-a Number))))

(_Man2 has 
	(instance-of (Man))
	(pet ((a Dog)))
	(age ((the age of _Man4))))

(new-situation)

; (trace)

;;; Check <> constraint IS tested for NON fluents
(not (_Man1 &? _Man2))

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

;;; Let's try it again, and this time make sure that unification doesn't
;;; trigger classification in the global situation. In fact, we're safe,
;;; as unification of two objects in ALL situations only results in classification
;;; being retried in the CURRENT situation, which necessarily won't be global.

(reset-kb)

(_Man1 has 
	(instance-of (Man))
	(age ((the age of _Man3) (must-be-a Number))))

(_Man2 has 
	(instance-of (Man))
	(age ((the age of _Man4))))

(every OldMan has-definition
  (instance-of (Man))
  (age (*VeryOld)))

(every Twin has-definition
  (instance-of (Person))
  (age ((the age of (the brother of Self)))))

(new-situation)

(_Man1 == _Man2)

(global-situation)

(a Man)

;;; ======================================================================

(reset-kb)(untrace)(comment)

(NaCl has (superclasses (Chemical)))
(*NaCl has (instance-of (NaCl)))

(Biology-Situation has
	(superclasses (Situation )))
(in-every-situation Biology-Situation
	(every NaCl has
		(text ("Salt"))))

(in-situation (a Biology-Situation))
((the text of *NaCl) = "Salt")

(*Biology-Situation == (a Biology-Situation))
(in-situation *Biology-Situation)
((the text of *NaCl) = "Salt")

(*Biology-Situation2 has
	(instance-of (Biology-Situation)))
(in-situation *Biology-Situation2)
((the text of *NaCl) = "Salt")  ; was failing in 2.0.19 and earlier

;;; ---------- CONCURRENT ACTIONS ----------

(reset-kb)

(destination has (fluent-status (*Non-Fluent)))
(location has (fluent-status (*Inertial-Fluent)))

(every Move has
  (object ((a Thing)))
  (destination ((a Thing)))
  (del-list ((:triple (the object of Self) location (the location of (the object of Self)))))
  (add-list ((:triple (the object of Self) location (the destination of Self)))))

(new-situation)

(*Cup1 has
  (instance-of (Cup))
  (location (*Table1)))

(*Cup2 has
  (instance-of (Cup))
  (location (*Table1)))

(*Cup3 has
  (instance-of (Cup))
  (location (*Table1)))

;(forall (:set *Cup1 *Cup2 *Cup3)
;  (km-format t "~a has location ~a~%" It (the location of It)))

((the location of *Cup1) = *Table1)
((the location of *Cup2) = *Table1)
((the location of *Cup3) = *Table1)

(do-concurrently-and-next
  (:set (a Move with
          (object (*Cup1))
          (destination (*Table2)))
        (a Move with
          (object (*Cup3))
          (destination (*Table2)))))

;(forall (:set *Cup1 *Cup2 *Cup3)
;  (km-format t "~a now has location ~a~%" It (the location of It)))

((the location of *Cup1) = *Table2)
((the location of *Cup2) = *Table1)
((the location of *Cup3) = *Table2)






;;; ignore  MoveIt.km

(print "actions.km")

;;; ======================================================================
;;;  Must make sure classification is disabled during action processing:
;;; ======================================================================

(reset-kb)

(setq *LINEAR-PATHS* T)

(every Car has-definition
  (instance-of (Vehicle))
  (parts ((a Engine))))

(parts has (fluent-status (*Inertial-Fluent)))

(every Remove has
  (from ())
  (thing ())
  (del-list ((forall (the thing of Self)
		(:triple (Self from) parts It)))))

(new-situation)

(*MyVehicle has
  (instance-of (Vehicle))
  (parts (*Wheel *FurryDice *Elephant)))

(do-and-next (a Remove with (from (*MyVehicle)) (thing (*Wheel *FurryDice))))

;;; Constraint error in 1.4.5.8 and earlier
(print (the parts of *MyVehicle))

(setq *LINEAR-PATHS* NIL)
;;; ignore  aeronet.km

(print "alisa.km")

;;; Virus example from one of Bruce's students. Check that no infinite looping in
;;; the final test.

(reset-kb)

;(default-fluent-status *Inertial-Fluent)  - assumed already in KM

(Thing has
	(subclasses (TangibleThing IntangibleThing Event)))
(TangibleThing has
	(subclasses (Object Substance)))
(Place has
	(superclasses (IntangibleThing)))
(String has 
	(subclasses (PlacePreposition Boolean)))
(*inside has (instance-of (PlacePreposition)))
(*outside has (instance-of (PlacePreposition)))
(*on has (instance-of (PlacePreposition)))
(*above has (instance-of (PlacePreposition)))
(*within has (instance-of (PlacePreposition)))
(*surrounds has (instance-of (PlacePreposition)))
(*connected-to has (instance-of (PlacePreposition)))
(*yes has (instance-of (Boolean)))
(*no has (instance-of (Boolean)))
(every Place has
	(name ((must-be-a String)))
	(place-relation ((must-be-a PlacePreposition)))
	(reference-object ((must-be-a TangibleThing)))
	)

(every TangibleThing has
	(location ((a Place)))
	(externalsurface ((must-be-a Place with
				(place-relation ((*surrounds)))
				(reference-object ((Self)))
			))  )
	)

(every Event has
	(agent ((a TangibleThing)))
	(patient ((a TangibleThing)))	; duration??
	(theme ((a Thing)))
	)
(Barrier has
	(superclasses (Object)))

(every Barrier has
	(space1 ((a Place)))
	(space2 ((a Place)))  	; portal?? prevents??
	)

(Container has
	(superclasses (Barrier)))

(every Container has
	(space1 ((must-be-a Place with 
		(place-relation (*inside))
		(reference-object (Self))
		)) )
	(space2 ((must-be-a Place with 
		(place-relation ((*outside))) 
		(reference-object ((Self))) 
		)) )
	(contents ( (must-be-a TangibleThing with
			(location ((the space1 of Self)) )
			)))
	(capacity ((a Volume)))
	(sealed ((must-be-a Boolean)))
	)

(contents has
	(instance-of (Slot))
	(domain (Container))
	(range (TangibleThing))
	(cardinality(1-to-N))
	(inverse (contents-of))
	)

(contents-of has
	(instance-of (Slot))
	(domain (TangibleThing))
	(range (Container))
	(cardinality (N-to-1))
	(inverse (contents))
	)
(ProteinCoat has (superclasses (TangibleThing)))
(OuterProteinCoat has (superclasses (TangibleThing)))
(every ProteinCoat has
	(externalsurface ((a OuterProteinCoat))) )
(DNA has (superclasses (Substance)))
(Virus has (superclasses (Container)))
(every Virus has
	(contents ((a DNA)))
	(externalsurface ((a ProteinCoat)))
	)
(Lysosome has (superclasses (Container)))
(Cytoplasm has (superclasses (Container)))
(CellWall has (superclasses (Barrier)))

(every Cytoplasm has
	(contents ((a Lysosome)))
	)
(Cell has (superclasses (Container)))
(every Cell has
	(contents ((a Cytoplasm)))
	(externalsurface ((a CellWall)))
	)
(Move has (superclasses (Event)))
(every Move has
	(source ((the location of (the patient of (Self)))))
	(destination ((a Place)))
	(add-list ((:triple (the patient of (Self)) location (the
		destination of (Self)))))
	(del-list ((:triple (the patient of (Self)) location (the
		source of (Self)))))
	)
(Contain has (superclasses (Event)))
(every Contain has
	(theme ((a Container)))
	(patient ((a Thing)))
	(add-list ((:triple (the theme of (Self)) contents (the patient of
		(Self)) )))
	)	
(Enter has (superclasses (Move)))
(every Enter has
	(theme ((a Container)))
	(destination ((the space1 of (the theme of (Self)))))
	(subevents (
		(a Contain with
			(theme ((the theme of (Self))))
			(patient ((the patient of (Self)))) )
		) )
	)
(NotContain has (superclasses (Event)))
(every NotContain has
	(theme ((a Container)))
	(patient ((a Thing)))
	(del-list ((:triple (the theme of (Self)) contents (the patient of
		(Self)) )))
	)	
(Leave has (superclasses (Move)))
(every Leave has
	(theme ((a Container)))
	(source ((the space1 of (the theme of (Self)))))
	(subevents (
		(a NotContain with
			(theme ((the theme of (Self))))
			(patient ((the patient of (Self)))) )
		) )
	)
(Attach has (superclasses (Move)))

(every Attach has
	(theme ((a TangibleThing)))
	(destination ((must-be-a Place with
			(place-relation ((*connected-to)))
			(reference-object ((the theme of (Self))))
			)))
	)

(Cavity has (superclasses (Container)))
(every Cavity has
	(carved-from ((a TangibleThing)))
	(location ((a Place with
			(place-relation ((*within))) 
			(reference-object ((the carved-from of (Self)))))))
	)
(Sealing has (superclasses (Event)))
(every Sealing has
	(patient ((a Container)))
	(add-list ((:triple (the patient of (Self)) sealed (*yes))))
	(del-list ((:triple (the patient of (Self)) sealed (*no))))
	)
(VirusVesicle has (superclasses (Container)))
(every VirusVesicle has-definition
	(instance-of (Container))
	(sealed (*yes))
	(contents ((a Virus)) )
	)
(Swallow has (superclasses (Move)))
(every Swallow has
	(byproduct ((a Cavity with
			(carved-from ((the externalsurface of (the agent 
				of (Self))))))))
	(subevents (
	 	(a Enter with
			(theme ((the byproduct of (Self)))) 
			(patient ((the patient of (Self)))) )
		(a Sealing with
			(patient ((the byproduct of (Self)))) )
		) )
)		
(Endocytosis has (superclasses (Swallow)))
(every Endocytosis has
	(agent ((a Cell)))
	(patient ((a Thing)))
)
(ViralEndocytosis has (superclasses (Endocytosis)))
(every ViralEndocytosis has
	(agent ((a Cell)))
	(patient ((a Virus)))
)
(Remove has (superclasses (Move)))
(Uncover has (superclasses (Remove)))
(every Uncover has
	(theme ((a TangibleThing)))
	(patient ((the externalsurface of (the theme of (Self)))))
	(source ((a Place with
		(place-relation (*surrounds))
		(reference-object (the theme of (Self)))
		)))
	)
(LysosomalViralUncoating has (superclasses (Uncover)))
(every LysosomalViralUncoating has
	(theme ((a ProteinCoat)))
)
(CytoplasmalViralUncoating has (superclasses (Uncover)))
(every CytoplasmalViralUncoating has
	(theme ((a Virus)))
)
(*mycellwall has
	(instance-of (CellWall)))
(*mycytoplasm has
	(instance-of (Cytoplasm)))
(*mycell has
	(instance-of (Cell))
	(contents (*mycytoplasm))
	(externalsurface (*mycellwall))
	)
(*mylysosome has
	(instance-of (Lysosome))
	(location ((the space1 of (*mycell))))
)
(*spdna has
	(instance-of (DNA))
	)
(*spvirus has 
	(instance-of (Virus))
	(contents (*spdna))
	)
(*spvattach has
	(instance-of (Attach))
	(patient (*spvirus))
	(theme ((the externalsurface of (*mycell)))) )
(*spve has
	(instance-of (ViralEndocytosis))
	(agent (*mycell))
	(patient (*spvirus))
)
(*spvmove has
	(instance-of (Move))
	(patient (*spvirus))
	(destination ((the space2 of (*mylysosome))))
	)
(*spfuse has
	(instance-of (Swallow))
	(agent (*mylysosome))
	(patient (*spvirus))
	)
(*spv-lvu has
	(instance-of (LysosomalViralUncoating))
	(theme ((the externalsurface of (*spvirus))))
	)
(*spv-expel has
	(instance-of (Leave))
	(theme (*mylososome))
	)
(*spv-cvu has
	(instance-of (CytoplasmalViralUncoating))
	(theme (*spvirus))
)

(the location of *spdna)
(the contents of *spvirus)

;;; The ultimate test. Created infinite loop in beta35
((the location of *spdna) is
'(a Place with
  (instance-of (Place))
  (location-of (*spdna))
  (place-relation (*inside))
  (reference-object (*spvirus))
  (space1-of (*spvirus))))



;;; ignore  all-instances.km

(print "anand.km")

;;;; relevant KB files:
;;; change.km

(reset-kb)

(fail-noisily)

(Action has (superclasses (Event)))
(Change has (superclasses (Action)))

(agent has
   (instance-of (Slot))
   (subslots-of (actor))
   (domain (Change))
   (range (Thing))
   (cardinality (N-to-N))
   (inverse (agent-of)))

(patient has
   (instance-of (Slot))
   (subslots-of (actor))
   (domain (Change))
   (range (Thing))
   (cardinality (N-to-N))
   (inverse (patient-of)))

(instrument has
   (instance-of (Slot))
   (subslots-of (actor))
   (domain (Change))
   (range (Physical-object))
   (cardinality (N-to-N))
   (inverse (instrument-of)))

(affect has
   (instance-of (Slot))
   (domain (Change))
   (range (Affect))
   (cardinality (N-to-N))
   (inverse (affectOf))
   (subslots (majorAffects minorAffects)))

(force has
   (instance-of (Slot))
   (subslots-of (actor))
   (domain (Change))
   (range (Force))
   (cardinality (N-to-N))
   (inverse (force-of)))

(rate has
   (instance-of (Slot))
   (domain (Change))
   (range (Rate))
   (cardinality (N-to-1))
   (inverse (rate-of)))


(Change has (superclasses (Thing)))

(every Change has
   (patient ((a Thing)))
   (agent ((a PhysicalThing with
	      (capable-of (Self))
	      (agent-of ((a Exert-force with
			    (creates ((the force of Self)))
			    (patient ((the patient of Self)))))))))
   (force ((a Force with
	      (when ((a TimePeriod with 
			(overlaps ((the when of Self))))))
	      (created-by ((the agent of Self))))))
   (instrument ((a PhysicalThing with
		   (controlled-by ((the agent of Self))))))
   (rate ((a RateQuantity)))
   (subevents ((a Change with
		  (rate ((a RateQuantity with
			    (influences ((the rate of Self)))))))))
   (del-list ((forall (the affects of Self)
		      (:triple 
		       (the affectedThing of It)
		       (the affectedSlot of It)
		       (the oldValue of It)))))
   (add-list ((forall (the affects of Self)
		      (:triple 
		       (the affectedThing of It) 
		       (the affectedSlot of It)
		       (the newValue of It))))))

#|
; START TEMPORARY
(affectedThing has
  (instance-of (Slot))
  (situation-specific (t)))

(affectedSlot has
  (instance-of (Slot))
  (situation-specific (t)))

(newValue has
  (instance-of (Slot))
  (situation-specific (t)))
; END TEMPORARY
|#

;;; The following serves to reify an "Affect".  This should insulate
;;; components from future changes (if any) to the representation of
;;; add-lists and del-lists

(Affect has (superclasses (Thing)))
(every Affect has 
   (affectedThing ((a Thing)))
   (affectedSlot ((a Slot)))
   (oldValue ((a Thing)))
   (newValue ((a Thing))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; changepossession.km

;;(load-kb "change.km")
;;(load-kb "person.km")
;;(load-kb "possessedthing.km")

(ChangePossession has (superclasses (Change)))

(oldKeeper has
	(instance-of (Slot))
	(domain (ChangePossession))
	(range  (Person))
	(cardinality (N-to-1))
)

(newKeeper has
	(instance-of (Slot))
	(domain (ChangePossession))
	(range (Person))
	(cardinality (N-to-1))
)

(every ChangePossession has
	(patient ((a PossessedThing)))
	(oldKeeper ((a Person)))
	(newKeeper ((a Person)))
	(affects ((a Affect with
;			(affectedThing ((Self patient)))
			(affectedThing ((the patient of Self)))
			(affectedSlot (possessor))
			(oldValue  ((the oldKeeper of Self)))
			(newValue  ((the newKeeper of Self)))
		  )
		 )
	)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; possessedThing.km
;(load-kb "physicalthing.km")
(PhysicalThing has (superclasses (Thing)))

;(load-kb "person.km")

(PossessedThing has (superclasses (PhysicalThing)))
(Person has (superclasses (PhysicalThing)))

(possessor has
	(instance-of (Slot))
	(domain (PossessedThing))
	(range (Person))
	(cardinality (N-to-1))
)


(every PossessedThing has                ;;;;;<<<<<< the offending bit.
	(possessor ((a Person)))         ;;;;;<<<<<< remove this, and no bug
;	(possessor ((some Person)))      ;;;;; NEW!!! no longer necessary with supersituations not inheriting
)                                        


;;; Test script...

(possessor has (instance-of (Slot)) (situation-specific (t)))

(*anand has (instance-of (Person)))
(*bruce has (instance-of (Person)))
(*bicycle has (instance-of (PossessedThing)))
(new-situation)
(*bicycle has (possessor (*anand)))
(a ChangePossession with (patient (*bicycle))
	     (oldKeeper (*anand))
	     (newKeeper (*bruce))
)
(the del-list of (thelast ChangePossession))
(the add-list of (thelast ChangePossession))
(do-and-next (thelast ChangePossession))
(the possessor of *bicycle)
((the possessor of *bicycle) = *bruce)
(print "args.km")

;;; File: args.km
;;; Author: Peter Clark
;;; Purpose: Testing of multi-argument slot values

#|

	SIT1  -----------next----> SIT2
	      <------previous-----

	    ^ \		      ^ /
     cauzed-by cauzes    results-in  result-of
	     \  v          / v
		   ACTION 
|#

(reset-kb)
	
(next has 
  (instance-of (Slot))
  (inverse (previous))
  (inverse2 (cauzes)))

(cauzes has
  (instance-of (Slot))
  (inverse (cauzed-by))
  (inverse2 (next)))

(cauzed-by has
  (instance-of (Slot))
  (inverse (cauzes))
  (inverse2 (results-in)))

(results-in has
  (instance-of (Slot))
  (inverse (result-of))
  (inverse2 (cauzed-by)))

(result-of has
  (instance-of (Slot))
  (inverse (results-in))
  (inverse2 (previous)))

(previous has 
  (instance-of (Slot))
  (inverse (next))
  (inverse2 (result-of)))

(Sit1 has (next ((:args Sit2 Action1))))

(Action2 has (cauzes ((:args Sit3 Sit2))))

(Sit3 has (results-in ((:args Action3 Sit4))))

#|
RESULT:
(Sit1 has 
  (results-in ((:args Action1 Sit2)))
  (next ((:args Sit2 Action1))))

(Sit2 has 
  (next ((:args Sit3 Action2)))
  (results-in ((:args Action2 Sit3)))
  (cauzed-by ((:args Action1 Sit1)))
  (previous ((:args Sit1 Action1))))

(Sit3 has 
  (next ((:args Sit4 Action3)))
  (previous ((:args Sit2 Action2)))
  (cauzed-by ((:args Action2 Sit2)))
  (results-in ((:args Action3 Sit4))))

(Sit4 has 
  (cauzed-by ((:args Action3 Sit3)))
  (previous ((:args Sit3 Action3))))

(Action1 has 
  (cauzes ((:args Sit2 Sit1)))
  (result-of ((:args Sit1 Sit2))))

(Action2 has 
  (result-of ((:args Sit2 Sit3)))
  (cauzes ((:args Sit3 Sit2))))

(Action3 has 
  (cauzes ((:args Sit4 Sit3)))
  (result-of ((:args Sit3 Sit4))))
|#

((the results-in of Sit1) = (:args Action1 Sit2))
((the next of Sit1) = (:args Sit2 Action1))

((the next of Sit2) = (:args Sit3 Action2))
((the results-in of Sit2) = (:args Action2 Sit3))
((the cauzed-by of Sit2) = (:args Action1 Sit1))
((the previous of Sit2) = (:args Sit1 Action1))

((the next of Sit3) = (:args Sit4 Action3))
((the previous of Sit3) = (:args Sit2 Action2))
((the cauzed-by of Sit3) = (:args Action2 Sit2))
((the results-in of Sit3) = (:args Action3 Sit4))

((the cauzed-by of Sit4) = (:args Action3 Sit3))
((the previous of Sit4) = (:args Sit3 Action3))

((the cauzes of Action1) = (:args Sit2 Sit1))
((the result-of of Action1) = (:args Sit1 Sit2))

((the result-of of Action2) = (:args Sit2 Sit3))
((the cauzes of Action2) = (:args Sit3 Sit2))

((the cauzes of Action3) = (:args Sit4 Sit3))
((the result-of of Action3) = (:args Sit3 Sit4))

;;; ======================================================================
;;;		LIMITED TEST of inverse3
;;; ======================================================================
	
(reset-kb)

(next has 
  (instance-of (Slot))
  (inverse (previous))
  (inverse2 (cauzes)) 
(inverse3 (strength)))

(Sit1 has (next ((:args Sit2 Action1 lots))))

#|
(Sit1 has 
  (next ((:args Sit2 Action1 lots))))

(Sit2 has 
  (strength-of ((:args lots Action1 Sit1)))
  (cauzes-of ((:args Action1 Sit1 lots)))
  (previous ((:args Sit1 Action1 lots))))

(Action1 has 
  (cauzes ((:args Sit2 Sit1 lots))))
|#

((the next of Sit1) = (:args Sit2 Action1 lots))

((the strength-of of Sit2) = (:args lots Action1 Sit1))
((the cauzes-of of Sit2) = (:args Action1 Sit1 lots))
((the previous of Sit2) = (:args Sit1 Action1 lots))

((the cauzes of Action1) = (:args Sit2 Sit1 lots))

;;; ======================================================================
;;;		different form
;;; ======================================================================

((the1 of (:args 1 2 3)) = 1)
((the2 of (:args 1 2 3)) = 2)
((the3 of (:args 1 2 3)) = 3)

;;; ======================================================================

(every 727-Airplane has
  (number-of-parts-of-type (
     (:args Engine 2 test1)			
     (:args Wing 2 test2)
     (:args Seat 134 test3))))

;;; How many wings?
((forall (the number-of-parts-of-type of (a 727-Airplane))
  where  ((the1 of It) = Wing)
         (the2 of It)) = 2)

;;; How many seats?
((forall (the number-of-parts-of-type of (a 727-Airplane))
  where  ((the1 of It) = Seat)
         (the2 of It)) = 134)

(*My727 has
  (instance-of (727-Airplane)))

((the1 number-of-parts-of-type of *My727) = 
 (the1 of (the number-of-parts-of-type of *My727)))

((the2 number-of-parts-of-type of *My727) = 
 (the2 of (the number-of-parts-of-type of *My727)))

((the3 number-of-parts-of-type of *My727) = 
 (the3 of (the number-of-parts-of-type of *My727)))


;;; ------------------------------
;;;	 inverse12
;;; ------------------------------


(reset-kb)

(is-between has
  (instance-of (Slot))
  (domain (Spatial-Entity))
  (range (Spatial-Entity))
  (range2 (Spatial-Entity))
  (inverse (borders))
  (inverse12 (is-between)))

(Austin has
  (instance-of (Spatial-Entity))
  (is-between ((:args SanAntonio Dallas))))

((the is-between of Austin) includes (:args SanAntonio Dallas))
((the is-between of Austin) includes (:args Dallas SanAntonio))

((the1 borders of Dallas) = Austin)
((the1 borders of SanAntonio) = Austin)





(print "bioex.km")

;;; TEST-SUITE ENTRY FOR WORKING NOTE 18
;;; http://www.cs.utexas.edu/users/clarkp/working_notes

;;; File: bioex-classes.km
;;; Author: Peter Clark

;;; This file requires KM 1.4.0-beta33 or later 

(reset-kb)

;;; Declare some inverses...
(before has (instance-of (Slot)) (inverse (after)))
(cotemporal-with has (instance-of (Slot)) (inverse (cotemporal-with)))
(subevents has (instance-of (Slot)) (inverse (superevents)))

;;; [1] This ugly formatting simply prints out the before, cotemporal-with, and 
;;; after properties for each leaf subevent of the main event.
(every Event has
  (before ((the before of (the superevents of Self))))
  (cotemporal-with ((the cotemporal-with of (the superevents of Self))))
  (all-subevents ((the subevents of Self) 
                  (the all-subevents of (the subevents of Self))))
  (leaf-subevents ((allof (the all-subevents of Self) 
                    where (not (the subevents of It)))))
  (subevents ((the subevents of (the component-events of Self))))
  (description-of-leaf-subevents (
      (make-sentence
             (forall (the leaf-subevents of Self)                       ; [1]
                (:seq It "."
                      (if   (has-value (the before of It)) 
                       then (:seq It "is before" (the before of It) "."))
                      (if   (has-value (the cotemporal-with of It)) 
                       then (:seq It "is cotemporal with" (the cotemporal-with of It) "."))
                      (if   (has-value (the after of It)) 
                       then (:seq It "is after" (the after of It) "."))
                      (format nil "~%")))))))

;;; Being lazy over the taxonomy here...
(Virus-Visiting has (superclasses (Event)))
(Invading has (superclasses (Event)))
(Delivering has (superclasses (Event)))
(Fusing has (superclasses (Breaking)))
(Coalescing has (superclasses (Event)))
(Piercing has (superclasses (Event)))
(Arriving has (superclasses (Event)))
(Breaking has (superclasses (Event)))
(Entering has (superclasses (Event)))
(Moving has (superclasses (Event)))
(Attaching has (superclasses (Event)))
(Creating has (superclasses (Event)))
(Inserting has (superclasses (Event)))

;;; ----------------------------------------
;;;       VIRUS VISITING (composition)
;;; ----------------------------------------

;;; [1] is a slightly cumbersome way of saying the two Arrivings (subevents of
;;;     the Invading and Delivering respectively) are coreferential.
;;; [2] We wish to say that the generic Breaking in the Invading is (here) a special
;;;     way of breaking into something, namely a Fusing. Here we rely on KM's
;;;     set unification mechanism to appropriately unify the Fusing (here) with the
;;;     Breaking (inherited from Invading).
(every Virus-Visiting has
  (agent ((a Virus with
             (container-wall ((a Viral-Envelope)))
             (contents ((a Capsid)))
             (attachments ((a Transmembrane))))))
  (patient ((a Cell with
              (container-wall ((a Cell-Membrane)))
              (contents ((a Cytoplasm))))))
  (component-events (
    (a Invading with
      (agent ((the Capsid contents of (the Virus agent of Self))))
      (patient ((the Cell patient of Self)))
      (barrier ((the container-wall of (the Cell patient of Self))))
      (subevents (
        (the Arriving subevents of (the Delivering component-events of Self))  ; [1]
        (a Fusing)                                                             ; [2]
        (a Entering with
          (cotemporal-with ((the Moving subevents of 
                              (the Delivering component-events of Self))))))))
    (a Delivering with
      (agent ((the Virus agent of Self)))
      (package ((the Capsid contents of (the Virus agent of Self))))
      (recipient ((the Cell patient of Self)))
      (subevents (
        (the Arriving subevents of (the Invading component-events of Self))    ; [1]
        (a Moving with
          (cotemporal-with ((the Entering subevents of 
                              (the Invading component-events of Self)))))))))))

;;; ----------------------------------------
;;;       INVADING
;;; ----------------------------------------

(every Invading has
  (agent ((a Thing)))
  (patient ((a Thing)))
  (barrier ((a Thing with
              (surrounds ((the patient of Self))))))
  (subevents (
    (a Arriving with
      (agent ((the agent of Self)))
      (location ((the patient of Self)))
      (before ((the Breaking subevents of Self))))
    (a Breaking with
      (agent ((the agent of Self)))
      (patient ((the barrier of Self)))
      (before ((the Entering subevents of Self))))
    (a Entering with
      (agent ((the agent of Self)))
      (patient ((the patient of Self)))))))

;;; ----------------------------------------
;;;       DELIVERING
;;; ----------------------------------------

(every Delivering has
  (agent ((a Thing)))
  (package ((a Thing)))
  (recipient ((a Thing)))
  (subevents (
    (a Arriving with
      (agent ((the agent of Self)))
      (destination ((the recipient of Self)))
      (before ((the Moving subevents of Self))))
    (a Moving with
      (agent ((the agent of Self)))
      (patient ((the package of Self)))
      (destination ((the recipient of Self)))))))

;;; ----------------------------------------
;;;       FUSING
;;; ----------------------------------------

(every Fusing has
  (agent ((a Thing)))
  (patient ((a Thing)))         ; the barrier
  (subevents (
    (a Attaching with
      (agent ((the agent of Self)))
      (patient ((the patient of Self)))
      (before ((the Piercing subevents of Self))))
    (a Piercing with
      (agent ((the agent of Self)))
      (patient ((the container-wall of (the patient of Self))))
      (before ((the Coalescing subevents of Self))))
    (a Coalescing with
      (agent ((the agent of Self)))
      (patients ((the agent of Self) (the patient of Self)))))))

;;; ----------------------------------------
;;;       PIERCING
;;; ----------------------------------------

(every Piercing has
  (agent ((a Thing)))
  (patient ((a Thing)))
  (instrument ((a Thing)))                      ; a pointy thing
  (subevents (
    (a Creating with
      (agent ((the agent of Self)))
      (created ((a Portal with
                  (part-of ((the patient of Self))))))
      (instrument ((the instrument of Self)))
      (cotemporal-with ((the Inserting subevents of Self))))
    (a Inserting with
      (agent ((the agent of Self)))
      (instrument ((the instrument of Self)))
      (patient ((the patient of Self)))))))

;;; --- end ---
\end{verbatim}

;;; ======================================================================
;;;			TEST - Rather crude use of text string testing!
;;; ======================================================================

;; In fact, all the below summaries are incomplete due to inference incompleteness with inverses. 
;;; Really, we should explore all branches, to ensure inverses are installed and THEN ask the query. 
;;; Let's do that.

#|
((the description-of-leaf-subevents of (a Virus-Visiting)) =
"The arriving. The arriving is before the moving the fusing.
The entering. The entering is cotemporal with the moving.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
.")
|#

(_X == (a Virus-Visiting))

(forall (the leaf-subevents of _X)		; precompute all inverses
 (:set (the before of It) (the cotemporal of It) (the after of It)))

#|
((the description-of-leaf-subevents of _X) =
"The arriving. The arriving is before the moving the fusing.
The entering. The entering is cotemporal with the moving. The entering is after the fusing the attaching the coalescing the piercing the creating the inserting.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing the creating the inserting.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
.")
|#
;;; ======================================================================

;;; File: bioex-prototypes.km
;;; Author: Peter Clark

;;; This file requires KM 1.4.0-beta33 or later 

(reset-kb)

;;; Declare some inverses...
(before has (instance-of (Slot)) (inverse (after)))
(cotemporal-with has (instance-of (Slot)) (inverse (cotemporal-with)))
(subevents has (instance-of (Slot)) (inverse (superevents)))

;;; [1] This ugly formatting simply prints out the before, cotemporal-with, and 
;;; after properties for each leaf subevent of the main event.
(every Event has
  (before ((the before of (the superevents of Self))))
  (cotemporal-with ((the cotemporal-with of (the superevents of Self))))
  (all-subevents ((the subevents of Self) 
                  (the all-subevents of (the subevents of Self))))
  (leaf-subevents ((allof (the all-subevents of Self) 
                    where (not (the subevents of It)))))
  (subevents ((the subevents of (the component-events of Self))))
  (description-of-leaf-subevents (
      (make-sentence
             (forall (the leaf-subevents of Self)                       ; [1]
                (:seq It "."
                      (if   (has-value (the before of It)) 
                       then (:seq It "is before" (the before of It) "."))
                      (if   (has-value (the cotemporal-with of It)) 
                       then (:seq It "is cotemporal with" (the cotemporal-with of It) "."))
                      (if   (has-value (the after of It)) 
                       then (:seq It "is after" (the after of It) "."))
                      (format nil "~%")))))))

;;; Being lazy over the taxonomy here...
(Virus-Visiting has (superclasses (Event)))
(Invading has (superclasses (Event)))
(Delivering has (superclasses (Event)))
(Fusing has (superclasses (Breaking)))
(Coalescing has (superclasses (Event)))
(Piercing has (superclasses (Event)))
(Arriving has (superclasses (Event)))
(Breaking has (superclasses (Event)))
(Entering has (superclasses (Event)))
(Moving has (superclasses (Event)))
(Attaching has (superclasses (Event)))
(Creating has (superclasses (Event)))
(Inserting has (superclasses (Event)))

;;; ----------------------------------------
;;;       VIRUS VISITING (composition)
;;; ----------------------------------------

(a-prototype Virus-Visiting)

;;; Introduce the objects into the prototype:
(a Virus with
  (container-wall ((a Viral-Envelope)))
  (contents ((a Capsid)))
  (attachments ((a Transmembrane))))

(a Cell with
  (container-wall ((a Cell-Membrane)))
  (contents ((a Cytoplasm))))

((the Virus-Visiting) has
  (agent ((the Virus)))
  (patient ((the Cell)))
  (component-events (
    (a Invading with
      (agent ((the Capsid)))
      (patient ((the Cell)))
      (barrier ((the Cell-Membrane))))
    (a Delivering with
      (agent ((the Virus)))
      (package ((the Capsid)))
      (recipient ((the Cell)))))))

((the Invading) has (subevents ((a Arriving) (a Breaking) (a Entering))))
((the Delivering) has (subevents ((a Arriving) (a Moving))))

;;; The Arrivings are coreferential
((the Arriving subevents of (the Invading)) == 
                (the Arriving subevents of (the Delivering)))

((the Entering) has
   (cotemporal-with ((the Moving))))

;;; In this case, the breaking occurs via fusing
((the Breaking) == (a Fusing))

(end-prototype)

;;; ----------------------------------------
;;;       INVADING
;;; ----------------------------------------

(a-prototype Invading)

((the Invading) has
  (agent ((a Thing)))
  (patient ((a Thing)))
  (barrier ((a Thing with
              (surrounds ((the patient of Self))))))
  (subevents (
    (a Arriving with
      (agent ((the agent of Self)))
      (location ((the patient of Self)))
      (before ((the Breaking subevents of Self))))
    (a Breaking with
      (agent ((the agent of Self)))
      (patient ((the barrier of Self)))
      (before ((the Entering subevents of Self))))
    (a Entering with
      (agent ((the agent of Self)))
      (patient ((the patient of Self)))))))

(end-prototype)

;;; ----------------------------------------
;;;       DELIVERING
;;; ----------------------------------------

(a-prototype Delivering)

((the Delivering) has
  (agent ((a Thing)))
  (package ((a Thing)))
  (recipient ((a Thing)))
  (subevents (
    (a Arriving with
      (agent ((the agent of Self)))
      (destination ((the recipient of Self)))
      (before ((the Moving subevents of Self))))
    (a Moving with
      (agent ((the agent of Self)))
      (patient ((the package of Self)))
      (destination ((the recipient of Self)))))))

(end-prototype)

;;; ----------------------------------------
;;;       FUSING
;;; ----------------------------------------

(a-prototype Fusing)

((the Fusing) has
  (agent ((a Thing)))
  (patient ((a Thing)))         ; the barrier
  (subevents (
    (a Attaching with
      (agent ((the agent of Self)))
      (patient ((the patient of Self)))
      (before ((the Piercing subevents of Self))))
    (a Piercing with
      (agent ((the agent of Self)))
      (patient ((the container-wall of (the patient of Self))))
      (before ((the Coalescing subevents of Self))))
    (a Coalescing with
      (agent ((the agent of Self)))
      (patients ((the agent of Self) (the patient of Self)))))))

(end-prototype)

;;; ----------------------------------------
;;;       PIERCING
;;; ----------------------------------------

(a-prototype Piercing)

((the Piercing) has
  (agent ((a Thing)))
  (patient ((a Thing)))
  (instrument ((a Thing)))                      ; a pointy thing
  (subevents (
    (a Creating with
      (agent ((the agent of Self)))
      (created ((a Portal with
                  (part-of ((the patient of Self))))))
      (instrument ((the instrument of Self)))
      (cotemporal-with ((the Inserting subevents of Self))))
    (a Inserting with
      (agent ((the agent of Self)))
      (instrument ((the instrument of Self)))
      (patient ((the patient of Self)))))))

(end-prototype)

;;; --- end ---

;;; ======================================================================
;;;			TEST - Rather crude use of text string testing!
;;; ======================================================================

;; In fact, all the below summaries are incomplete due to inference incompleteness with inverses. 
;;; Really, we should explore all branches, to ensure inverses are installed and THEN ask the query. 
;;; Let's do that.

#|
((:set 
"The entering. The entering is cotemporal with the moving. The entering is after the fusing.
The arriving. The arriving is before the moving the fusing.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
."
"The entering. The entering is cotemporal with the moving. The entering is after the piercing the fusing.
The arriving. The arriving is before the moving the fusing.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
."
"The arriving. The arriving is before the fusing the moving.
The entering. The entering is cotemporal with the moving. The entering is after the fusing the piercing.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
."
"The arriving. The arriving is before the fusing the moving.
The entering. The entering is cotemporal with the moving. The entering is after the fusing.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
.")

)
includes (the description-of-leaf-subevents of (a Virus-Visiting)))
|#

(_X == (a Virus-Visiting))

(forall (the leaf-subevents of _X)		; precompute all inverses
 (:set (the before of It) (the cotemporal of It) (the after of It)))

#|
((the description-of-leaf-subevents of _X) =
"The arriving. The arriving is before the fusing the moving.
The entering. The entering is cotemporal with the moving. The entering is after the fusing the attaching the coalescing the piercing the creating the inserting.
The moving. The moving is cotemporal with the entering. The moving is after the arriving.
The attaching. The attaching is before the piercing the entering.
The coalescing. The coalescing is before the entering. The coalescing is after the piercing the creating the inserting.
The creating. The creating is before the coalescing the entering. The creating is cotemporal with the inserting.
The inserting. The inserting is before the coalescing the entering. The inserting is cotemporal with the creating. 
.")
|#

(print "bioremediation.km")

;;; File: bioremediation.km
;;; Author: Peter Clark and Bruce Porter
;;; Purpose: Demo of the AAAI'97 paper example -- in fact it's rather trivial!

#|
KM> (forall (the subevents of (the script of (a Bioremediation)))
	(print (make-sentence (the text of It))))
("The person applies the microbes to the oil."
 "The person gets the microbes." 
 "The microbes breaks down the oil."
 "The microbes absorbs the oil."
 "The person gets a certification for handling the oil.")

Note: the steps are unordered! There's no ordering constraints
stated here, we need some way of making explicit what the ordering 
constraints are, and some way of linearizing them into a printable form.

Interesting note:
This was a unification problem in KM1.3, which is now fixed in KM1.4
due to more aggressive constraint testing during lazy unification:

The earlier version of this example had two Get actions (the Microbes, the 
Certification). Unfortunately this causes problems: lazy unification unifies 
them to become

	(a Get with
	  (theme (((a Certification) & (_Bioremediation23 theme)))))

Evaluation of the `theme' expression later fails (if we define 
Information-Objects (eg. Certification) and Agents (eg. Microbes) as disjoint).
KM's lazy unification doesn't evaluate subexpressions to check for unification,
and can't easily do so without hitting major tractibility problems.

To work around this, I renamed Getting a certification as Licencing, which 
doesn't lazily unify with Get (assuming I don't say Licencing isa Get). 

Other alternatives would be to: 
(i) state atomically what is Got, eg.
	(a Get with
	  (theme-type (Microbes))
	  (theme ((_Bioremediation theme))))
  ...
	(a Get with
	  (theme-type (Certification))
	  (theme ((a Certification))))

(ii) flag these slots as "to be evaluated eagerly", eg.
	(a Get with
	  (theme ((eagerly-evaluate (_Bioremediation theme)))))
  ...
	(a Get with
	  (theme-type (Certification))
	  (theme ((eagerly-evaluate ((a Bioremediation))))))

[Problem fixed in KM1.4, with more aggressive lazy unification algorithm
 which checks constraints including partitions]
|#

(reset-kb)

(SETQ *LINEAR-PATHS* T)

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

(every Conversion has
  (raw-materials ((a Substance with
			(amount ((a Amount with
					(q+ ((Self rate Quantity)))))))))
  (theproduct ((a Substance with
		(amount ((a Amount with
				(q- ((Self rate Quantity)))))))))
  (rate ((a Quantity with
		(i+ ((Self theproduct Substance amount Amount)))
		(i- ((Self raw-materials Substance amount Amount)))))))

;;; ======================================================================

(every Treatment has
  (agent ((a Person)))
  (theme ((a Thing)))
  (patient ((a Thing)))
  (script (
    (a Script with
      (subevents (
	(a Get with 
	  (agent ((Self agent)))
	  (theme ((Self theme))))
	(a Apply with
          (agent ((Self agent)))
          (patient ((Self patient)))
          (theme ((Self theme))))))))))

;;; ======================================================================

(every Digestion has
  (eater ((a Agent)))
  (food ((a Substance)))
  (script ((a Script with 
     (subevents (
       (a Break-down with
          (agent ((Self eater)))
          (broken ((Self food))))
       (a Absorb with
          (agent ((Self eater)))
          (absorbed ((Self food))))))))))

;;; ======================================================================

(Bioremediation has (superclasses (Conversion Treatment Digestion Activity)))

(every Bioremediation has
  (raw-materials ((Self patient)))
  (eater ((Self theme)))
  (food ((Self patient)))
  (theme ((a Microbes)))
  (patient ((a Oil)))
  (theproduct ((a Fertilizer))))

(a Partition with
  (members (Certification Microbes)))

;;; ======================================================================
;;;		GENERIC
;;; ======================================================================

(script has 
  (instance-of (Slot))
  (cardinality (N-to-1)))

(theme has 
  (instance-of (Slot))
  (cardinality (N-to-1)))

(Person has (superclasses (Agent)))
(Microbes has (superclasses (Agent)))
(Fertilizer has (superclasses (Substance)))
(Oil has (superclasses (Substance)))

(every Get has
  (text ((:seq (Self agent) "gets" (Self theme)))))

(every Licencing has
  (text ((:seq (Self agent) "gets" (Self theme)))))

(every Apply has
  (text ((:seq (Self agent) "applies" (Self theme) "to" (Self patient)))))

(every Break-down has
  (text ((:seq (Self agent) "breaks down" (Self broken)))))

(every Absorb has
  (text ((:seq (Self agent) "absorbs" (Self absorbed)))))

;;; ======================================================================
;;;		EXTENSION...
;;; ======================================================================
#|
For interest we'll add in some more info... 
For example, applying microbes to oil requires (say) getting certification.

We could put this as a frame in the bioremedation frame, but that's 
too general, rather we want to qualify it.
|#

;;; 1. Generic certified activity

(every Certified-Activity has
  (agent ((a Agent)))
  (patient ((a Substance)))
  (script ((a Script with
    (subevents (
;      (a Licencing with
      (a Get with
        (agent ((Self agent)))
        (theme ((a Certification with
		     (patient ((Self patient)))))))
      (a Apply with
      	(agent ((Self agent)))
        (patient ((Self patient))))))))))

;;; 2. Linking rule:
;;; Activities handling Oil are certified activities.

(Certified-Activity has (superclasses (Activity)))

(every Certified-Activity has-definition
  (instance-of (Activity))
  (patient ((a Oil))))

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

(Certification has (superclasses (Information-Bearing-Object)))

(every Certification has
  (name ((make-phrase (:seq "a certification for handling" (Self patient))))))

;;; ======================================================================
;;;			TEST / DEMO QUERIES
;;; ======================================================================

(forall (the subevents of (the script of (a Bioremediation)))
	(print (make-sentence (the text of It))))

(SETQ *LINEAR-PATHS* NIL)(print "blocks.km")

(reset-kb)

(subevent has (fluent-status (*Non-Fluent)))

(first-subevent has (fluent-status (*Non-Fluent)))

;;; NOTE: current-object is computed, and NOT projected
(object has (fluent-status (*Inertial-Fluent)))
(current-object has (fluent-status (*Fluent)))

(next-event has (fluent-status (*Fluent)))

(parts has (fluent-status (*Inertial-Fluent)))
(on has 
   (fluent-status (*Inertial-Fluent))
   (inverse (under)))
(clear? has (fluent-status (*Inertial-Fluent)))

#|
======================================================================
	A SIMPLE PLAN FOR UNSTACKING A TOWER
======================================================================

			+----------------+
			V		 |
  Power on  ---- Unstack top ------> More stacked ---NO---> Power off
  robot arm   	  block		     blocks left?	    robot arm

======================================================================
|#

(every Unstack-A-Tower has
   (object ((a Tower)))
   (instrument ((a Robot-Arm)))
   (first-subevent ((the Power-On subevent of Self)))
   (subevent (
	(a Power-On with 
	    (object ((the instrument of Self)))
	    (next-event ((the Remove subevent of Self))))
	(a Remove with
	  (current-object ((the Block with
			     (parts-of ((the Tower object of Self)))
			     (clear? (Yes)))))
          (instrument ((the instrument of Self)))
          (next-event (
		(if   ((the number of (the parts of (the Tower object of Self))) = 1)
		 then (the Power-Off subevent of Self)
		 else (the Remove subevent of Self)))))
	(a Power-Off with
	    (object ((the instrument of Self)))))))

;;; Domain-specific knowledge...
(every Remove has
   (current-object ((a Block)))
   (pcs-list ((:triple (the current-object of Self) clear? Yes)))
   (del-list ((:triple (the current-object of Self) on (the on of (the current-object of Self)))
	     (:triple (the current-object of Self) parts-of (the parts-of of 
				(the current-object of Self)))
	     (:triple (the on of (the current-object of Self)) clear?  No)))
   (add-list ((:triple (the on of (the current-object of Self)) clear? Yes)
	      (:triple (the current-object of Self) on *Floor))))


(new-situation)

#| Define the initial situation:
    *BlockA
    *BlockB
    *BlockC
    *BlockD
  -------------- |#
(*MyTower has
   (instance-of (Tower))
   (parts (*BlockA *BlockB *BlockC *BlockD)))

(*BlockA has
   (instance-of (Block))
   (on (*BlockB))
   (clear? (Yes)))

(*BlockB has
   (instance-of (Block))
   (on (*BlockC))
   (clear? (No)))

(*BlockC has
   (instance-of (Block))
   (on (*BlockD))
   (clear? (No)))

(*BlockD has
   (instance-of (Block))
   (on (*Floor))
   (clear? (No)))

(in-situation *Global (*MyUnstack == (a Unstack-A-Tower with (object (*MyTower)))))

(do-plan *MyUnstack)

;;; Check it's unstacked ok
((the parts of *MyTower) = *BlockD)

;;; ---------- test 2 ----------

(new-situation)

#| Define the initial situation:
    _BlockA
    _BlockB
    _BlockC
    _BlockD
  -------------- |#

(_MyTower has
   (instance-of (Tower))
   (parts (_BlockA _BlockB _BlockC _BlockD)))

(_BlockA has
   (instance-of (Block))
   (on (_BlockB))
   (clear? (Yes)))

(_BlockB has
   (instance-of (Block))
   (on (_BlockC))
   (clear? (No)))

(_BlockC has
   (instance-of (Block))
   (on (_BlockD))
   (clear? (No)))

(_BlockD has
   (instance-of (Block))
   (on (_Floor))
   (clear? (No)))

(in-situation *Global (_MyUnstack == (a Unstack-A-Tower with (object (_MyTower)))))

(do-plan _MyUnstack)

;;; Check it's unstacked ok
((the parts of _MyTower) = _BlockD)

(print "bomb.km")

;;; File: bomb.km
;;; Author: Peter Clark
;;; Purpose: Debugging and testing of prototype mechanism
;;; Comment: The prototype definitions in this file are loaded three
;;;	times in a row, for extensive testing!

#|
PROBLEM WITH LAZY UNIFICATION:
If I lazy unify Blackmail1 		and Blackmail2
		  weapon: Device1 	      weapon: Device2

I get Blackmail1
	weapon: (Device1 & Device2)

which still looks like there are two Devices, so a query for (the Device)
is apparently ambiguous!

Solution is to do eager unification, implemented as KM commands &! and &&!

It finally seems to work after some very painful debugging. A good test
is to reload three copies of this file in a row, and check it still
works.
|#	

(reset-kb)

;;; ======================================================================
;;;		FIRST LOAD ITERATION
;;; ======================================================================

;;; ======================================================================
;;; 	ONTOLOGY (part of it)
;;; ======================================================================

(Blackmail has (superclasses (Event)))
(Nuclear-Blackmail has (superclasses (Blackmail)))
(Nuclear-Bomb has (superclasses (Bomb)))
(Bomb has (superclasses (Device)))
(BigTThing has (superclasses (TThing)))

(uses has
  (instance-of (Slot))
  (inverse (used-for)))

;;; ======================================================================
;;;			BLACKMAIL PROTOTYPE
;;; ======================================================================

(a-prototype Blackmail)

((the Blackmail) has
  (blackmailer ((a Person)))
  (blackmailee ((a Person with (posession ((a TThing)))))))

((the Blackmail) has
  (weapon ((a Device))))

((the Blackmail) has
   (threat ((a Destruction with 
		(destroyer ((the blackmailer of (the Blackmail))))))))

((the Destruction) has
  (destroyed ((the TThing posession of (the blackmailee of (the Blackmail))))))

((the Destruction) has
  (uses ((the weapon of (the Blackmail)))))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BOMB PROTOTYPE
;;; ======================================================================

(a-prototype Nuclear-Bomb)

((the Nuclear-Bomb) has
  (used-for ((a Destruction))))

((the Destruction) has
  (destroyer ((a Person)))
  (destroyed ((a BigTThing))))

((the Person) has
  (access-to (*Nuclear-Materials)))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BLACKMAIL - COMPOSITION RULES
;;; ======================================================================

(Nuclear-Blackmail has (superclasses (Blackmail)))

(a-prototype Nuclear-Blackmail)

((the Nuclear-Blackmail) has (weapon ((a Nuclear-Bomb))))

(end-prototype)

(X == (a Nuclear-Blackmail))

((the weapon of X) isa Nuclear-Bomb)
((the threat of X) isa Destruction)

;;; ======================================================================
;;;		SECOND LOAD ITERATION
;;; ======================================================================

;;; ======================================================================
;;; 	ONTOLOGY (part of it)
;;; ======================================================================

(Blackmail has (superclasses (Event)))
(Nuclear-Blackmail has (superclasses (Blackmail)))
(Nuclear-Bomb has (superclasses (Bomb)))
(Bomb has (superclasses (Device)))
(BigTThing has (superclasses (TThing)))

(uses has
  (instance-of (Slot))
  (inverse (used-for)))

;;; ======================================================================
;;;			BLACKMAIL PROTOTYPE
;;; ======================================================================

(a-prototype Blackmail)

((the Blackmail) has
  (blackmailer ((a Person)))
  (blackmailee ((a Person with (posession ((a TThing)))))))

((the Blackmail) has
  (weapon ((a Device))))

((the Blackmail) has
   (threat ((a Destruction with 
		(destroyer ((the blackmailer of (the Blackmail))))))))

((the Destruction) has
  (destroyed ((the TThing posession of (the blackmailee of (the Blackmail))))))

((the Destruction) has
  (uses ((the weapon of (the Blackmail)))))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BOMB PROTOTYPE
;;; ======================================================================

(a-prototype Nuclear-Bomb)

((the Nuclear-Bomb) has
  (used-for ((a Destruction))))

((the Destruction) has
  (destroyer ((a Person)))
  (destroyed ((a BigTThing))))

((the Person) has
  (access-to (*Nuclear-Materials)))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BLACKMAIL - COMPOSITION RULES
;;; ======================================================================

(Nuclear-Blackmail has (superclasses (Blackmail)))

(a-prototype Nuclear-Blackmail)

((the Nuclear-Blackmail) has (weapon ((a Nuclear-Bomb))))

(end-prototype)

(Y == (a Nuclear-Blackmail))

((the weapon of Y) isa Nuclear-Bomb)
((the threat of Y) isa Destruction)

;;; ======================================================================
;;;		THIRD LOAD ITERATION
;;; ======================================================================

;;; ======================================================================
;;; 	ONTOLOGY (part of it)
;;; ======================================================================

(Blackmail has (superclasses (Event)))
(Nuclear-Blackmail has (superclasses (Blackmail)))
(Nuclear-Bomb has (superclasses (Bomb)))
(Bomb has (superclasses (Device)))
(BigTThing has (superclasses (TThing)))

(uses has
  (instance-of (Slot))
  (inverse (used-for)))

;;; ======================================================================
;;;			BLACKMAIL PROTOTYPE
;;; ======================================================================

(a-prototype Blackmail)

((the Blackmail) has
  (blackmailer ((a Person)))
  (blackmailee ((a Person with (posession ((a TThing)))))))

((the Blackmail) has
  (weapon ((a Device))))

((the Blackmail) has
   (threat ((a Destruction with 
		(destroyer ((the blackmailer of (the Blackmail))))))))

((the Destruction) has
  (destroyed ((the TThing posession of (the blackmailee of (the Blackmail))))))

((the Destruction) has
  (uses ((the weapon of (the Blackmail)))))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BOMB PROTOTYPE
;;; ======================================================================

(a-prototype Nuclear-Bomb)

((the Nuclear-Bomb) has
  (used-for ((a Destruction))))

((the Destruction) has
  (destroyer ((a Person)))
  (destroyed ((a BigTThing))))

((the Person) has
  (access-to (*Nuclear-Materials)))

(end-prototype)

;;; ======================================================================
;;;		NUCLEAR-BLACKMAIL - COMPOSITION RULES
;;; ======================================================================

(Nuclear-Blackmail has (superclasses (Blackmail)))

(a-prototype Nuclear-Blackmail)

((the Nuclear-Blackmail) has (weapon ((a Nuclear-Bomb))))

(end-prototype)

(Z == (a Nuclear-Blackmail))

((the weapon of Z) isa Nuclear-Bomb)
((the threat of Z) isa Destruction)


;;; ignore  cache-problem.km


;;; ignore  cache-problem2.km

(print "cache-problem3.km")

;;; COMMENT:
;;; The last query will FAIL if a (reset-done) is not called after looping is detected.

(reset-kb)

(first-subevent has
  (instance-of 	 (Relation))
  (superslots    (subevent))
  (domain 	 (Event))
  (range 	 (Event))
  (fluent-status (*Inertial-Fluent))
  (cardinality 	 (N-to-N))
)

(every Penetrate has
       (first-subevent  ((the Breach subevent of Self)))
       (subevent 	((a Breach with
		     	    (agent  	((the agent of Self)))
		     	    (object 	((the object of Self)))
			    (next-event ((the Go-Through subevent of Self))))
		  	 (a Go-Through with
		     	    (agent ((the agent of Self)))
			    (path  ((the result of 
				         (the Breach subevent of Self))))))))


(_X == (a Penetrate))

(the subevent of _X)

#|
 -> (the subevent ...
  -> (the first-subevent [a subslot of subevent]
   -> (the subevent ...
   <- NIL [looping]
  <- NIL -- and the first-subevent = nil is cached
 -> look in subevent slots and get right answer.
<- right answer

BUT: we are stuck with NIL cached on first-subevent, so a call to (km ...)
from Lisp, or from km-eval, must call (reset-done) to flush the cache.
KM 2.0.12 there was no (reset-done) in km-eval, so the cache wasn't flushed
for calls direct to km-eval. KM 2.0.13 moved (reset-done) call from
(km-eval-print) to (km-eval). 
KM 2.1.13 moved (reset-done) from (km-eval) to (km).
|#

;;; Should succeed, failed in 2.0.12
(the first-subevent of _X)
(print "cache-problem4.km")

;;; ======================================================================
;;; Rather bizarre test
;;; ======================================================================
(reset-kb)
(global-situation)
(every Sports-Car has (color (*red)))
(Sports-Car has (superclasses (Car)))
(new-situation)
(*Foo1 has
   (info ((_R & (a Car)) (the color of _R) (_R & (a Sports-Car)) (if (the color of _R) then *Yes))))

;;; Fails with 2.0.36 and earlier.
;;; first call (the color of _R) fails and answer is cached. 
;;; (_R & (a Sports-Car)) didn't, but now does, an un-done on ALL of _R's slots (not just instance-of, as before)
;;; This means the 2nd (the color of _R) clause does get re-evaluated.
((the info of *Foo1) includes *Yes)




(print "cache.km")

#|
======================================================================
Caching problem (now fixed) here -- this is a subtle case where a change causes
a significant *indirect* effect, but KM only un-done's the cached
flag on the direct effects.

In this case, we compute the `defeats' and `del-list' of an action,
THEN KM assumes a precondition (which would mean computation of `defeats'
would now produce a new answer), then asks for the `del-list' again
which requires using `defeats'. But the old NIL value on `defeats' is
cached, and so KM doesn't re-compute `defeats' and realize there's been a change.
======================================================================
|#

;;; From the Component Lib

(reset-kb)

(Tangible-Entity has (superclasses (Entity)))

(object has
   (instance-of (Relation))
   (superslots ())
   (subslots ())
   (domain (Event))
   (range (Entity))
   (inverse (object-of))
   (fluent-status (*Inertial-Fluent))
   (situation-specific (t))
   (cardinality (N-to-N)))

; note use of inherit-with-overrides.  This ensures that KM returns only
; the most specific value of the defeats slot
(defeats has
         (instance-of (Relation))
         (superslots ())
	 (subslots ())
	 (domain (Action))
	 (range (State))
	 (inverse (defeated-by))
	 (fluent-status (*Inertial-Fluent))
	 (situation-specific (t))
	 (inherit-with-overrides (t))
	 (cardinality (N-to-N)))

(destination has
   (instance-of (Relation))
   (superslots ())
   (subslots ())
   (domain      (Event))
   (range       (Place))
   (inverse (destination-of))
   (fluent-status (*Inertial-Fluent))
   (situation-specific (t))
   (cardinality (N-to-1)))

(instrument has
	    (instance-of (Relation))
	    (superslots ())
	    (subslots ())
	    (domain (Event))
	    (range (Entity))
	    (inverse (instrument-of))
	    (fluent-status (*Inertial-Fluent))
	    (situation-specific (t))
	    (cardinality (N-to-N)))


(location has
	  (instance-of (Relation))
	  (superslots ())
	  (subslots ())
	  (domain (Tangible-Entity Event))
	  (range (Place))
	  (inverse (location-of))
	  (cardinality (N-to-1))
	  (situation-specific (t))
	  (fluent-status (*Inertial-Fluent)))

(Action has
	(superclasses (Event))
	(primary-slot (agent object instrument))
	(secondary-slot (subevent))   
	(cmap-correspondence (
            (:seq object "direct object of the change")
            (:seq agent "doer")
            (:seq instrument "instrument")
	    )))


(every Action has
       (object  ((must-be-a Thing)))  
       (instrument 	((must-be-a Tangible-Entity)))
       (subevent 	((must-be-a Action)))

       ; action should have a default condition which says the agent
       ; is at the location of the object

       ; The following code collects the subevents of the Action into 
       ; a single list, which can then be simulated by KM.
       ; The semantics of the "actions" slot is built into KM.
       (actions ((if (has-value (the subevent-order of Self))
		     then
		     (forall (the subevent-order of Self) where (t)
			     (the actions of It))
		     else
		     Self)))

       ;; an object cannot be the object/instrument of an action 
       ;; if it is inaccessible to the agent
       (pcs-list (
		  (if (not (Self isa Make-Accessible))
		      then
		    (if (has-value (the agent of Self))
			then
		      (forall (the object of Self)
			      ((:triple 
				(It)
				object-of
				(mustnt-be-a Be-Inaccessible with
					     (object (It))
					     (destination (the agent of Self))))))
		      else
		      (forall (the object of Self)
			      ((:triple 
				(It)
				object-of
				(mustnt-be-a Be-Inaccessible with
					     (object (It)))))))
		    else 
		    (the del-list of Self))

		  (if (not (Self isa Make-Accessible))
		      then
		    (if (has-value (the agent of Self))
			then
		      (forall (the instrument of Self)
			      ((:triple
				(It)
				object-of
				(mustnt-be-a Be-Inaccessible with
					     (object (It))
					     (destination (the agent of Self))))))
		      else
		      (forall (the instrument of Self)
			      ((:triple
				(It)
				object-of
				(mustnt-be-a Be-Inaccessible with
					     (object (It)))))))
		    else
		    (the del-list of Self)))))

(Make-Accessible has (superclasses (Action)))

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

(Unobstruct has (superclasses (Make-Accessible)))

(every Unobstruct has
       (object  ((a Entity)))
       (agent   ((must-be-a Living-Entity)))
       (defeats ((if (has-value (the agent of Self))
		     then
		     (allof (the object-of of (the object of Self))
			    where 
			    ( ((the classes of It) = Be-Obstructed) and
			      ((the agent of It) = (the agent of Self))))
		     else
		     (allof (the object-of of (the object of Self))
			    where
			    ((the classes of It) = Be-Obstructed)))))

       ;; The precondition is not needed since it is the 
       ;; same as the del-list.
       ;; (pcs-list ())

       (del-list ((forall (the defeats of Self)
			  (:triple It object (the object of Self))))))

;; As with Obstruct, we must specify that the agent must 
;; move to the location of the object as part of the
;; prepatory step in an attempt to obstruct the object.
(every Unobstruct has
       (prepatory-action 
	((:default
	     (if (has-value (the agent of Self))
		 then
		 (a Move with
		    (object      ((the agent of Self)))
		    (destination ((a Place with
				     (is-at ((the location of
						  (the object of Self)))))
				  ))))))))

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

(Release has
  (superclasses		(Unobstruct))
  (required-slot   	(object the-enclosure))
  (primary-slot 	(agent instrument))
  (secondary-slot      	())
  (cmap-correspondence 	(
			 (:seq object "object")
			 (:seq agent "releaser")
			 (:seq instrument "instrument")
			)))

(every Release has
  (the-enclosure ((a Enclosure)))
  (defeats ((allof (the object-of of (the object of Self))
		   where (((the the-enclosure of It) = (the the-enclosure of Self))
			  and ((the classes of It) = Be-Confined)))))
  (object ((a Tangible-Entity with
	      (location ((constraint 
			   ((TheValue isa Place) and
			    (TheValue ==
			     (the encloses of (the location of 
				  (the the-enclosure of Self)))))))))))
  (pcs-list ((:triple
	       (the object of Self)
	       object-of
	       (a Be-Confined with
		 (the-enclosure ((the the-enclosure of Self)))))))

  (del-list ((forall (the defeats of Self)
	       (:set
		 (:triple It object (the object of Self))
		 (:triple It the-enclosure (the the-enclosure of Self))))))
)

(every Release has
       (preparatory-step (#|default|#
			  (a Confine with
			     (the-enclosure ((the the-enclosure of Self)))
			     (object ((the object of Self))))))
)

;; Test cases are incorporated with that of Confine and can be 
;; found in Confine.km
(Release has (test-case ()))

 
;;; ----------
		 
(global-situation)

 (*john has (instance-of (Tangible-Entity)))

(*cell has (instance-of (Enclosure)))

(new-situation)

(a Release with
       (object (*john))
       (the-enclosure (*cell)))
(do-and-next (thelast Release))
(the object-of of *john)

;;; In 1.4.3.4 was 2 objects (_X _Be-Confined17)
;;; But the _Be-Confined shouldn't be there!

(print (the object-of of *john))
((the object-of of *john) isa Release)
#|
[_Situation79] KM>  (print (the object-of of *john))
1 -> (print (the object-of of *john))+A
(Will now trace absolutely everything)
1 -> (print (the object-of of *john))
2  -> (the object-of of *john)
2   (1) Look in previous situation
3   -> (in-situation _Situation67 (the object-of of *john))+A
(Will now trace absolutely everything)
3   -> (in-situation _Situation67 (the object-of of *john))
3    
3    Temporarily changing to Situation _Situation67...
4    -> (the object-of of *john)
4     (1) Local value(s): ((_Release68) &&
                           ((a Be-Confined with
                             (the-enclosure
                              ((the the-enclosure of _Release68))))))
5     -> ((_Release68) &&
          ((a Be-Confined with
            (the-enclosure ((the the-enclosure of _Release68))))))

Caching problem here -- this is a subtle case where a change causes
a significant *indirect* effect, but KM only un-done's the cached
flag on the direct effects.

compute the pcs-list 
 -> compute the del-list
   -> compute the defeats of the Release
     -> defeats is NIL, because the object isn't known to be confined
Then we ASSUME the pcs that the object is confined.
So now the "defeats" and "del-list" has changed, but 
  defeats has been cached as NIL, so the updated del-list isn't seen!

As a result, we are left with 
  *john still as the object of a Be-Confined, which then gets projected
   to the new situation (rather than being deleted).

Really, the del-list should be recomputed, AND defeats should be
recomputed too.

Solution: After doing the pcs-list: if you do any asserts then un-done
ALL slots on the action. This is a limited relaxation of caching. To
be logically complete, EVERY computation should be undone every time
an assert is made, but that is too drastic to be reasonable.
|#


(print "cache2.km")

(reset-kb)

(every Car has (parts ((a Engine))))

(the parts of (a Car))

(EVAL (DELETE-VAL '_Car1 'parts '_Engine2))

;;; Make sure that we re-inherit info, i.e., that delete-val includes
;;; a un-done call to flush the cache.
(the parts of _Car1)
(print "called.km")

(reset-kb)

(not ((a Car uniquely-called "Pete") &? (a Car uniquely-called "Joe")))

(Pete has (owns ((a Car uniquely-called "Joe") (a Car uniquely-called "Mike"))))

(((the owns of Pete) called "Joe") isa Car)

(((the owns of Pete) uniquely-called "Joe") isa Car)

(not ((the first of (the owns of Pete)) &? (the second of (the owns of Pete))))

(every Car has (parts ((a Engine uniquely-called "Engine1"))))

(Car has (superclasses (Vehicle)))

(every Vehicle has (parts ((a Engine uniquely-called "Engine2"))))

((the number of (the parts of (a Car))) = 2)

((the uniquely-called of (the parts of (a Car))) = (:set "Engine1" "Engine2"))

(*Pete has (owns ((a Car called "Fred"))))
(*Pete has (owns ((a Car called "Joe"))))
(*Pete has (owns ((a Car uniquely-called "Mike"))))
(*Pete has (owns ((a Car uniquely-called "Andrew"))))

((the number of (the owns of *Pete)) = 2)
((the called of (the first of (the owns of *Pete))) = (:set "Fred" "Joe" "Mike"))
((the uniquely-called of (the first of (the owns of *Pete))) = "Mike")
((the called of (the second of (the owns of *Pete))) = (:set "Andrew"))
((the uniquely-called of (the second of (the owns of *Pete))) = (:set "Andrew"))

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

;;; Shouldn't generate an error...
((the called of 
	  (an instance of (the-class Car called "fred" with (color (*Red)))))
  = "fred")
(print "ccalc.km")

;;; File: ccalc.km
;;; Author: Peter Clark
;;; Purpose: Solution to Jo Lee's exercise

(reset-kb)

(car has (superclasses (object)))
(vw has (superclasses (car)))
(vwRabbit has (superclasses (vw)))
(toyota has (superclasses (car)))
(electricalSystem has (superclasses (object)))
(alternator has (superclasses (object)))
(airCondSystem has (superclasses (object)))

(mikesCar has (instance-of (toyota)))
(dicksCar has (instance-of (vwRabbit)))
(tomsCar has (instance-of (vwRabbit)))

(subpartsOK has
  (instance-of (Slot))
  (domain (object))
  (range (Boolean))
  (cardinality (1-to-1)))

(is-defective has
  (instance-of (Slot))
  (domain (object))
  (range (Boolean)))


;;; [1] non-null means object has a defective part
;;; [2] non-null means subparts are ok. 
;;; [3] isWrong: list parts which are defective, but subparts are OK
(every object has
  (part ((the part0 of Self)
         (the part of (the part0 of Self))))
  (is-defective ((the is-defective of (the part of Self))))  ; [1]
  (subpartsOK ((allof (the part of Self)		     ; [2]
		must  (not (the is-defective of It)))))
  (isWrong ((allof (the part of Self)			     ; [3]
	     where (    (the is-defective of It)
		    and (the subpartsOK of It))))))

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

(every vw has
    (part0 ((a electricalSystem with
	      (part0 ((a alternator with
			 (is-defective (t)))))))))

(every car has
    (part0 ((a airCondSystem))))

;;; --------------------
;;;	Prototype version: redundant to have this twice, but no problem
;;; --------------------


(a-prototype vw)
 
((the vw) has 
        (part0 ((a electricalSystem with
		    (part0 ((a alternator)))))))

; Revised, prototypes no longer pull in inherited information
; ((the alternator part of (the vw)) has (is-defective (t)))
((the alternator part0 of (the part0 of (the vw))) has (is-defective (t)))

(end-prototype)

(a-prototype car)

;((the car) has (part0 ((a airCondUnit))))
((the car) has (part0 ((a airCondSystem))))

(end-prototype)

;;; --------------------
;;; Demo
;;; --------------------

#|
KM> (the isWrong of dicksCar)
(_alternator1214)

KM> (tomsCar has 
	(part0 ((a airCondSystem with
		   (is-defective (t))))))

KM> (the isWrong of tomsCar)
(_airCondSystem1215 _alternator1218)

KM> (the isWrong of mikesCar)
NIL				; ie. nothing is wrong
|#

;;; test:
((the isWrong of dicksCar) isa alternator)

(tomsCar has 
	(part0 ((a airCondSystem with
		   (is-defective (t))))))

;((the isWrong of tomsCar) covers '(a airCondSystem))
;((the isWrong of tomsCar) covers '(a alternator))
(oneof (the isWrong of tomsCar) where (It isa airCondSystem))
(oneof (the isWrong of tomsCar) where (It isa alternator))

(not (the isWrong of mikesCar))
(print "classify.km")

(reset-kb)

;;; Note: (constraint (TheValue >= 100000)) is satisfied if there are zero values, hence need extra test
(every RichPerson has-definition
  (instance-of (Person))
  (salary ((at-least 1 Thing) (constraint (TheValue >= 100000)))))

(every RichPerson has
  (lives-in ((a House with (size (*Big))))))

(the size of (the lives-in of (a Person with (salary (1000000)))))
(not (the size of (the lives-in of (a Person with (salary (10))))))
(*Fred has (instance-of (Person)))
(not (the size of (the lives-in of *Fred)))
(*Fred has (salary (1000000)))
(the size of (the lives-in of *Fred))

(SETQ *OLD-INDIRECT-CLASSIFICATION* *INDIRECT-CLASSIFICATION*)
(SETQ *INDIRECT-CLASSIFICATION* T)

;;; ======================================================================
;;;		INDIRECT CLASSIFICATION (Steve Wilder 1/8/03)
;;; ======================================================================

(reset-kb)

(American has (superclasses (Thing)))

(every American has
       (flags-on-car ((the output of (a Compute-Nationality with (input (Self)))))))

(Patriot has (superclasses (American)))

(every Patriot has-definition
       (instance-of (American))
       (flags-on-car (2)))

(Soldier has (superclasses (American)))

(every Soldier has-definition
       (instance-of (American))
       (carries (*gun)))

(Compute-Nationality has (superclasses (Method)))

(every Compute-Nationality has
       (output ((if ((the drives of (the input of Self)) = *suv)
		    then
		  2
		  else
		  1))))

(Texan has (superclasses (American)))

(every Texan has
       (flags-on-car (2))
       (drives (*suv)))

;;; ---------- requires indirect classification:

((a American with (drives (*suv))) isa Patriot)

;;; ---------- requires plain and simple instances to be classified:

; ((a Texan) isa Patriot)	- Now deliberately FAILS with KM 2.0.32 and later
; To have "bare instances" classified, do (setq *classify-slotless-instances* t)

(SETQ *INDIRECT-CLASSIFICATION* *OLD-INDIRECT-CLASSIFICATION*)

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

(reset-kb)

(every Mexican has-definition (instance-of (Person)) (lives-in (*Mexico)))
(every Big-Mexican has-definition (instance-of (Person)) (lives-in (*Mexico)) (body-size (*Big)))
((a Person with (lives-in (*Mexico)) (body-size (*Big))) isa Mexican)
((a Person with (lives-in (*Mexico)) (body-size (*Big))) isa Big-Mexican)

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

(reset-kb)

(every Capacitor has-definition
     (instance-of (Object))
     (parts ((a Plate with
		(parallel-to ((the second of (the Plate parts of Self)))))
	     (a Plate with
		(parallel-to ((the first of (the Plate parts of Self))))))))

(_Plate1 has
     (instance-of (Plate))
     (parallel-to (_Plate2)))

(_Plate2 has
     (instance-of (Plate))
     (parallel-to (_Plate1)))

((a Object with
     (parts (_Plate1 _Plate2))) isa Capacitor)

;;; ------------------------------
;;; Classify with inherit-with-overrides example from Bruce  8/19/05

(reset-kb)

(every Super1 has 
       (mycolor (Blue))
       (mysize (Big)))

(every Super2 has
       (mycolor (Red))
       (mysize (Small)))

(Sub has (superclasses (Super1 Super2)))  ;;; Note that Sub is a subclass of 
(every Sub has-definition                  ;; both Super1 and Super2,
       (instance-of (Super1))              ;; and it has a definition
       (mysize (Medium)))

(mysize has 
       (instance-of (Slot))
       (cardinality (N-to-1))
       (inherit-with-overrides (t)))     ;;; Note this

#|
NOTE: in earlier KM, this failed as 
  - the Super1 was classified as a Sub
  - but the constraint check failed to do the unification, as it thought
	(i) the super1 has mysize Medium Big
	(ii) the to-be-unified Sub had mysize Big Medium Small
    the reason being that the "get the values" code in
	check-slotvals-constraints did not take into account that the slot
	was an inherit-with-overrides slot. Result was:
    (COMMENT: _Super11 satisfies definition of Sub,)
    (COMMENT: ...but classes/properties clash!! So reclassification not made.)
Now this is fixed.
|#
((a Super1 with (mysize (Medium))) isa Sub)

;;; ======================================================================
;;;		NEW: Test :incomplete flag
;;; ======================================================================

(reset-kb)

(every Island has-definition
  (instance-of (Thing))
  (neighbors ((exactly 0 Thing))))

(every Combination-Reaction has-definition 
  (instance-of (Thing))
  (result ((exactly 1 Thing))))

(_X == (a Reaction with (neighbors (:incomplete)) (result ((a Thing)
:incomplete))))

(not (_X isa Combination-Reaction))
(not (_X isa Island))

(_X now-has (neighbors ()))

(not (_X isa Combination-Reaction))
(_X isa Island)

(_Y == (the result of _X))
(_X now-has (result (_Y)))

(_X isa Combination-Reaction)
(_X isa Island)

(new-situation)

(_XX == (a Reaction with (neighbors (:incomplete)) (result ((a Thing)
:incomplete))))

(not (_XX isa Combination-Reaction))
(not (_XX isa Island))

(_XX now-has (neighbors ()))

(not (_XX isa Combination-Reaction))
(_XX isa Island)

(_YY == (the result of _XX))
(_XX now-has (result (_YY)))

(_XX isa Combination-Reaction)
(_XX isa Island)

#|
======================================================================
This subtle classification problem was reported by Andre Renard.
(the atoms of _X) generates 3 atoms, but before they are asserted
on the atoms slot the classifier fires and attempts to classify the
Carbon, causing (the Oxygen atoms of Self) to be evaluated...which
fails, as the 3 atoms have not yet been asserted on the atoms slot
and the looping detector kicks in. As a result, the classification
fails and the expression on the double-bonds slot is clobbered
(overwritten by the nil result).

The fix is to postpone classification for (a ...) expressions on a 
slot until they have been asserted on that slot, implemented using
*postponed-classifications* variable in KM.
======================================================================
|#
(reset-kb)

(every Carbonyl has-definition
     (instance-of (Carbon))
     (double-bonds ((a Oxygen))))

(_X has
     (atoms (
             (a Oxygen called "O1")
             (a Oxygen called "O2")
             (a Carbon with
                 (double-bonds (((the Oxygen atoms of Self) called "O2")))
                 (single-bonds (((the Oxygen atoms of Self) called "O1")))))))

(showme (the Carbon atoms of _X))

;;; The test
((the Carbon atoms of _X) isa Carbonyl)


;;; ======================================================================
;;;	3/17/09: The below used to fail because the lookahead in slotvals-subsume 
;;;     was incorrectly reading (?kmvar9014 == (a Tangible-Entity)) as 
;;;     denoting 2 entities, while the object of _Y is only 1, and hence
;;;     undesirably failing. 
;;; ======================================================================

(reset-kb)

(Move has (superclasses (Event)))
(Person has (superclasses (Tangible-Entity)))

(_X == (a Person))
(_Y == (a Move with (agent (_X)) (object (_X))))
(_Z == (a Action with (subevent (_Y))))
(_Z isa (the-class Action with
       (subevent
        ((a Move with (object ((?kmvar9014 == (a Tangible-Entity))))
          (agent (?kmvar9014)))
         (must-be-a Event)))))






(print "comments.km")

(reset-kb)

(every Car has
      (cost (((the pretax-cost of Self) * (1 + (the tax-rate of Self)) [Tax1])))
      (pretax-cost (((the base-cost of Self) + (the options-cost of Self) [PreTax1])))
	(tax-rate ((a Thing [foo] [foo1]))))

(comment [foo]
	"exit foo"
	"enter foo")

(comment [foo1]
	"exit foo1"
	"enter foo1")

(comment [Tax1]
        (:seq "So the total cost of the car is" (the pretax-cost of Self) 
               "* (1 + " (the tax-rate of Self) ") = " (the cost of Self) ".")
        "A car's total cost is its pretax cost plus tax."
        (:set 
              (:triple Self tax-rate *)
		(:triple Self pretax-cost *) ))

(comment [PreTax1]
         (:seq "So, the car costs (pretax) " (the base-cost of Self) "+"
               (the options-cost of Self) "=" (the pretax-cost of Self) ".") 
         "A car's pretax cost is its base cost + options cost.")

(*MyCar has
      (instance-of (Car))
      (base-cost (10000))
      (options-cost (2000))
      (tax-rate (0.08)))

(the cost of *MyCar)

; (trace)

(justify)

#|
KM> (justify)
I'll assume you're asking me to justify:
   (the cost of *MyCar) = (12960.001)...

A car's total cost is its pretax cost plus tax.
  enter foo
  exit foo
  enter foo1
  exit foo1
  A car's pretax cost is its base cost + options cost.
  So, the car costs (pretax) 10000 + 2000 = 12000.
So the total cost of the car is 12000 * (1 + 0.0800) = 12960.00.
(t)
(34 inferences and 165 KB accesses in 0.0 sec [850 lips, 4125 kaps]))
KM> 
|#

;;; ======================================================================
;;;		COMMENTS ON INSTANCES AND PROTOTYPES
;;; ======================================================================

(reset-kb)

(*Fido == (a Dog with (parts ((a Head [Fido])))))

(comment [Fido] (:seq Self "exit.") (:seq Self "enter."))

;(justify (:triple *Fido parts *))
((get-justification (:triple *Fido parts *)) =
("fido enter.
fido exit."))

(*Fido2 has (parts ((a Head [Fido]))))

;(justify (:triple *Fido parts *))
((get-justification (:triple *Fido2 parts *)) =
("fido2 enter.
fido2 exit."))

(a Dog with (parts ((a Head [Fido]))))

((get-justification (:triple (thelast Dog) parts *)) =
("the dog enter.
the dog exit."))

(a-prototype Car)

((the Car) has 
   (parts ((a Engine [Engine]))))

(comment [Engine] (:seq Self "has an engine.") (:seq "See if" Self "has an engine."))

(end-prototype)

;(justify (:triple (a Car) parts *))
((get-justification (:triple (a Car) parts *)) =
("See if the car has an engine.
the car has an engine."))

(*X == (a Car))

;(justify (:triple *X parts *))
((get-justification (:triple *X parts *)) =
("See if x has an engine.
x has an engine."))

(print "compositions.km")

(SETQ *LINEAR-PATHS* T)

#|
PREFACE: The tests at the end exhibit classificational incompleteness,
because of KM's special cache** of instance-existentialexpr pairs. If we disable
that cache, we get the full answers that we desire, but at the high price of
introducing errors and excessive overwork elsewhere in the test-suite. The 
errors are of the form of sometimes getting multiple values where we expect 
single values.

** see (cache-explanation-for instance existential-expr) and (explained-by instance) 
   in explain.lisp

2006: More on this:
(the parts of (a Stereo)) = power-supply and loudspeaker, rather than battery and loudspeaker.
Reasoning:
 (the parts of (a Stereo)) = power-supply and converter.
 Now classify power-supply:
   output of power-supply = input of converter = nil at this point.
   so no classificationl.
 Now classify converter, find output = sound, so converter = loudspeaker, hence input = electricity.
 But now it is too late to reclassify power-supply, we have "used up" (evaluated and
   replaced with cached value nil) the path "output of power-supply = input of converter"
   and so we are stuck.
 The shallow explanation is KM classifies power-supply before converter, then there
   is a later change in converter, but KM doesn't realize power-supply should therefore
   be reclassified.
 The deeper explanation is that even if KM tried to reclassify power-supply it would
   still fail, as the key path linking the power-supply and converter has been clobbered
   by the evaluation and caching of values.

----------
These files implement the "Camera = Image Recording Device" example, plus 
others. They run under KM 1.2 (UT Web site) and later versions.

The demo illustrates both the form of general concepts, definitions (defining 
compositions), and the composition algorithm at work for run-time question 
answering.

======================================================================
			INSTRUCTIONS
======================================================================

To run the demo from KM:

	KM> (load-kb "compositions.km" :verbose t)	

(the 'verbose' flag allows you to see the result of evaluating the queries).

======================================================================
			FILES (concatenated here)
======================================================================

README	   This file

concepts.km defines a simple model of Device, plus the behaviours of Recording
	   and Producing. It also contains a whole slew of definitions of 
	   various relevant concepts, eg. a Microphone is a Sound Detector etc.

compounds.km defines a new set of compound concepts, made by different  perm-
	   utations of a {Image;Sound;Vibration} {Recording;Producing} Device
	   They are defined and named explicitly in this file purely for 
	   convenience, to save having to type 
		"(a Device with (behaviour ((a Recording with ... "
	   every time you want to query about this device.

demo.km	   contains a set of demo queries.
	   The demo issues three queries for each compound object:
		What are the parts of the device?
	 	What are its failure modes?
		What subevents are involved in its behavour?

demo.trace shows what demo.km does, with some debugging information edited out.

======================================================================
			DISCUSSION
======================================================================

This demo demonstrates both some strengths and weaknesses of the composition
algorithm. 

Strength-wise, many of the answers KM generates involve than simple union of
facts via multiple inheritance -- often the inherited information interacts
so that objects in the composition become specialized versions of their more
general forms, and can thus be recognized (classified) as already-known 
concepts. For example, "a Detector of Signals" (from Recording) becomes "a 
Detector of Sound" (in Sound Recording Device), which is then recognized 
(classified) as being an already known concept (namely a Microphone), hence 
more can be inferred about it (that it outputs an electrical signal, as this 
is a known property of microphones). etc.

A certain amount of crafting was required to make all the concepts "fit 
together". However, in a number of cases some of the answers (in particular 
failure modes) came as a (pleasant) surprise, as they weren't anticipated (by 
me) during building the KB.

----------

Weakness-wise, perhaps the most limiting factor here is that reasoning is 
completely deductive -- KM doesn't allow me to say "A generator of sound is 
*probably* a Loudspeaker" (although it might be something else); so instead I 
have to overstate it and write "A generator of sound is definitely a 
loudspeaker." (hence Sound Generators will be classified as Loudspeakers). In 
addition, the separation of "defining" vs. "incidental" properties has been, 
to an extent, judiciously made here so that the demo works. For example, the 
fact an Aperture *inputs* an Image is asserted as a DEFINING property, but 
the fact that it *outputs* an Image is asserted as an INCIDENTAL (additional) 
property. I can't say that an Aperture is defined by *both* inputing an Image 
AND outputing an Image, because then KM would fail to recognize an 
Image-inputting Receptor as an Aperture (as it's missing the second 
definitional property of outputing an Image). It might be possible to extend 
KM so it will allow multiple definitions for a concept, eg.
	Aperture: 
	  definition 1: a Receptor inputting an Image
	  definition 2: a Receptor outputting an Image
but this isn't very satisfactory either -- really KM should note that the 
concept it's built (eg. an Image-inputting Receptor) matches a *reasonably 
large subset* of the "salient" features of an Aperture, and thus it's probably
an Aperture. If later there's a conflict, it will undo that conclusion. (This
is reminiscent of PROTOS).

This lack of plausible reasoning seems to limit KM's ability to formulate a
scenario; we'd like it to experiment with possible concepts to see which fit
together, rather than follow one and only one deductive path to composition.
The (to-be-documented-very-soon) "Situation" capability in KM1.3 offers
an avenue for handling this -- KM could make a plausible inference and
enter a "Situation" (context); if a problem is hit, then it can abandon
the situation and go back to where it was. Multiple Situations could be
explored in parallel, focussing on the most coherent ones.

A second issue is one which Eugene Charniak mentioned to us at AAAI'97, namely
that the general concept descriptions don't always fit exactly -- for some
concepts, you might like to mutate or modify them; or perhaps you want several
possible descriptions of (say) Producing, and then KM chooses the appropriate
one. For example, it's natural to think of a Tape-Recorder or a Seismograph 
(for recording earthquakes) as having a Signal Receptor and a Memory-Unit, but
what about a Camera? The Aperture is sort-of a Receptor but, well it doesn't 
quite fit in the same way. Some special concepts seem slighly shoe-horned 
into the general ones which the abstract definitions present. 

Peter Clark
|#

(reset-kb)

;;; **********************************************************************
;;;			FILE concepts.km
;;; **********************************************************************

;;; ======================================================================
;;;		A GENERIC DEVICE
;;; ======================================================================

(Device has (superclasses (Physobj)))

;;; "The failure-modes of a device are the failure-modes of its (functional) parts."
(every Device has
  (behaviour ((a Activity)))
  (parts ((the participants of (the behaviour of Self))))
  (failure-modes (
    (the failure-modes of
      (the participants of 
        (the behaviour of Self))))))

;;; ======================================================================
;;;			TYPES OF BEHAVIOUR
;;; ======================================================================

;;; ----------------------------------------------------------------------
;;;		RECORDING
;;; ----------------------------------------------------------------------

(Recording has (superclasses (Activity)))

;;; "Recording involves detecting a signal, then writing it to a memory."
(every Recording has 
  (input ((a Signal)))
#|
  (participants (
    (a Receptor with
      (input ((the input of Self))))
    (a Memory-Unit with
      (input ((the output of (the Receptor participants of Self)))))))	; terrible looping!
|#
  (receptor ((a Receptor with
	      (input ((the input of Self))))))
  (memory-unit ((a Memory-Unit with
	      (input ((the output of (the receptor of Self)))))))
  (participants ((Self receptor) (Self memory-unit)))

  (subevents (
    (a Receiving with
      (object ((the input of Self)))
      (agent ((the Receptor participants of Self))))
    (a Writing with
      (object ((the output of (the Receptor participants of Self))))
      (patient ((the Memory-Unit participants of Self)))))))

;;; ----------------------------------------------------------------------
;;;		PRODUCING (this assumes two-stage production)
;;; ----------------------------------------------------------------------

(Producing has (superclasses (Activity)))

;;; "Producing involves supplying power, and converting that to a target signal."
(every Producing has 
  (output ((a Signal)))
  (participants (
    (a Power-Supply with
      (output ((the input of (the Converter participants of Self)))))
    (a Converter with
      (input ((the output of (the Power-Supply participants of Self))))
      (output ((the output of Self))))))
  (subevents (
    (a Supplying with
      (agent ((the Power-Supply participants of Self))))
    (a Converting with
      (agent ((the Converter participants of Self)))
      (object ((the output of Self)))))))

;;; ======================================================================
;;;		TYPES OF SIGNAL
;;; ======================================================================

(*Image has (instance-of (Signal)))
(*Sound has (instance-of (Signal)))
(*Vibration has (instance-of (Signal)))
(*Electricity has (instance-of (Signal)))

;;; ======================================================================
;;;		SOME GENERAL CONCEPTS
;;; ======================================================================

;;; ----------------------------------------------------------------------
;;;		ELECTRICAL DEVICE
;;; ----------------------------------------------------------------------

(Electrical-Device has (superclasses (Device)))

(every Electrical-Device has
  (failure-modes ((a Loose-Connection with (object (Self))))))

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

(Electrical-Consumer has (superclasses (Electrical-Device Consumer)))

;;; "an ELECTRICAL-CONSUMER is a CONSUMER of ELECTRICITY."
(every Electrical-Consumer has-definition
  (instance-of (Consumer))
  (input (*Electricity)))

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

(Electrical-Producer has (superclasses (Electrical-Device Producer)))

;;; "an ELECTRICAL-PRODUCER is a PRODUCER of ELECTRICITY."
(every Electrical-Producer has-definition
  (instance-of (Producer))
  (output (*Electricity)))

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

(Battery has (superclasses (Electrical-Producer Power-Supply)))

;;; "A BATTERY is a SUPPLIER of ELECTRICITY."
(every Battery has-definition
  (instance-of (Power-Supply))
  (output (*Electricity)))

(every Battery has
  (failure-modes ((a Discharged with (object (Self))))))

;;; ----------------------------------------------------------------------
;;;		MISC BITS OF THE TAXONOMY
;;; ----------------------------------------------------------------------

(Converter has (superclasses (Generator)))

(Generator has (superclasses (Producer)))

(Receptor has (superclasses (Consumer)))

;;; ----------------------------------------------------------------------
;;;		MECHANICAL DEVICE
;;; ----------------------------------------------------------------------

(Mechanical-Device has (superclasses (Device)))

(every Mechanical-Device has
  (failure-modes ((a Breakage with (object ((the moving-parts of Self)))))))

;;; ======================================================================
;;;		SOME PRE-BUILT DEFINITIONS 
;;; ======================================================================

;;; ----------------------------------------------------------------------
;;;		APERTURE
;;; ----------------------------------------------------------------------

;;; "An APERTURE is an IMAGE DETECTOR..." (definition)
(every Aperture has-definition
  (instance-of (Receptor))
  (input (*Image)))

;;; "...which outputs an image, and might get blocked." (additional assertions)
(every Aperture has
  (output (*Image))
  (failure-modes ((a Blockage with (object (Self))))))

;;; ----------------------------------------------------------------------
;;;		FILM
;;; ----------------------------------------------------------------------

;;; "a FILM is an IMAGE MEMORY-UNIT..." (definition)
(every Film has-definition 
  (instance-of (Memory-Unit))
  (input (*Image)))

;;; "...which might age, and includes a chemical-covered sheet."
(every Film has
  (failure-modes ((a Aging with (object (Self)))))
  (parts ((a Sheet with
             (covering ((a Chemical with
                           (sensitive-to ((Self input))))))))))

;;; ----------------------------------------------------------------------
;;;		MICROPHONE
;;; ----------------------------------------------------------------------

(Microphone has (superclasses (Electrical-Device)))

;;; "a MICROPHONE is a SOUND RECEPTOR..." (definition)
(every Microphone has-definition 
  (instance-of (Receptor))
  (input (*Sound)))

;;; "...which outputs an electrical signal."
(every Microphone has
  (output (*Electricity)))

;;; ----------------------------------------------------------------------
;;;		MOVEMENT SENSOR
;;; ----------------------------------------------------------------------

(Movement-Sensor has (superclasses (Mechanical-Device)))

;;; "a MOVEMENT-SENSOR is a RECEPTOR of VIBRATION..." (definition)
(every Movement-Sensor has-definition 
  (instance-of (Receptor))
  (input (*Vibration)))

;;; "...which outputs a vibration signal."
(every Movement-Sensor has
  (output (*Vibration))
  (moving-parts ((a Sensing-Needle))))

;;; ----------------------------------------------------------------------
;;;		LOUDSPEAKER
;;; ----------------------------------------------------------------------

(Loudspeaker has (superclasses (Electrical-Consumer Mechanical-Device)))

;;; "A LOUDSPEAKER is a GENERATOR of SOUND..."
(every Loudspeaker has-definition
  (instance-of (Generator))
  (output (*Sound)))

;;; "...which inputs Electricity."
(every Loudspeaker has
  (moving-parts ((a Diaphragm)))
  (input (*Electricity)))

;;; ----------------------------------------------------------------------
;;;		TAPE
;;; ----------------------------------------------------------------------

;;; "A TAPE is an ELECTRICITY SIGNAL MEMORY-UNIT..."
(every Tape has-definition
  (instance-of (Memory-Unit))
  (input (*Electricity)))

;;; ----------------------------------------------------------------------
;;;		LIGHT
;;; ----------------------------------------------------------------------

;;; "A LIGHT is a GENERATOR of IMAGES..."
(every Light has-definition
  (instance-of (Generator))
  (output (*Image)))

(every Light has
  (input (*Electricity))
  (failure-modes ((a Burning-Out with (object (Self))))))

;;; ----------------------------------------------------------------------
;;;		MOTOR
;;; ----------------------------------------------------------------------

(Motor has (superclasses (Mechanical-Device)))

;;; "A MOTOR is a VIBRATION GENERATOR..."
(every Motor has-definition
  (instance-of (Generator))
  (output (*Vibration)))

(every Motor has
  (input (*Electricity))
  (moving-parts (Self)))

;;; ======================================================================
;;;		ACTION DEFINITIONS
;;; ======================================================================

(Converting has (superclasses (Generating)))

;;; "EXPOSING is WRITING on FILM."
(every Exposing has-definition
  (instance-of (Writing))
  (patient ((a Film))))

;;; "TAPING is WRITING to TAPE."
(every Taping has-definition
  (instance-of (Writing))
  (patient ((a Tape))))

;;; "SHINING is GENERATING an IMAGE."
(every Shining has-definition
  (instance-of (Generating))
  (object (*Image)))

;;; ======================================================================
;;;		SOME NATURAL LANGUAGE GENERATION...
;;;	       (Come back, James!! All is forgiven!!)
;;; ======================================================================

(every Loose-Connection has
  (text ((:seq (Self object) "has a loose connection"))))

(every Aging has
  (text ((:seq (Self object) "is aged"))))

(every Blockage has
  (text ((:seq (Self object) "is blocked"))))

(every Breakage has
  (text ((:seq (Self object) "is broken"))))

(every Burning-Out has
  (text ((:seq (Self object) "is burned out"))))

(every Discharged has
  (text ((:seq (Self object) "is discharged"))))

;;; **********************************************************************
;;;			FILE compounds.km
;;; **********************************************************************

;;; ======================================================================

#|
The following compound concepts could, of course, be defined at run-time 
instead -- Here I've defined them explicitly in the KB for 
testing/debugging/tracing purposes. The important point is that KM 
assembles the description of them from their constitutent concepts.
|#

;;; ======================================================================
;;;		SOME PRE-DEFINED COMPOUND CONCEPTS
;;; ======================================================================

;;; ----------------------------------------------------------------------
;;;		CAMERA
;;; ----------------------------------------------------------------------

;;; "A CAMERA is an IMAGE RECORDING DEVICE."
(Camera has (superclasses (Device)))

(every Camera has
  (behaviour ((a Recording with 
                    (input (*Image))))))

;;; ----------------------------------------------------------------------
;;;		TAPE RECORDER
;;; ----------------------------------------------------------------------

;;; "A TAPE-RECORDER is a SOUND RECORDING DEVICE."
(Tape-Recorder has (superclasses (Device)))

(every Tape-Recorder has
  (behaviour ((a Recording with
		   (input (*Sound))))))

;;; ----------------------------------------------------------------------
;;;		SEISMOGRAPH
;;; ----------------------------------------------------------------------

;;; "A SEISMOGRAPH is a VIBRATION RECORDING DEVICE."
(Seismograph has (superclasses (Device)))

(every Seismograph has
  (behaviour ((a Recording with
		   (input (*Vibration))))))

;;; ----------------------------------------------------------------------
;;;		STEREO
;;; ----------------------------------------------------------------------

;;; "A STEREO is a SOUND PRODUCING DEVICE."
(Stereo has (superclasses (Device)))

(every Stereo has
  (behaviour ((a Producing with 
                    (output (*Sound))))))

;;; ----------------------------------------------------------------------
;;;		IMAGE-GENERATOR
;;; ----------------------------------------------------------------------

;;; "An IMAGE-GENERATOR is an IMAGE PRODUCING DEVICE."
(Image-Generator has (superclasses (Device)))

(every Image-Generator has
  (behaviour ((a Producing with 
                    (output (*Image))))))

;;; ----------------------------------------------------------------------
;;;		SHAKER (Let's keep it clean...)
;;; ----------------------------------------------------------------------

;;; "An SHAKER is a VIBRATION PRODUCING DEVICE."
(Shaker has (superclasses (Device)))

(every Shaker has
  (behaviour ((a Producing with 
                    (output (*Vibration))))))

;;; **********************************************************************
;;;			FILE demo.km
;;; **********************************************************************
#|
The actual queries
(make-phrase (andify  (the parts of (a Camera))))
(forall (the failure-modes of (a Camera)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Camera)))))

(make-phrase (andify  (the parts of (a Tape-Recorder))))
(forall (the failure-modes of (a Tape-Recorder)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Tape-Recorder)))))

(make-phrase (andify  (the parts of (a Seismograph))))
(forall (the failure-modes of (a Seismograph)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Seismograph)))))

(make-phrase (andify  (the parts of (a Stereo))))
(forall (the failure-modes of (a Stereo)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Stereo)))))

(make-phrase (andify  (the parts of (a Image-Generator))))
(forall (the failure-modes of (a Image-Generator)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Image-Generator)))))

(make-phrase (andify  (the parts of (a Shaker))))
(forall (the failure-modes of (a Shaker)) (make-sentence (the text of It)))
(make-phrase (andify  (the subevents of (the behaviour of (a Shaker)))))
|#

;;; Validation
#|
((make-phrase (andify  (the parts of (a Camera)))) = "the aperture and the film")
((forall (the failure-modes of (a Camera)) (make-sentence (the text of It))) = 
	(:set "The aperture is blocked." "The film is aged."))
((make-phrase (andify  (the subevents of (the behaviour of (a Camera))))) = "the receiving and the exposing")

((make-phrase (andify  (the parts of (a Tape-Recorder)))) = "the microphone and the tape")
((forall (the failure-modes of (a Tape-Recorder)) (make-sentence (the text of It))) 
	= "The microphone has a loose connection.")
((make-phrase (andify  (the subevents of (the behaviour of (a Tape-Recorder))))) =
	"the receiving and the taping")

((make-phrase (andify  (the parts of (a Seismograph)))) = "the movement-sensor and the memory-unit")
((forall (the failure-modes of (a Seismograph)) (make-sentence (the text of It))) = "The sensing-needle is broken.")
((make-phrase (andify  (the subevents of (the behaviour of (a Seismograph))))) = "the receiving and the writing")
|#

; (trace)

((make-phrase (andify  (the parts of (a Stereo)))) = "the power-supply and the loudspeaker")
;((make-phrase (andify  (the parts of (a Stereo)))) = "the battery and the loudspeaker")
((forall (the failure-modes of (a Stereo)) (make-sentence (the text of It))) = 
	(:set "The loudspeaker has a loose connection." "The diaphragm is broken."))
;	(:set "The battery is discharged." "The battery has a loose connection."
;		 "The loudspeaker has a loose connection." "The diaphragm is broken."))
((make-phrase (andify  (the subevents of (the behaviour of (a Stereo))))) = "the supplying and the converting")

((make-phrase (andify  (the parts of (a Image-Generator)))) = "the power-supply and the light")
;((make-phrase (andify  (the parts of (a Image-Generator)))) = "the battery and the light")
((forall (the failure-modes of (a Image-Generator)) (make-sentence (the text of It))) = 
	"The light is burned out.")
;#|NEW|#	(:set "The battery is discharged." "The battery has a loose connection."
;	"The light is burned out."))
((make-phrase (andify  (the subevents of (the behaviour of (a Image-Generator))))) = "the supplying and the shining")

((make-phrase (andify  (the parts of (a Shaker)))) = "the power-supply and the motor")
;((make-phrase (andify  (the parts of (a Shaker)))) = "the battery and the motor")
((forall (the failure-modes of (a Shaker)) (make-sentence (the text of It))) = 
  "The motor is broken.")
;#|NEW|#	(:set "The battery is discharged." "The battery has a loose connection."
;	"The motor is broken."))
((make-phrase (andify  (the subevents of (the behaviour of (a Shaker))))) = "the supplying and the converting")

;;; ======================================================================
;;;		Another rather esoteric one to test...
;;; ======================================================================

(ERecorder has (superclasses (Device)))

(every ERecorder has
  (behaviour ((a Recording with 
                    (input (*Electricity))))))


(EProducer has (superclasses (Device)))

(every EProducer has
  (behaviour ((a Producing with 
                    (output (*Electricity))))))


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

((make-phrase (andify  (the parts of (a ERecorder)))) = "the electrical-consumer and the memory-unit")
((forall (the failure-modes of (a ERecorder)) (make-sentence (the text of It))) =
	"The electrical-consumer has a loose connection.")
((make-phrase (andify  (the subevents of (the behaviour of (a ERecorder))))) = "the receiving and the writing")

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

((make-phrase (andify  (the parts of (a EProducer)))) = "the power-supply and the electrical-producer")
((forall (the failure-modes of (a EProducer)) (make-sentence  (the text of It))) 
	= "The electrical-producer has a loose connection.")
((make-phrase (andify  (the subevents of (the behaviour of (a EProducer))))) =
	"the supplying and the converting")

(SETQ *LINEAR-PATHS* NIL)(print "constraints-padding.km")

;;; File: constraints-padding.km
;;; Author: Peter Clark
;;; Date: 9.17.99
;;; Constraint enforcement problem!
;;; STATUS: FIXED (but at the expense of reduced constraint enforcement)

(reset-kb)

(setq *OLD-MAX-PADDING-INSTANCES* *MAX-PADDING-INSTANCES*)
(setq *MAX-PADDING-INSTANCES* 10)

(parts has
  (subslots (dparts)))

(every Thing has
  (parts ((the dparts of Self) 
	  (the parts of (the dparts of Self)))))

(every Car has 
  (dparts ((a Engine) (a Wheel-Set))))

(every Engine has
  (dparts (
	(the Wheel parts of (the Car parts-of of Self))
	(exactly 1 Wheel))))

(every Wheel-Set has
  (dparts ((a Wheel))))

(X == (a Car))
(the dparts of X) ; _Engine1 _Wheel-Set2
(the parts of X)  ; 

(the dparts of (the Engine parts of X))

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

(every Person has
   (owns ((at-least 7 Car))))

((the number of (the owns of (a Person))) = 7)

;;; Disable it again...
(setq *MAX-PADDING-INSTANCES* *OLD-MAX-PADDING-INSTANCES*)

#|
KM> (a Car)
(_Car1227)

KM> (the dparts of _Car1227)
(_Engine1228 _Wheel-Set1229)

;;; Fails to find the Wheel, as the inverse parts-of isn't yet installed.
;;; Thus, KM creates a new one using the constraint (exactly 1 Wheel)
KM> (the parts of _Car1227)
CREATED a Wheel!
(_Engine1228 _Wheel-Set1229 _Wheel1230 _Wheel1231)

;;; Now we get an error, because different value sets from subslots are
;;; appended, not unified.
KM> (the dparts of _Engine1228)
ERROR! set-constraint violation! Found 2 Wheel(s), but should be
ERROR! exactly 1! Values were: (_Wheel1230
                                _Wheel1231). Ignoring extras...
(_Wheel1230)

KM> 

SOLUTION: **Don't** allow (exactly 1 x) to do a creation if none is
found, for now. 
|#

(print "constraints.km")

;;; File: constraints.km
;;; Author: Peter Clark
;;; Date: 5/3/99
;;; Purpose: Test the constraint mechanism in KM

(reset-kb)

(Black-Thing has (superclasses (Physobj)))

(every Black-Thing has
  (color (*Black)))

(Cheap-Thing has (superclasses (Physobj)))

;;; Test: should cause constraint violations
;;; (a Partition with (members (Black-Thing Cheap-Thing)))

(*Year-1999 has 
  (instance-of (Situation))
  (supersituations (*Global)))

(*Jan-1999 has 
  (instance-of (Situation))
  (supersituations (*Year-1999)))

(*Pete has
  (owns ((must-be-a Physobj))))

(*Pete has
  (owns ((a Car))))

(in-situation *Year-1999)

(*Pete has (owns ((must-be-a Cheap-Thing))))

(*Pete has (owns ((a Rabbit))))

(in-situation *Jan-1999)

(*Pete has (owns ((must-be-a Black-Thing))))

(*Pete has (owns ((a Pen))))

;;; Test:
((the number of (the owns of *Pete)) = 3)

(forall (the owns of *Pete)
	(    ((the color of It) = *Black)
	 and (It isa Cheap-Thing)
	 and (It isa Physobj)))

;;; ======================================================================
;;;	SINGLE VALUED SLOT: Make sure it all gets unified
;;; ======================================================================

(reset-kb)

(owns has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(Black-Thing has (superclasses (Physobj)))

(every Black-Thing has
  (color (*Black)))

(Cheap-Thing has (superclasses (Physobj)))

;;; Test: should cause constraint violations
;;; (a Partition with (members (Black-Thing Cheap-Thing)))

(*Year-1999 has 
  (instance-of (Situation))
  (supersituations (*Global)))

(*Jan-1999 has 
  (instance-of (Situation))
  (supersituations (*Year-1999)))

(*Pete has
  (owns ((must-be-a Physobj))))

(*Pete has
  (owns ((a Car))))

(in-situation *Year-1999)

(*Pete has (owns ((must-be-a Cheap-Thing))))

(*Pete has (owns ((a Rabbit))))

(in-situation *Jan-1999)

(*Pete has (owns ((must-be-a Black-Thing))))

(*Pete has (owns ((a Pen))))

;;; Test: Here should be 1
((the number of (the owns of *Pete)) = 1)

(forall (the owns of *Pete)
	(    ((the color of It) = *Black)
	 and (It isa Cheap-Thing)
	 and (It isa Physobj)))

;;; ======================================================================

(reset-kb)

(likes has (instance-of (Slot)) (fluent-status (*Inertial-Fluent)))

(new-situation)

(*Fred has (likes (*Sue *Mary)))

(next-situation)

;; OLD SYNTAX
;; (*Fred has (likes ((mustnt-be *Sue))))
(*Fred has (likes ((<> *Sue))))

((the likes of *Fred) = *Mary)

;;; ======================================================================

(reset-kb)

(Action has (superclasses (Event)))
(Switching-On has (superclasses (Action)))
(Switching-Off has (superclasses (Action)))

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

;;; "The effect of a Switching-On is that the switch's position becomes Up."
(every Switching-On has
  (object ((a Switch)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

;;; "The effect of a Switching-Off is that the switch position becomes Down."
(every Switching-Off has
  (object ((a Switch)))
  (del-list ((:triple (the object of Self) position *Up)))
  (add-list ((:triple (the object of Self) position *Down))))

(*Switch1 has (instance-of (Switch)))

(new-situation)

(*Switch1 has (position (*Down)))

(do-and-next (a Switching-On with (object (*Switch1))))

((the position of *Switch1) = *Up)

(next-situation)

(next-situation)

(do-and-next (a Switching-Off with (object (*Switch1))))

((the position of *Switch1) = *Down)

;;; ======================================================================
;;;		1.4.0-beta14
;;; ======================================================================

;;; Was 1 in 1.4.0-beta13.
;;; Here the constraint is between multivalued slots, requiring the new 
;;; &&? test.
((the number of 
   (    ((a Block with (color (*Red))))
     && ((a Block with (color ((<> *Red))))))) = 2)

(*Red has (instance-of (Color)))

((the number of 
   (    ((a Block with (color (*Red))))
     && ((a Block with (color ((mustnt-be-a Color))))))) = 2)

;;; ======================================================================
;;;		1.4.0-beta14: &? operator added
;;; ======================================================================

(reset-kb)

(every Jet-Airplane has 
  (engine ((must-be-a Jet))))

(every Propellor-Airplane has
  (engine ((a Propellor))))

(a Partition with
  (members (Jet Propellor)))

;;; test NOW FAILS due to less complete contraint checking in 1.4.0 beta-39
; (not ((a Jet-Airplane) &? (a Thing with (engine ((a Propellor))))))

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

(a Partition with
  (members (Jet-Airplane Propellor-Airplane)))

(owns has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(Pete has
  (instance-of (Person))
  (owns ((a Jet-Airplane))))

(every Propellor-Airplane-Owner has
  (instance-of (Person))
  (owns ((a Propellor-Airplane))))

;;; test NOW FAILS due to less complete contraint checking in 1.4.0 beta-39
; (not (Pete &? (a Propellor-Airplane-Owner)))

;;; ======================================================================
;;; Preservation of constraints on instances:
;;; These shouldn't disappear due to unification!
;;; ======================================================================

(reset-kb)

#| 
in KM1.4.0-beta18, the two internal means of updating a slot's
values, namely get-slotvals and lazy-unify, BOTH retain constraints
on the slots. A top-level, & or &&, though, continues to filter them
out.
|#

;;; Similarly:

(global-situation)

;;; in KM1.4.0-beta17, unification loses constraints!
(*Fred & (a Person with (location ((must-be-a Place)))))

(*Fred has (location (*House)))

(the location of *Fred)

(*House isa Place)

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

(reset-kb)

(*Fred has (location (*House)))

(every Person has
  (location ((must-be-a Place))))

;;; This will test, but not enforce, the constraints. 
(*Fred & (a Person))

;;; This will now enforce the constraints, thus coercing *House to be a Place
(the location of *Fred)

(*House isa Place)

;;; ---------- similarly for Situation unification ----------

(reset-kb)

(location has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(S1 has 
	(instance-of (Situation))
	(next-situation (S2)))

(S2 has (instance-of (Situation)))
(_Situation01 has (instance-of (Situation)))

(in-situation S1)

(*Joe has (location (*House)))

(in-situation S2)

(*Joe has (location ((<> *House))))

(in-situation _Situation01)

(*Joe has (location ((<> *Tree))))

(global-situation)

(S2 & _Situation01)

(in-situation S2)

;;; Should fail! Don't want the <> constraints to disappear!
;;; Now unification preserves them.
(not (the location of (*Joe)))

;;; Another test...
(every Engine has (parts ((mustnt-be-a Biological-Thing))))

;;; test NOW FAILS due to less complete contraint checking in 1.4.0 beta-39
;;; Now works in beta-43!
(not ((a Thing with (parts ((a Biological-Thing)))) &? (a Engine)))

;;; ======================================================================

(reset-kb)

(a Partition with
  (members (Cat Dog)))

(Alsation has (superclasses (Dog)))
(Siamese has (superclasses (Cat)))

(not ((a Alsation) &? (a Siamese)))

(_MyAlsation1 has (instance-of (Alsation)))
(_MySiamese2 has (instance-of (Siamese)))

(not (_MyAlsation1 &? _MySiamese2))

;;; ---------- try again, checking partition inheritance

(reset-kb)

(MyPartition has (superclasses (Partition)))

(a MyPartition with
  (members (Cat Dog)))

(Alsation has (superclasses (Dog)))
(Siamese has (superclasses (Cat)))

(not ((a Alsation) &? (a Siamese)))

(_MyAlsation1 has (instance-of (Alsation)))
(_MySiamese2 has (instance-of (Siamese)))

(not (_MyAlsation1 &? _MySiamese2))

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

;;; Urgh. These were working under beta38, but then stopped with
;;; the beta39 use of unifiable-with-indefinite-expr.
;;; They need to be in the test suite!

(every NonRedThing has
  (color ((<> *Red))))

(every RedThing has
  (color ((exactly 1 Thing) *Red)))

(not ((a Car with (color (*Red))) &? (a NonRedThing)))   ; [1]
(not ((a Car with (color ((<> *Red)))) &? (a RedThing))) ; [2]

(*Pete has 
  (has-red-car ((a Car)
		 (must-be-a Car with
		   (color (*Red)))))
  (has-nonred-car ((a Car with
		     (color ((<> *Red)))))))

(not ((the has-red-car of *Pete) &? (a NonRedThing)))  ; [3]
(not ((the has-nonred-car of *Pete) &? (a RedThing)))  ; [4]

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

;;; undefined objects should be in class Thing
((the classes of asdf) = Thing)

;;; ============================================================
;;;		ANOTHER LITTLE TEST...
;;; ============================================================

(reset-kb)

(Big-Engine has (superclasses (Engine)))
(Noisy-Engine has (superclasses (Engine)))

(_Engine01 has (instance-of (Big-Engine)))
(_Engine02 has (instance-of (Noisy-Engine)))

(_Car01 has
  (parts (_Engine01 (exactly 1 Engine))))

(_Car02 has
  (parts (_Engine02)))

(_Car01 &! _Car02)

;;; Check constraint is enforced
((the number of (the Engine parts of _Car01)) = 1)

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

(reset-kb)

(Big-Engine has (superclasses (Engine)))
(Noisy-Engine has (superclasses (Engine)))

(_Engine01 has (instance-of (Big-Engine)))
(_Engine02 has (instance-of (Noisy-Engine)))

(_Car01 has
  (parts (_Engine01 (exactly 1 Engine))))

(_Car02 has
  (parts (_Engine02)))

(_Car01 == _Car02)

;;; Check constraint is enforced
((the number of (the Engine parts of _Car01)) = 1)

;;; ======================================================================
;;;		CLASS CONSTRAINTS
;;; ======================================================================

(Car has (superclasses (Vehicle)))

(not ((a Car) &? (a Truck with (instance-of ((<> Car))))))
(not ((a Truck with (instance-of ((<> Car)))) &? (a Car)))

;;; Also, as instance-of is a remove-subsumers slot, the following
;;; tests should also be passed:
(not ((a Car) &? (a Table with (instance-of ((<> Vehicle))))))
(not ((a Table with (instance-of ((<> Vehicle)))) &? (a Car)))

((a Car) &? (a Person with (instance-of (Car (<> Man)))))

;;; --- more ---
;;; Check can override classification with <> constraints.
;;; Technically is inconsistent in the KB, but allows user overrides.

(reset-kb)

(Car has (superclasses (Vehicle)))

(Fast-Car has (superclases (Car)))

(every Fast-Car has-definition
  (instance-of (Vehicle))
  (goes (Fast)))

(Big-Car has (superclasses (Car)))

((a Car with (goes (Fast))) isa Fast-Car)

(not ((a Car with (instance-of ((<> Fast-Car))) (goes (Fast))) isa Fast-Car))

((a Vehicle with (goes (Fast))) isa Fast-Car)

(not ((a Vehicle with (instance-of ((<> Fast-Car))) (goes (Fast))) isa Car))

;;; ======================================================================
;;;		PARTITIONS
;;; ======================================================================

;;; Non-exhaustive partitions...
(a Partition with (members (Solid Liquid)))
((a Tangible-Entity) &? (a Solid))			; failed in 1.4.0.52

;;; ======================================================================
;;;		POSSIBLE-VALUES constraint
;;; ======================================================================

(every Car has
  (parts ((a Engine with
		(instance-of ((possible-values Petrol-Engine Diesel-Engine)))))))

(a Partition with
  (members (Petrol-Engine Diesel-Engine Solar-Engine)))

(not ((the parts of (a Car)) &? (a Solar-Engine)))

;;; ======================================================================
;;;		POSSIBLE-VALUES and EXCLUDED-VALUES
;;; ======================================================================

(reset-kb)

;;; ---------- Test 1 ----------

(every Person has
  (favorite-color ((a Color) (possible-values *Red *Blue))))

(not ((the favorite-color of (a Person)) &? *Green))

;;; ---------- Test 2 ----------

(every Pet has
  (instance-of ((possible-values Dog Cat))))

(a Partition with
  (members (Cat Dog Elephant)))

(Pet has (superclasses (Animal)))
(Dog has (superclasses (Animal)))
(Cat has (superclasses (Animal)))
(Elephant has (superclasses (Animal)))
(Big-Elephant has (superclasses (Elephant)))
(Big-Dog has (superclasses (Dog)))

((a Pet) &? (a Animal))
(not ((a Pet) &? (a Elephant)))
(not ((a Pet) &? (a Big-Elephant)))

((a Dog) &? (a Animal))
(not ((a Dog) &? (a Elephant)))
(not ((a Dog) &? (a Big-Elephant)))

;;; ---------- Test 3 ----------

(*Pete has
  (owns (*PetesCar)))

(*Fred has
  (likes ((a Car) (possible-values (the owns of *Pete)))))

;;; As there's only one possible value, we can conclude this is 
;;; what Fred likes.
((the likes of *Fred) = *PetesCar)

;;; ---------- Test 4 ----------

;(reset-kb)
(every Nucleotide has
  (parts (
   (a Sugar) 
   (a Sugar)
   (a Nitrogen with
     (connected-to ((a Sugar) (possible-values (the Sugar parts of Self))))))))

(N == (a Nucleotide))
((the first of (the Sugar parts of N)) == S1)
((the second of (the Sugar parts of N)) == S2)

;;; If I enforce that...
((the connected-to of (the Nitrogen parts of N)) /== S1)

;;; then it follows that...
;;; ((the connected-to of (the Nitrogen parts of N)) = S2)
;;; PROVIDING the constraints are retested. BUT KM's cache
;;; retrieves the old, cached value, and doesn't apply constraint reasoning.

((the Nitrogen parts of N) has (age (20)))	; Hack: touch the Nitrogen, to remove cache

((the connected-to of (the Nitrogen parts of N)) = S2)

;;; ---------- Test 5 ----------

(*Joe has
  (likes ((excluded-values *Sue))))

(*Joe has
  (likes ((a Person))))

(not ((the likes of *Joe) &? *Sue))

;;; ---------- Test 6 ----------

(reset-kb)

(Pet has (superclasses (Animal)))

(every Pet has
  (instance-of ((excluded-values Tiger))))

(Pet-Dog has (superclasses (Pet)))

(Tiger has (superclasses (Animal)))

(Big-Tiger has (superclasses (Tiger)))

((a Pet) &? (a Animal))
(not ((a Pet) &? (a Tiger)))
(not ((a Pet) &? (a Big-Tiger)))

((a Pet-Dog) &? (a Animal))
(not ((a Pet-Dog) &? (a Tiger)))
(not ((a Pet-Dog) &? (a Big-Tiger)))

((a Animal) &? (a Animal))
((a Animal) &? (a Tiger))
((a Animal) &? (a Big-Tiger))

;;; ---------- Test 7 ----------

(every Person has
  (favorite-color ((a Color)))
  (likes-color ((possible-values (the favorite-color of Self)))))

(*Pete has 
  (instance-of (Person))
  (likes-color (*Green)))

(the likes-color of *Pete)		; trigger constraint enforcement

((the favorite-color of *Pete) = *Green)

;;; ---------- Test 8 ----------

(*Pete has (likes ((a Person))))

(_X == (the likes of *Pete))

(_X /== *Sue)

(not (_X &? *Sue))

;;; ---------- Test 9 ----------

(_X /== _Y)
(_Y == _Z)
(not (_X &? _Z))

;;; ======================================================================
;;; v1.4.1.3 bug - evaluation during constraint checking mistakenly
;;; added, rather than replaced, the old slot-value expressions.
;;; ======================================================================

(reset-kb)

(*MyCar has
  (parts ((a Wheel))))

(every Vehicle has
  (parts ((must-be-a Wheel))))

(*MyCar &? (a Vehicle))

((the number of (the parts of *MyCar)) = 1)


;;; ======================================================================
;;;		test-set-constraints:
;;; Check the potential *combination* of values on the holds slot violates the
;;; (exactly 2 Base) constraints, even though each value set on its own
;;; doesn't violate the constraint.
;;; ======================================================================

(reset-kb)

(AT-Bond has (superclasses (Bond)))
(every AT-Bond has
  (holds ((exactly 2 Base) (a Adenine) (a Thymine))))

(GC-Bond has (superclasses (Bond)))
(every GC-Bond has
  (holds ((exactly 2 Base) (a Guanine) (a Cytosine))))

(Adenine has (superclasses (Base)))
(Thymine has (superclasses (Base)))
(Guanine has (superclasses (Base)))
(Cytosine has (superclasses (Base)))

(a Partition with
  (members (Adenine Thymine Guanine Cytosine)))

(_MyAT-Bond == (a AT-Bond))
(_MyGC-Bond == (a GC-Bond))
(the holds of _MyAT-Bond)	; One object must have values to do checking!

;(trace)
;;; This failed under 1.4.1.4
(not (_MyAT-Bond &? _MyGC-Bond))

;;; NB ((a AT-Bond) &? (a GC-Bond)) incorrectly succeeds, as nothing provokes 
;;; checking of "holds" slot constraints

;;; similar test (failed under 1.4.1.4)
(not ((a Bond with (holds ((a Guanine)))) &? 
      (a Bond with (holds ((exactly 2 Thing) (a Adenine) (a Thymine))))))

(not ((a Bond with (holds ((exactly 2 Thing) (a Adenine) (a Thymine)))) &?
      (a Bond with (holds ((a Guanine))))))

;;; ======================================================================

#|
Asymmetry here under KM 1.4.1.4:

KM> (every Dog has (color (*Green)))
KM> ((a Thing with (color ((<> *Green)))) &? (a Dog))		; [1]
NIL
KM> ((a Dog) &? (a Thing with (color ((<> *Green)))))		; [2]
(t)

[1] _Thing23 &? (a Dog) 
    -> will inherit and evaluate all expressions on Dog, bar existential expressions
[2] _Dog23 &? (a Thing with (color ((<> *Green)))))
    -> Dog will not inherit any value expressions, only constraints. Otherwise,
	we're heading for doing full inheritance (perhaps that's what we should do??)
|#
;;; Fixed in KM 1.4.1.5, though it means KM's doing more work. Fix is to have KM do 
;;; inheritance for named objects.

(every Dog has (color (*Green)))
(not ((a Thing with (color ((<> *Green)))) &? (a Dog)))
(not ((a Dog) &? (a Thing with (color ((<> *Green))))))

;;; ======================================================================

#|
Make sure that a local value in a situation (24) is compared for unification
with a SUPERSITUATION-INHERITED LOCAL value (23), and find they don't match (and
thus violate the cardinality constraint).

We also check for named instances failing to unify with cardinality constraints here.

NOTE: [1] We make a dummy assertion on [1], because KM is optimized to ONLY compare
constraints in situations where BOTH objects have at least some slot-values.

If we remove [1], then the below unification will incorrectly succeed. We could
avoid this by relaxing the optimization, but this will mean, in general, a ton of
work in constraint checking. 

This optimization is implemented in lazy-unify.lisp 
	(defun unified-svs-in-situation (i1 i2 situation &key classes-subsumep eagerlyp)
	  (let ( (slotsvals1 (get-slotsvals i1 'own-properties situation))
		 (slotsvals2 (get-slotsvals i2 'own-properties situation)) )
	    (cond ((and slotsvals1 slotsvals2)	...			<====== HERE 

|#

(reset-kb)

(age has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(_Person1 has
  (age (23)))

(new-situation)

(_Person1 has
  (has-name (flusie)))		; [1]

(_Person2 has
  (age (24)))

(not (_Person1 &? _Person2))	; should succeed

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

(reset-kb)

(every Person has
      (favorite-color (
  	(a Color)
        (excluded-values *Purple)
	(possible-values (the possible-favorite-colors of Self))))
      (possible-favorite-colors (*Red *Blue *Pink)))

(Man has (superclasses (Person)))

(every Man has 
      (possible-favorite-colors (*Black)))

(*Fred has
  (instance-of (Man)))

(_X == (the favorite-color of *Fred))

(_X /== *Red)
(_X /== *Blue)
(_X /== *Pink)

;;; Hack - Need to trigger resetting the cache...
(*Fred has (age (20)))

;;; therefore:
((the favorite-color of *Fred) = *Black)

;;; ======================================================================
;;;	failure due to test-set-constraints mistakenly thinking 
;;; 	_Engine1 will unify with _Wheel3. Now ignore instances when
;;;	testing set constraints during unification.
;;; ======================================================================

;;; This problem isn't fixed yet in KM.
;;; 4/18/01 - Fixed!

(reset-kb)

(every Car has
  (parts ((at-most 1 Engine))))

(_Car1 has
  (instance-of (Car)) 
  (parts (_Engine1)))

(_Engine1 has
  (instance-of (Engine)))

(_Car2 has
  (instance-of (Car)) 
  (parts (_Wheel3 _Engine2)))

(_Engine2 has
  (instance-of (Engine)))

(_Car1 &? _Car2)

;;; ------------------------------
;;; Even more tricky...

(reset-kb)

(every Car has
  (parts ((at-most 1 Small-Engine))))

(_Car1 has
  (instance-of (Car)) 
  (parts (_Small-Engine1)))

(_Small-Engine1 has
  (instance-of (Small-Engine)))

(_Engine3 has 
  (instance-of (Engine)))

(Small-Engine has (superclasses (Engine)))

(_Car2 has
  (instance-of (Car)) 
  (parts (_Engine3 _Small-Engine2)))

(_Small-Engine2 has
  (instance-of (Small-Engine)))

(_Car1 &? _Car2)


;;; ======================================================================
;;;	For Dan Tecuci..
;;; ======================================================================

(reset-kb)
 (Aggregate has (superclasses (Entity)))
 
 (every Aggregate has
 
        ;; some type/class
        (element-type ((must-be-a Class)))
 
        ;; all members must be of some type in element-type list
;        (members ((constraint ((the element-type of Self)
; 			      includes
; 			      (the instance-of of TheValue)))))

        (members ((constraint ((oneof (the element-type of Self) 
				where (TheValue isa It))))
		  (set-constraint ((the number of TheValues) <=
					(the max-size of Self)))))

	(max-size (10)))
 
        ;; compute size if not given
        ;; This implements 1.a. from above
;        (size ((constraint ((the1 of TheValue) >=
; 			   (the number of (the members of Self)))))))
	
 
 
 (E has (superclasses (Entity)))
 
 (F has (superclasses (Entity)))
 
 (a Aggregate with
    (element-type (E F))
    (members ((a E) (a E) (a F)))
    (size ((:pair 10 (:set E F)))))

;;; Check this works without error...
(the members of (thelast Aggregate))

;;; ======================================================================
;;;	EXCLUDED VALUES BUG - need to allow zero excluded values
;;; ======================================================================

(reset-kb)

 (every MMove has
    (object       (((a Tangible-Entity) &
                    (excluded-values (the origin of Self)
                                     (the destination of Self)
                                     (the away-from of Self)
                                     (the toward of Self)
                                     (the path of Self)))
    ))
    (origin       ((must-be-a Spatial-Entity)))
    (destination  ((must-be-a Spatial-Entity)))
    (away-from    ((must-be-a Spatial-Entity)))
    (toward       ((must-be-a Spatial-Entity)))
    (path         ((must-be-a Spatial-Entity))))

;;; Note - null excluded values caused error in 1.4.5.6
((the object of (a MMove)) isa Tangible-Entity)

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

(every Person has
  (parts ((a Head) (a Head) (exactly 1 Head))))

;;; Check (exactly 1 Head) constraint is enforced.
;;; In earlier versions, I forgot to splice out the (@ ...) source markers
((the number of (the parts of (a Person))) = 1)

;;; ======================================================================
#| 
put-vals for single-valued slots may be called with value (val & constraint).
This occurs when there is a LOCAL constraint, as produced by actions.
So, we must unpack this expression to make sure inverse is installed.
|#

(reset-kb)

(location has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(every Dog has
  (location ((a Place))))

(*MyDog has 
  (instance-of (Dog))
  (location ((<> *InMyHouse))))

((the location-of of (the location of *MyDog)) = *MyDog)

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

;;; Test enforcement of <>:
(every Man has (loves ((<> *Sue) (a Woman))))

(not ((the loves of (a Man)) &? *Sue))


;;; ======================================================================
;;;		CHECK FIX FOR ENFORCING CONSTRAINTS
;;; ======================================================================

; (SETQ *ERROR-REPORT-SILENT* T)  ; KM 2.1
(SETQ *ON-ERROR* 'IGNORE)	; KM 2.2
(SETQ *REMOVE-VIOLATING-INSTANCES* T)

(reset-kb)
(every Car has (parts ((exactly 0 Thing))))
(_C == (a Car))
(_W == (a Part))
(_C has (parts (_W)))
(not (the parts of _C)) ; constraint violation - deletes the value

;;; The test - check inverses are deleted by the "deletes the value" line!
(not (the parts-of of _W)) ; check inverse was deleted.



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

(reset-kb)
(every Car has (parts ((exactly 2 Part))))
(_C == (a Car))
(_W == (a Thing))
(_X == (a Part))
(_Y == (a Part))
(_Z == (a Part))
(_C has (parts (_W _X _Y _Z)))
(not (the parts of _C)) ; constraint violation - deletes the value
(showme _C)
(showme _Y)

;;; The test - check inverses are deleted by the "deletes the value" line!
(not (the parts-of of _Y)) ; check inverse was deleted.

(not (SETQ *ERROR-REPORT-SILENT* NIL))	; KM 2.1 put value back to how it was
(SETQ *ON-ERROR* 'DEBUG)		; KM 2.2
(not (SETQ *REMOVE-VIOLATING-INSTANCES* NIL))

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

;;; make sure that constraints-for triggers unification in of relevant prototypes HLO-2308 and HLO-2325

(reset-kb)
(a-prototype Human-Cell)
((the Human-Cell)  has (has-part ((exactly 46 Chromosome))))
(end-prototype)
((constraints-for (the has-part of (a Human-Cell))) = '(exactly 46 Chromosome))
(print "constraints2.km")

#|
Extracts from the UT component library.

This is slightly horrible.

The failing query was:
((the number of (the some-associated-collide of (a Car-Accident))) = 1)

where (the some-associated-collide of (a Car-Accident)) produces:

(  _Collide8:
    object: (_Tangible-Entity10 _Car11 _Tangible-Entity19)
 &&
  _Collide25:
    object: (_Tangible-Entity26)
)

and there's a constraint on object of (exactly 1 Thing).

Now the problem is, the old KM fails as there are three "estimated unifications",
because of the three values in object in _Collide8, which violates the constraint.

So this is changed now, so instead of (in constraints.lisp)
  (estimate-unifications '((_Tangible-Entity10 _Car11 _Tangible-Entity19) (_Tangible-Entity26)))

it does
  (estimate-unifications '((_Tangible-Entity10) (_Car11) (_Tangible-Entity19) (_Tangible-Entity26)))

which works.

Later, KM enforces the (exactly 1 Thing) rule to unify these things together.
|#

(every Break-Contact has
  ;; The agent is inherited from Action

  (object   ((exactly 1 Tangible-Entity)
	     (a Tangible-Entity)))

  (base     ((exactly 1 Tangible-Entity)
	     (a Tangible-Entity)))
)
(every Break has 
       (object ((a Tangible-Entity)))
       (resulting-state ((a Be-Broken)))
)

(every Make-Contact has
  (object       ((exactly 1 Tangible-Entity)
		 (a Tangible-Entity)))

  (base  	((exactly 1 Tangible-Entity)
		 (a Tangible-Entity)))

  (location  	(((a Place) & (the location of (the base of Self)))))

  (resulting-state ((a Be-Touching))))

(Collide has
  (superclasses   	(Make-Contact)))


(Car-Accident has (superclasses (Compound-Action)))
                          
(every Car-Accident has 
  (some-associated-collide ((((a Collide)) 
			     && 
			     ((a Collide with 
				(next-event ((the some-associated-break-contact of Self))))) 
			     && 
			     ((a Collide with 
				 (object ((a Tangible-Entity) (the some-associated-car2 of Self))))) 
			     && 
			     ((a Collide with 
				 (base ((a Tangible-Entity) 
					(the some-associated-light-pole of Self))))) 
			     && 
			     ((a Collide)) 
			     && 
			     ((a Collide with 
				 (next-event ((the some-associated-break-contact of Self))))) 
			     && 
			     ((a Collide with 
				 (object ((a Tangible-Entity) 
					  (the some-associated-car2 of Self))))) 
			     && 
			     ((a Collide with 
				 (base ((a Tangible-Entity) 
					(the some-associated-light-pole of Self))))) 
			     && 
			     (( ((a Collide)) 
				&& 
				((a Collide with 
				    (next-event ((the some-associated-break-contact of Self))))) 
				&& 
				((a Collide with 
				    (object ((a Tangible-Entity) 
					     (the some-associated-car2 of Self))))) 
				&& 
				((a Collide with 
				    (base ((a Tangible-Entity) 
					   (the some-associated-light-pole of Self))))))))))

  (some-associated-break ((((a Break)) 
			   && 
			   ((a Break with 
			       (next-event ((the some-associated-break-contact of Self))))) 
			   && 
			   ((a Break with 
			       (object ((a Tangible-Entity) 
					(the some-associated-car2 of Self))))) 
			   && 
			   ((a Break)) 
			   && 
			   ((a Break with 
			       (next-event ((the some-associated-break-contact of Self))))) 
			   && 
			   ((a Break with 
			       (object ((a Tangible-Entity) 
					(the some-associated-car2 of Self))))) 
			   && 
			   (( ((a Break)) 
			      && 
			      ((a Break with 
				  (next-event ((the some-associated-break-contact of Self))))) 
			      && 
			      ((a Break with 
				  (object ((a Tangible-Entity) 
					   (the some-associated-car2 of Self))))))))))

  (some-associated-break-contact 
      ((((a Break-Contact)) 
	&& 
	((a Break-Contact with 
	    (next-event ((the some-associated-carry of Self))))) 
	&& 
	((a Break-Contact with 
	    (base ((a Tangible-Entity) 
		   (the some-associated-light-pole of Self))))) 
	&& 
	((a Break-Contact with 
	    (object ((a Tangible-Entity) 
		     (the some-associated-car2 of Self))))) 
	&& 
	((a Break-Contact)) 
	&& 
	((a Break-Contact with 
	    (next-event ((the some-associated-carry of Self))))) 
	&& 
	((a Break-Contact with 
	    (base ((a Tangible-Entity) 
		   (the some-associated-light-pole of Self))))) 
	&& 
	((a Break-Contact with 
	    (object ((a Tangible-Entity) 
		     (the some-associated-car2 of Self))))) 
	&& 
	((((a Break-Contact)) 
	  && 
 	  ((a Break-Contact with 
	      (next-event ((the some-associated-carry of Self))))) 
	  && 
	  ((a Break-Contact with 
	      (base ((a Tangible-Entity) 
		     (the some-associated-light-pole of Self))))) 
	  && 
	  ((a Break-Contact with 
	      (object ((a Tangible-Entity) 
		       (the some-associated-car2 of Self))))))))))

  (some-associated-carry 
      ((((a Carry)) 
	&& 
	((a Carry with 
	    (next-event ((the some-associated-repair of Self))))) 
	&& 
	((a Carry with 
	    (object ((a Tangible-Entity) 
		     (the some-associated-car2 of Self))))) 
	&& 
	((a Carry with 
	    (agent ((a Tangible-Entity) 
		    (the some-associated-car of Self))))) 
	&& 
	((a Carry)) 
	&& 
	((a Carry with 
	    (next-event ((the some-associated-repair of Self))))) 
	&& 
	((a Carry with 
	    (object ((a Tangible-Entity) 
		     (the some-associated-car2 of Self))))) 
	&& 
	((a Carry with 
	    (agent ((a Tangible-Entity) 
		    (the some-associated-car of Self))))) 
	&& 
	((((a Carry)) 
	  && 
	  ((a Carry with 
	      (next-event ((the some-associated-repair of Self))))) 
	  && 
	  ((a Carry with 
	      (object ((a Tangible-Entity) 
		       (the some-associated-car2 of Self))))) 
	  && 
	  ((a Carry with 
	      (agent ((a Tangible-Entity) 
		      (the some-associated-car of Self))))))))))

  (some-associated-repair 
      ((((a Repair)) 
	&& 
	((a Repair)) 
	&& 
	((a Repair with 
	    (object ((a Tangible-Entity) 
		     (the some-associated-car2 of Self))))) 
	&& 
	((((a Repair)) 
	  && 
	  ((a Repair with 
	      (object ((a Tangible-Entity) 
		       (the some-associated-car2 of Self))))))))))

  (first-subevent 
      ((((the some-associated-collide of Self)) 
	&& 
	((a Collide) (the some-associated-break of Self)) 
	&& 
	((the some-associated-collide of Self)) 
	&& 
	((a Collide) (the some-associated-break of Self)) 
	&& 
	((((the some-associated-collide of Self)) 
	  && 
	  ((a Collide) (the some-associated-break of Self)))))))
                            
 
  (some-associated-car 
      ((((a Car)) 
	&& 
	((the first of (the agent of (the some-associated-carry of Self)))) 
	&& 
	((a Car)) 
	&& 
	((the first of (the agent of (the some-associated-carry of Self)))) 
	&& 
	((((a Car)) 
	  && 
	  ((the first of (the agent of (the some-associated-carry of Self)))))))))
                            
  (some-associated-car2 
      ((((a Car)) 
	&& 
	((the first of (the object of (the some-associated-break of Self)))) 
	&& 
	((the first of (the object of (the some-associated-carry of Self)))) 
	&& 
	((a Car)) 
	&& 
	((the first of (the object of (the some-associated-break of Self)))) 
	&& 
	((the first of (the object of (the some-associated-carry of Self)))) 
	&& 
	((the first of (the object of (the some-associated-repair of Self)))) 
	&& 
	((((a Car)) 
	  && 
	  ((the first of (the object of (the some-associated-break of Self)))) 
	  && 
	  ((the first of (the object of (the some-associated-carry of Self)))) 
	  && 
	  ((the first of (the object of (the some-associated-repair of Self)))))))))
                            
  (some-associated-light-pole ((a Light-Pole)))
                            
  (subevent ((  ((the some-associated-collide of Self)) 
		&& 
		((a Collide) (the some-associated-break of Self)) 
		&& 
		((a Collide) (a Break) (the some-associated-break-contact of Self)) 
		&& 
		((a Collide) (a Break) (a Break-Contact) (the some-associated-carry of Self)) 	
		&& 
		((a Collide) (a Break) (a Break-Contact) (a Carry) (the some-associated-repair of Self)) 
		&& 
		((((the some-associated-collide of Self)) 
		  && 
		  ((a Collide) (the some-associated-break of Self)) 
		  && 
		  ((a Collide) (a Break) (the some-associated-break-contact of Self)) 
		  && 
		  ((a Collide) (a Break) (a Break-Contact) (the some-associated-carry of Self)) 
		  && 
		  ((a Collide) (a Break) (a Break-Contact) (a Carry) (the some-associated-repair of Self)))))))
                             
  (base ((the some-associated-light-pole of Self)))
  (object ((the some-associated-car2 of Self)))
  (agent ((the some-associated-car of Self))))
                          

((the number of (the some-associated-collide of (a Car-Accident))) = 1)

(print "darpa.km")

;;; File: darpa.km
;;; Author: Bruce Porter, modified by Pete 
;;; Date: March 1999
;;; Purpose: This is a test of the situations mechanism in KM, based on a 
;;;     simuation of a simple aspect of battlefield management. 
;;;     It tests these things: creating situations, projecting values
;;;     between situations, inheriting properties from *global, do-and-next
;;;     and do-script.
;;;
;;; The test queries are at the end of this file, and they're evaluated 
;;; when you load the file.  If the load completes with no ERROR's or 
;;; WARNING's, then all the queries succeeded.
;;;
;;; ======================================================================
;;;                     *Global situation
;;; ======================================================================

(reset-kb)

;;; VERSION 1: Efficient, where we assume non-fluents
(default-fluent-status *Non-Fluent)

(FO has (superclasses (Opfac Agent StateMachine)))

;; For now, I'll assume that every FO is in a WR_FFE mission
(every FO has
   (agent-of (*WR_FFE))
   (node ((a FO_start) (a FO_n1) (a FO_n2) 
	  (a FO_n3) (a FO_n4) (a FO_stop)))
   (edge ((a FO_e1) ; with (edge-of ((Self))))
	  (a FO_e2) ; with (edge-of ((Self))))
	  (a FO_e3) ; with (edge-of ((Self))))
	  (a FO_e4) ; with (edge-of ((Self))))
	  (a FO_e5) ; with (edge-of ((Self))))
	  (a FO_e6) ; with (edge-of ((Self))))
	  (a FO_e7) ; with (edge-of ((Self))))
	  )))


(FO_start has (superclasses (Node)))
(FO_n1 has    (superclasses (Node)))
(FO_n2 has    (superclasses (Node)))
(FO_n3 has    (superclasses (Node)))
(FO_n4 has    (superclasses (Node)))
(FO_stop has  (superclasses (Node)))

(FO_e1 has (superclasses (Edge)))
(FO_e2 has (superclasses (Edge)))
(FO_e3 has (superclasses (Edge)))
(FO_e4 has (superclasses (Edge)))
(FO_e5 has (superclasses (Edge)))
(FO_e6 has (superclasses (Edge)))
(FO_e7 has (superclasses (Edge)))
(FO_e8 has (superclasses (Edge)))

(every FO_e1 has 
   (from ((the FO_start node of (the edge-of of Self)))) 
   (to   ((the FO_n1    node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *initialize)
	      then *true)))
;;   would prefer to say:
;;   (test ((the messages-received of (the edge-of of Self))
;;	  includes 
;;	  (*initialize)))
   (action ((a Send with 
	       (message (*initialize))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Opfac
                            (the edge-of of Self)  ;; -> FO
			    ))))))))

(every FO_e2 has 
   (from ((the FO_n1 node of (the edge-of of Self)))) 
   (to   ((the FO_n2 node of (the edge-of of Self))))
   (test ((the accept-mission of (the edge-of of Self))))
   (action ()))

(every FO_e3 has 
   (from ((the FO_n1   node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((not (the accept-mission of (the edge-of of Self)))))
   (action ()))

(every FO_e4 has 
   (from ((the FO_n2 node of (the edge-of of Self)))) 
   (to   ((the FO_n3 node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *shot)
	      then *true)))
   (action ()))

(every FO_e5 has 
   (from ((the FO_n3 node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *roundsComplete)
	      then *true)))
   (action ((a Send with 
	       (message (*eom))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Opfac
                            (the edge-of of Self)  ;; -> FO
			    ))))))))

(every FO_e6 has 
   (from ((the FO_n3 node of (the edge-of of Self)))) 
   (to   ((the FO_n4 node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *splash)
	      then *true)))
   (action ()))

(every FO_e7 has 
   (from ((the FO_n4 node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *roundsComplete)
	      then *true)))
   (action ((a Send with 
	       (message (*eom))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Mission
                            (the edge-of of Self)  ;; -> FO
			    ))))))))


(every FO has
   (accept-mission (*true))) ;;; stubbing out the reasoning that goes here

;; the messages sent/received by FO's
(*initialize has (instance-of (Message)))
(*eom        has (instance-of (Message)))
(*shot       has (instance-of (Message)))
(*splash     has (instance-of (Message)))
(*roundsComplete 
             has (instance-of (Message)))

(Send has (superclasses (Event)))
(every Send has
   (message ((a Message)))
   (sender ((a Agent)))
   (receiver ((a Agent)))
   (add-list ((:triple
	       (the receiver of Self)
	       messages-received
	       (the message of Self)))))

(message has
   (instance-of (Slot))
   (domain (Send))
   (range (Message))
;  (cardinality (1-to-1))		**** MAJOR ERROR!! ***
   (cardinality (N-to-1))
   (inverse ()))

(sender has
   (instance-of (Slot))
   (domain (Send))
   (range (Agent))
;  (cardinality (1-to-1))		*** MAJOR ERROR!! ***
   (cardinality (N-to-1))
   (inverse (sender-of)))

(receiver has
   (instance-of (Slot))
   (domain (Send))
   (range (Agent))
   (cardinality (1-to-N))
   (inverse (receiver-of)))

(messages-received has
   (instance-of (Slot))
   (domain (Agent))
   (range (Message))  
   (cardinality (1-to-N))
   (fluent-status (*Inertial-Fluent))
   (inverse ()))

(currentState has 
   (instance-of (Slot)) 
   (fluent-status (*Inertial-Fluent)))

(actions has 
	(instance-of (Slot)) 
	(fluent-status (*Fluent)))
;	(complete (t)))			; <-- better put this here! Or else the same tick produces different actions in different situations, 
					;     which will then all be projected and unified together!
(text has (instance-of (Slot)) (fluent-status (*Inertial-Fluent)))

(Message has (superclasses (Thing)))
(*initialize has (instance-of (Message)))

(every Send has
   (text ((Send sender) "sends the message" (Send message) "to" 
          (Send receiver))))


(Agent has (superclasses (Thing)))
(Opfac has (superclasses (Agent)))

(talks-to has
   (instance-of (Slot))
   (domain (Agent))
   (range (Agent))
   (cardinality (N-to-N))
   (inverse (talks-to)))

(messages-received has
   (instance-of (Slot))
   (domain (Agent))
   (range (Message))  
   (cardinality (1-to-N))
   (inverse ()))

(Message has (superclasses (Thing)))

(every Agent has
   (text ((the name of (Self)) "is engaged in" (the name of (Self agent-of))
	  ", and has received the messages:" (Self messages-received)
	  ".  ")))


(StateMachine has (superclasses (DirectedGraph)))
(every StateMachine has
   (currentState ())
   (initialState ())
   (terminalState ())
   (possible-transitions 
    ((allof (the from-of of (the currentState of Self))
	    where
	    ((the test of It) = *true))))
   (best-transition ((the first of (the possible-transitions of Self)))))
		     
;;; In the future, we might want to select the best-transition in this way: 
;;;   (best-transition ((oneof (the possible-transitions of Self)
;;;                      where ((the rank of It) =
;;;                             (the max of (the rank of
;;;                                (the possible-transitions of Self)))))))
;;; ie. pick (one of) the highest ranking ones.

(Tick has (superclasses (Script)))
(every Tick has
   (patient ())
   (actions ((if (has-value (the best-transition of (the patient of Self))) then
		 (:set
		  (the action of 
		       (the best-transition of (the patient of Self)))
		  (a State-Change-Event with 
			(patient ((the patient of Self)))))))))

(State-Change-Event has (superclasses (Event)))
(every State-Change-Event has
		        (del-list ((:triple (the patient of Self)
					 currentState 
					 (the currentState of 
					      (the patient of Self)))))
		        (add-list ((:triple (the patient of Self)
					 currentState
					 (the to of (the best-transition of
							 (the patient of
							      Self)))))))

#|
======================================================================
5.3.00 - ABOVE: I had to reify State-Change-Event, so that add-list gets passed to
instances of State-Change-Event. This is to overcome an incompleteness with reasoning:
Another incompleteness, with projection:

*Global:
	(every C1 has
	  (s ((a C2 with
		(s' ((a C3)))))))

AND s' is a *non-inertial* fluent. Now create (a C1) in Situation1:

	Situation1: -->	Situation2:

	I1		I2
	--		--
	 s: I2		  s': nothing!!
	    --
	     s': I3

Although KM correctly doesn't project I3,  it also doesn't realize that
the "embedded rule" on s', declared in *Global, for this instance of C2, still applies. 
Normally, we don't care -- we just apply the rule once, and then we can get rid of the
rule. But here, as the results vary with situation, we don't want to lose the rule,
rather we want to re-apply it.

This can be solved by reformulating the general rule as:
	(every C1 has
	  (s ((a SpecC2))))

	(every SpecC2 has
	  (s' ((a C3))))

Also, if we asked for (the s' of (the s of I1)) in Situation2, KM would compute
an answer as it would then realize the embedded rule applies.

======================================================================
|#



(possible-transitions has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Edge))
   (cardinality (1-to-N))
   (fluent-status (*Fluent)))

(best-transition has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Edge))
   (cardinality (1-to-1))
   (fluent-status (*Fluent)))

(currentState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-1))
   (inverse (currentState-of))
   (superslots (node)))

(initialState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-1))
   (inverse (initialState-of))
   (superslots (node)))

(terminalState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-N))
   (inverse (terminalState-of))
   (superslots (node)))

;;; some extra slots that edges of StateMachines might have

(test has
   (instance-of (Slot))
   (domain (Edge))
   (range (Thing)) ;; should be "booleanExpression"
   (cardinality (1-to-1))
   (inverse ())
   (fluent-status (*Fluent)))                 ;; Do NOT project values from 
                                   ;; previous situations - recompute them!

(action has
   (instance-of (Slot))
   (domain (Edge))
   (range (Event))
   (cardinality (1-to-1))
   (inverse (action-of))
   (fluent-status (*Fluent)))                 ;; Do NOT project values from 
                                   ;; previous situations - recompute them!

;;; Text Generation 
(every StateMachine has
   (text ((the name of (Self)) "is in state" 
	  (the name of (Self currentState))
	  ", and the possible next states are" 
	  (the name of (Self possible-transitions)))))

;;; ======================================================================
;;;			FILE: directedGraph.km
;;; ======================================================================
#|
		=========================
		ONTOLOGY: Directed Graphs
		=========================

Introduction:
This structural representation can be used to denote many things, such
as connectivity in circuits, supply/demand chains, etc. It is a 
domain-independent model skeleton which we can map onto particular problems 
of interest in various ways. Here we describe some of the basic graph
properties.

Bruce Porter, February 1999
|#

#| NAMESPACE
OBJECTS: 
	DirectedGraph
	Node
        Edge
RELATIONS: 
        node
        edge
	from
	to
	reachable-from
	reaches
|#




(node has
  (instance-of (Slot))
  (domain (DirectedGraph))
  (range (Node))
  (cardinality (1-to-N))
  (inverse (node-of)))

(edge has
  (instance-of (Slot))
  (domain (DirectedGraph))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (edge-of)))

(from has
  (instance-of (Slot))
  (domain (Edge))
  (range (Node))
  (cardinality (1-to-1))
  (inverse (from-of)))

(from-of has
  (instance-of (Slot))
  (domain (Node))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (from)))

(to has
  (instance-of (Slot))
  (domain (Edge))
  (range (Node))
  (cardinality (1-to-1))
  (inverse (to-of)))

(to-of has
  (instance-of (Slot))
  (domain (Node))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (to)))

(reaches has
  (instance-of (Slot))
  (domain (Node))
  (range (Node))
  (fluent-status (*Fluent))
  (cardinality (1-to-N))
  (inverse (reachable-from)))

(reachable-from has
  (instance-of (Slot))
  (cardinality (1-to-N))   
  (fluent-status (*Fluent)))

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

#| 
Now we can define some relationships `of interest', ie. which have a 
reasonable chance of mapping onto some useful domain-specific concept.
From this menu we can pick and choose which ones we want to employ, and
ignore (not load) the rest.
|#

;;; ======================================================================
;;; 		REACHABILITY
;;; Reachability just returns nodes (not arcs).
;;; ======================================================================

(every Node has
  (reachable-from ((Self to-of * from) (Self to-of * from * reachable-from)))
  (reaches ((Self from-of * to) (Self from-of * to * reaches))))

;;;used to be: (reaches ((Self to) (Self to * reaches))))

;;; ======================================================================

;;; We can reify the concept of a DirectedGraph itself, even though we
;;; haven't much to say about it.  Every DirectedGraph has node(s), but 
;;; not necessarily edges

(every DirectedGraph has
  (node ()))

;;; ======================================================================

#|
;;;DEMO/TEST:
A --a1--> B --a2 --> C --a5 -\
       	    \-a3 --> D --a4 --> E


;; KB
(a DirectedGraph with
   (node (A B C D E))
   (edge (a1 a2 a3 a4 a5)))

(A has (instance-of (Node)))
(B has (instance-of (Node)))
(C has (instance-of (Node)))
(D has (instance-of (Node)))
(E has (instance-of (Node)))

(a1 has (instance-of (Edge)) (from (A)) (to (B)))
(a2 has (instance-of (Edge)) (from (B)) (to (C)))
(a3 has (instance-of (Edge)) (from (B)) (to (D)))
(a4 has (instance-of (Edge)) (from (D)) (to (E)))
(a5 has (instance-of (Edge)) (from (C)) (to (E)))

;; Tests...
;;KM> (A reaches)
;;(B C D E)
;;KM> (D reachable-from)
;;(A B)
|#


(Mission has (superclasses (Thing)))

(every Mission has           ;;; for now, there's only one type of Mission
   (objectives (*when-ready-fire-for-effect-mortars))
   (opfac ((a FSE with
	      (opfac-of ((Self)))
	      (talks-to ((the FIST opfac of Self)
			 (the MTR opfac of Self))))
	   (a FIST with
	      (opfac-of ((Self)))
	      (talks-to ((the FO opfac of Self)
			 (the FSE opfac of Self))))
	   (a FO with
	      (opfac-of ((Self)))
	      (talks-to ((the FIST opfac of Self))))
	   (a MTR with
	      (opfac-of ((Self)))
	      (talks-to ((the FSE opfac of Self)))))))

(objectives has
   (instance-of (Slot))
   (domain (Mission))
   (range (Objective))
   (cardinality (1-to-N))
   (inverse (objective-of)))

(opfac has
   (instance-of (Slot))
   (domain (Mission))
   (range (Opfac))
   (cardinality (1-to-N))
   (inverse (opfac-of)))


(*When-ready-fire-for-effect-mortars has (instance-of (Objectives)))
(*When-ready-fire-for-effect-mortars has
   (text ("When Ready Fire for Effect - Mortars")))



(Objectives has (superclasses (Thing)))

(every Mission has
   (text ((the name of (Self)) "has opfacs" (the name of (Self opfac))
	  ", with the objective" (the name of (Self objectives)))))




;;; An example to TEST everything
;(watchon)

#|
(from has (complete (t)))
(from-of has (complete (t)))
(edge has (complete (t)))
(edge-of has (complete (t)))
(opfac has (complete (t)))
(opfac-of has (complete (t)))
(node has (complete (t)))
|#

(global-situation)
;NEW  (new-situation)

(a Mission)
;(the opfac of (thelast Mission))
(the FO opfac of (thelast Mission))
;(the edge of (thelast FO))
;(the node of (thelast FO))
(the from of (the edge of (thelast FO)))
(the to of (the edge of (thelast FO)))

(Initialize has (superclasses (Event)))
; Now go into a situation
(new-situation)

(do-and-next ((a Initialize with
	       (patient ((the FO opfac of (thelast Mission))))
	       (del-list ())
	       (add-list ((:triple (the patient of Self)
				   currentState
				   (the FO_start node of 
					(the patient of Self))))))))

; (the currentState of (thelast FO)) 			; PEC
((the currentState of (thelast FO)) isa FO_start)	; PEC

(do-and-next ((a Send with (message (*initialize))
                         (receiver ((thelast FO))))))

((the currentState of (thelast FO)) isa FO_start)	; PEC
(the FO opfac of (thelast Mission))

;;; The enxt command creates a new Sends, which is unified with the first send.
(do-script (a Tick with (patient ((thelast FO)))))

;; should now be in state n1
((the currentState of (thelast FO))  isa FO_n1)		; PEC

;;; The next command causes the problem...

(do-script (a Tick with (patient ((thelast FO)))))
; (the currentState of (thelast FO)) 
;(trace)

((the currentState of (thelast FO))  isa FO_n2)		; PEC

;; should now be in state n2

;;(do-script (a Tick with (patient ((thelast FO))))) ;; --> should FAIL (below)
(not (do-script (a Tick with (patient ((thelast FO))))))

(do-and-next ((a Send with (message (*shot))
                         (receiver ((thelast FO))))))
(do-script (a Tick with (patient ((thelast FO)))))

;; should now be in state n3
;(the currentState of (thelast FO)) 
((the currentState of (thelast FO))  isa FO_n3)		; PEC

(do-and-next ((a Send with (message (*splash))
                         (receiver ((thelast FO))))))
(do-script (a Tick with (patient ((thelast FO)))))
(the currentState of (thelast FO)) 
;; should now be in state n4

(do-and-next ((a Send with (message (*roundsComplete))
                         (receiver ((thelast FO))))))
(do-script (a Tick with (patient ((thelast FO)))))

((the currentState of (thelast FO)) isa FO_stop) 
;; should return (t) 

(print "darpa2.km")

;;; File: darpa2.km
;;; Author: Bruce Porter, modified by Pete 
;;; Date: March 1999
;;; Purpose: This is a test of the situations mechanism in KM, based on a 
;;;     simuation of a simple aspect of battlefield management. 
;;;     It tests these things: creating situations, projecting values
;;;     between situations, inheriting properties from *global, do-and-next
;;;     and do-script.
;;;
;;; The test queries are at the end of this file, and they're evaluated 
;;; when you load the file.  If the load completes with no ERROR's or 
;;; WARNING's, then all the queries succeeded.
;;;
;;; ======================================================================
;;;                     *Global situation
;;; ======================================================================

(reset-kb)

(opfac has
   (instance-of (Slot))
   (domain (Mission))
   (range (Opfac))
   (cardinality (1-to-N))
   (inverse (opfac-of)))


;;; VERSION 2: Remove the efficiency - it should still work though
(default-fluent-status *Inertial-Fluent)

(FO has (superclasses (Opfac Agent StateMachine)))

;; For now, I'll assume that every FO is in a WR_FFE mission
(every FO has
   (agent-of (*WR_FFE))
   (node ((a FO_start) (a FO_n1) (a FO_n2) 
	  (a FO_n3) (a FO_n4) (a FO_stop)))
   (edge ((a FO_e1) ; with (edge-of ((Self))))
	  (a FO_e2) ; with (edge-of ((Self))))
	  (a FO_e3) ; with (edge-of ((Self))))
	  (a FO_e4) ; with (edge-of ((Self))))
	  (a FO_e5) ; with (edge-of ((Self))))
	  (a FO_e6) ; with (edge-of ((Self))))
	  (a FO_e7) ; with (edge-of ((Self))))
	  )))


(FO_start has (superclasses (Node)))
(FO_n1 has    (superclasses (Node)))
(FO_n2 has    (superclasses (Node)))
(FO_n3 has    (superclasses (Node)))
(FO_n4 has    (superclasses (Node)))
(FO_stop has  (superclasses (Node)))

(FO_e1 has (superclasses (Edge)))
(FO_e2 has (superclasses (Edge)))
(FO_e3 has (superclasses (Edge)))
(FO_e4 has (superclasses (Edge)))
(FO_e5 has (superclasses (Edge)))
(FO_e6 has (superclasses (Edge)))
(FO_e7 has (superclasses (Edge)))
(FO_e8 has (superclasses (Edge)))

(every FO_e1 has 
   (from ((the FO_start node of (the edge-of of Self)))) 
   (to   ((the FO_n1    node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *initialize)
	      then *true)))
;;   would prefer to say:
;;   (test ((the messages-received of (the edge-of of Self))
;;	  includes 
;;	  (*initialize)))
   (action ((a Send with 
	       (message (*initialize))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Opfac
                            (the edge-of of Self)  ;; -> FO
			    ))))))))

(every FO_e2 has 
   (from ((the FO_n1 node of (the edge-of of Self)))) 
   (to   ((the FO_n2 node of (the edge-of of Self))))
   (test ((the accept-mission of (the edge-of of Self))))
   (action ()))

(every FO_e3 has 
   (from ((the FO_n1   node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((not (the accept-mission of (the edge-of of Self)))))
   (action ()))

(every FO_e4 has 
   (from ((the FO_n2 node of (the edge-of of Self)))) 
   (to   ((the FO_n3 node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *shot)
	      then *true)))
   (action ()))

(every FO_e5 has 
   (from ((the FO_n3 node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *roundsComplete)
	      then *true)))
   (action ((a Send with 
	       (message (*eom))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Opfac
                            (the edge-of of Self)  ;; -> FO
			    ))))))))

(every FO_e6 has 
   (from ((the FO_n3 node of (the edge-of of Self)))) 
   (to   ((the FO_n4 node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *splash)
	      then *true)))
   (action ()))

(every FO_e7 has 
   (from ((the FO_n4 node of (the edge-of of Self)))) 
   (to   ((the FO_stop node of (the edge-of of Self))))
   (test ((if ((the messages-received of (the edge-of of Self))
	       includes *roundsComplete)
	      then *true)))
   (action ((a Send with 
	       (message (*eom))
	       (receiver ((the FIST talks-to of    ;;   -> FIST
                           (the opfac-of of        ;;  -> Mission
                            (the edge-of of Self)  ;; -> FO
			    ))))))))


(every FO has
   (accept-mission (*true))) ;;; stubbing out the reasoning that goes here

;; the messages sent/received by FO's
(*initialize has (instance-of (Message)))
(*eom        has (instance-of (Message)))
(*shot       has (instance-of (Message)))
(*splash     has (instance-of (Message)))
(*roundsComplete 
             has (instance-of (Message)))

(Send has (superclasses (Event)))
(every Send has
   (message ((a Message)))
   (sender ((a Agent)))
   (receiver ((a Agent)))
   (add-list ((:triple
	       (the receiver of Self)
	       messages-received
	       (the message of Self)))))

(message has
   (instance-of (Slot))
   (domain (Send))
   (range (Message))
;  (cardinality (1-to-1))		**** MAJOR ERROR!! ***
   (cardinality (N-to-1))
   (inverse ()))

(sender has
   (instance-of (Slot))
   (domain (Send))
   (range (Agent))
;  (cardinality (1-to-1))		*** MAJOR ERROR!! ***
   (cardinality (N-to-1))
   (inverse (sender-of)))

;;; Without [2], [1] says that an action can have multiple receivers, but a person
;;; will only be the receiver of a single action. But in different situations, the
;;; same person may be the receiver in different actions -- and if projection is
;;; allowed (fluent-status = *Inertial-Fluent, the default) then all those different
;;; actions will be incorrectly unified!
;;; To deliverately test this possible error, I provoked it by the call marked 
;;; [ISSUE] later.
(receiver has
   (instance-of (Slot))
   (domain (Send))
   (range (Agent))
;   (cardinality (1-to-N))			; [1]
   (cardinality (N-to-1))			; [1] this is what was intended
   (fluent-status (*Fluent))			; [2]
   (inverse (receiver-of)))

;;; [1] An edge can receive many messages, but a message will be recieved by at
;;; most one edge. Ok.
(messages-received has
   (instance-of (Slot))
   (domain (Agent))
   (range (Message))  
   (cardinality (1-to-N))			; [1]
   (fluent-status (*Inertial-Fluent))
   (inverse ()))

(currentState has 
   (instance-of (Slot)) 
   (fluent-status (*Inertial-Fluent)))

(actions has 
	(instance-of (Slot)) 
	(fluent-status (*Fluent)))
;	(complete (t)))			; <-- better put this here! Or else the same tick produces different actions in different situations, 
					;     which will then all be projected and unified together!
(text has (instance-of (Slot)) (fluent-status (*Inertial-Fluent)))

(Message has (superclasses (Thing)))
(*initialize has (instance-of (Message)))

(every Send has
   (text ((Send sender) "sends the message" (Send message) "to" 
          (Send receiver))))


(Agent has (superclasses (Thing)))
(Opfac has (superclasses (Agent)))

(talks-to has
   (instance-of (Slot))
   (domain (Agent))
   (range (Agent))
   (cardinality (N-to-N))
   (inverse (talks-to)))

(Message has (superclasses (Thing)))

(every Agent has
   (text ((the name of (Self)) "is engaged in" (the name of (Self agent-of))
	  ", and has received the messages:" (Self messages-received)
	  ".  ")))


(StateMachine has (superclasses (DirectedGraph)))
(every StateMachine has
   (currentState ())
   (initialState ())
   (terminalState ())
   (possible-transitions 
    ((allof (the from-of of (the currentState of Self))
	    where
	    ((the test of It) = *true))))
   (best-transition ((the first of (the possible-transitions of Self)))))
		     
;;; In the future, we might want to select the best-transition in this way: 
;;;   (best-transition ((oneof (the possible-transitions of Self)
;;;                      where ((the rank of It) =
;;;                             (the max of (the rank of
;;;                                (the possible-transitions of Self)))))))
;;; ie. pick (one of) the highest ranking ones.

(Tick has (superclasses (Script)))
(every Tick has
   (patient ())
   (actions ((if (has-value (the best-transition of (the patient of Self))) then
		 (:set
		  (the action of 
		       (the best-transition of (the patient of Self)))
		  (a State-Change-Event with 
			(patient ((the patient of Self)))))))))

(State-Change-Event has (superclasses (Event)))
(every State-Change-Event has
		        (del-list ((:triple (the patient of Self)
					 currentState 
					 (the currentState of 
					      (the patient of Self)))))
		        (add-list ((:triple (the patient of Self)
					 currentState
					 (the to of (the best-transition of
							 (the patient of
							      Self)))))))

#|
======================================================================
5.3.00 - ABOVE: I had to reify State-Change-Event, so that add-list gets passed to
instances of State-Change-Event. This is to overcome an incompleteness with reasoning:
Another incompleteness, with projection:

*Global:
	(every C1 has
	  (s ((a C2 with
		(s' ((a C3)))))))

AND s' is a *non-inertial* fluent. Now create (a C1) in Situation1:

	Situation1: -->	Situation2:

	I1		I2
	--		--
	 s: I2		  s': nothing!!
	    --
	     s': I3

Although KM correctly doesn't project I3,  it also doesn't realize that
the "embedded rule" on s', declared in *Global, for this instance of C2, still applies. 
Normally, we don't care -- we just apply the rule once, and then we can get rid of the
rule. But here, as the results vary with situation, we don't want to lose the rule,
rather we want to re-apply it.

This can be solved by reformulating the general rule as:
	(every C1 has
	  (s ((a SpecC2))))

	(every SpecC2 has
	  (s' ((a C3))))

Also, if we asked for (the s' of (the s of I1)) in Situation2, KM would compute
an answer as it would then realize the embedded rule applies.

======================================================================
|#



(possible-transitions has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Edge))
   (cardinality (1-to-N))
   (fluent-status (*Fluent)))

(best-transition has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Edge))
   (cardinality (1-to-1))
   (fluent-status (*Fluent)))

(currentState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-1))
   (inverse (currentState-of))
   (superslots (node)))

(initialState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-1))
   (inverse (initialState-of))
   (superslots (node)))

(terminalState has
   (instance-of (Slot))
   (domain (StateMachine))
   (range (Node))
   (cardinality (1-to-N))
   (inverse (terminalState-of))
   (superslots (node)))

;;; some extra slots that edges of StateMachines might have

(test has
   (instance-of (Slot))
   (domain (Edge))
   (range (Thing)) ;; should be "booleanExpression"
   (cardinality (1-to-1))
   (inverse ())
   (fluent-status (*Fluent)))                 ;; Do NOT project values from 
                                   ;; previous situations - recompute them!

(action has
   (instance-of (Slot))
   (domain (Edge))
   (range (Event))
   (cardinality (1-to-1))
   (inverse (action-of))
   (fluent-status (*Fluent)))                 ;; Do NOT project values from 
                                   ;; previous situations - recompute them!

;;; Text Generation 
(every StateMachine has
   (text ((the name of (Self)) "is in state" 
	  (the name of (Self currentState))
	  ", and the possible next states are" 
	  (the name of (Self possible-transitions)))))

;;; ======================================================================
;;;			FILE: directedGraph.km
;;; ======================================================================
#|
		=========================
		ONTOLOGY: Directed Graphs
		=========================

Introduction:
This structural representation can be used to denote many things, such
as connectivity in circuits, supply/demand chains, etc. It is a 
domain-independent model skeleton which we can map onto particular problems 
of interest in various ways. Here we describe some of the basic graph
properties.

Bruce Porter, February 1999
|#

#| NAMESPACE
OBJECTS: 
	DirectedGraph
	Node
        Edge
RELATIONS: 
        node
        edge
	from
	to
	reachable-from
	reaches
|#




(node has
  (instance-of (Slot))
  (domain (DirectedGraph))
  (range (Node))
  (cardinality (1-to-N))
  (inverse (node-of)))

(edge has
  (instance-of (Slot))
  (domain (DirectedGraph))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (edge-of)))

(from has
  (instance-of (Slot))
  (domain (Edge))
  (range (Node))
  (cardinality (1-to-1))
  (inverse (from-of)))

(from-of has
  (instance-of (Slot))
  (domain (Node))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (from)))

(to has
  (instance-of (Slot))
  (domain (Edge))
  (range (Node))
  (cardinality (1-to-1))
  (inverse (to-of)))

(to-of has
  (instance-of (Slot))
  (domain (Node))
  (range (Edge))
  (cardinality (1-to-N))
  (inverse (to)))

(reaches has
  (instance-of (Slot))
  (domain (Node))
  (range (Node))
  (fluent-status (*Fluent))
  (cardinality (1-to-N))
  (inverse (reachable-from)))

(reachable-from has
  (instance-of (Slot))
  (cardinality (1-to-N))   
  (fluent-status (*Fluent)))

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

#| 
Now we can define some relationships `of interest', ie. which have a 
reasonable chance of mapping onto some useful domain-specific concept.
From this menu we can pick and choose which ones we want to employ, and
ignore (not load) the rest.
|#

;;; ======================================================================
;;; 		REACHABILITY
;;; Reachability just returns nodes (not arcs).
;;; ======================================================================

(every Node has
  (reachable-from ((Self to-of * from) (Self to-of * from * reachable-from)))
  (reaches ((Self from-of * to) (Self from-of * to * reaches))))

;;;used to be: (reaches ((Self to) (Self to * reaches))))

;;; ======================================================================

;;; We can reify the concept of a DirectedGraph itself, even though we
;;; haven't much to say about it.  Every DirectedGraph has node(s), but 
;;; not necessarily edges

(every DirectedGraph has
  (node ()))

;;; ======================================================================

#|
;;;DEMO/TEST:
A --a1--> B --a2 --> C --a5 -\
       	    \-a3 --> D --a4 --> E


;; KB
(a DirectedGraph with
   (node (A B C D E))
   (edge (a1 a2 a3 a4 a5)))

(A has (instance-of (Node)))
(B has (instance-of (Node)))
(C has (instance-of (Node)))
(D has (instance-of (Node)))
(E has (instance-of (Node)))

(a1 has (instance-of (Edge)) (from (A)) (to (B)))
(a2 has (instance-of (Edge)) (from (B)) (to (C)))
(a3 has (instance-of (Edge)) (from (B)) (to (D)))
(a4 has (instance-of (Edge)) (from (D)) (to (E)))
(a5 has (instance-of (Edge)) (from (C)) (to (E)))

;; Tests...
;;KM> (A reaches)
;;(B C D E)
;;KM> (D reachable-from)
;;(A B)
|#


(Mission has (superclasses (Thing)))

(every Mission has           ;;; for now, there's only one type of Mission
   (objectives (*when-ready-fire-for-effect-mortars))
   (opfac ((a FSE with
	      (opfac-of ((Self)))
	      (talks-to ((the FIST opfac of Self)
			 (the MTR opfac of Self))))
	   (a FIST with
	      (opfac-of ((Self)))
	      (talks-to ((the FO opfac of Self)
			 (the FSE opfac of Self))))
	   (a FO with
	      (opfac-of ((Self)))
	      (talks-to ((the FIST opfac of Self))))
	   (a MTR with
	      (opfac-of ((Self)))
	      (talks-to ((the FSE opfac of Self)))))))

(objectives has
   (instance-of (Slot))
   (domain (Mission))
   (range (Objective))
   (cardinality (1-to-N))
   (inverse (objective-of)))

(*When-ready-fire-for-effect-mortars has (instance-of (Objectives)))
(*When-ready-fire-for-effect-mortars has
   (text ("When Ready Fire for Effect - Mortars")))



(Objectives has (superclasses (Thing)))

(every Mission has
   (text ((the name of (Self)) "has opfacs" (the name of (Self opfac))
	  ", with the objective" (the name of (Self objectives)))))




;;; An example to TEST everything
;(watchon)

#|
(from has (complete (t)))
(from-of has (complete (t)))
(edge has (complete (t)))
(edge-of has (complete (t)))
(opfac has (complete (t)))
(opfac-of has (complete (t)))
(node has (complete (t)))
|#

(global-situation)
;NEW  (new-situation)

(a Mission)
;(the opfac of (thelast Mission))
(the FO opfac of (thelast Mission))
;(the edge of (thelast FO))
;(the node of (thelast FO))
(the from of (the edge of (thelast FO)))
(the to of (the edge of (thelast FO)))

(Initialize has (superclasses (Event)))
; Now go into a situation
(new-situation)

(do-and-next ((a Initialize with
	       (patient ((the FO opfac of (thelast Mission))))
	       (del-list ())
	       (add-list ((:triple (the patient of Self)
				   currentState
				   (the FO_start node of 
					(the patient of Self))))))))

; (the currentState of (thelast FO)) 			; PEC
((the currentState of (thelast FO)) isa FO_start)	; PEC

(do-and-next (a Send with (message (*initialize))
             (receiver ((thelast FO)))))

((the currentState of (thelast FO)) isa FO_start)	; PEC
(the FO opfac of (thelast Mission))

;;; The enxt command creates a new Sends, which is unified with the first send.
(do-script (a Tick with (patient ((thelast FO)))))

;; should now be in state n1
((the currentState of (thelast FO))  isa FO_n1)		; PEC

;;; The next command causes the problem...

(do-script (a Tick with (patient ((thelast FO)))))
; (the currentState of (thelast FO)) 
;(trace)

((the currentState of (thelast FO))  isa FO_n2)		; PEC

;; should now be in state n2

;;(do-script (a Tick with (patient ((thelast FO))))) ;; --> should FAIL (below)
(not (do-script (a Tick with (patient ((thelast FO))))))

;;; [ISSUE] This rather weird call below is to deliberately provoke and
;;; test for a possible error which occurred in earlier versions of this KB.
;;; It should be innocuuous, but it provokes constraint-checking on (thelast FO),
;;; causing prev-situation and curr-situation values for (the receiver-of of _FO23)
;;; to be unified. The KB author's mistake here is received-of shouldn't be an 
;;; inertial fluent, or it should be multiple valued (depending on whether receiver-of
;;; means receiver-of in this or all situations).

(do-and-next (a Send with (message (*shot))
	                     (receiver ((thelast FO)))))


((ignore-result (the receiver-of of (thelast FO))) or t)	; prompt undesirable projection if fluent-status is
					; mis-declared
((ignore-result (the after-situation of (thelast Send))) or t)  ; prompt misunification of Situations to cause error

(do-script (a Tick with (patient ((thelast FO)))))

;; should now be in state n3
;(the currentState of (thelast FO)) 
((the currentState of (thelast FO))  isa FO_n3)		; PEC

(do-and-next ((a Send with (message (*splash))
                         (receiver ((thelast FO))))))
(do-script (a Tick with (patient ((thelast FO)))))
(the currentState of (thelast FO)) 
;; should now be in state n4

(do-and-next ((a Send with (message (*roundsComplete))
                         (receiver ((thelast FO))))))
(do-script (a Tick with (patient ((thelast FO)))))

((the currentState of (thelast FO)) isa FO_stop) 
;; should return (t) 

(print "defaults.km")

(reset-kb)

(every Car has 
  (parts ((a Engine) (:default (a Seat)))))

(*MyCar has 
  (instance-of (Car))
  (parts ((mustnt-be-a Seat))))

((the number of (the parts of *MyCar)) = 1)	; Engine

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


(reset-kb)

(every Vehicle has
  (parts ((mustnt-be-a Furry-Dice))))

(Car has (superclasses (Vehicle)))

(every Car has 
  (parts ((a Engine) (:default (a Seat)))))

(*MyCar has 
  (instance-of (Car))
  (parts ((:default (a Furry-Dice)))))

(print (the parts of *MyCar))
((the number of (the parts of *MyCar)) = 2)	; Seat and Engine, but not Furry-Dice

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

(reset-kb)

(every Vehicle has
  (parts ((mustnt-be-a Furry-Dice))))

(Car has (superclasses (Vehicle)))

(every Car has 
  (parts ((a Engine) (:default (a Seat)))))

(new-situation)

(*MyCar has 
  (instance-of (Car))
  (parts ((:default (a Furry-Dice)))))

(print (the parts of *MyCar))
((the number of (the parts of *MyCar)) = 2)	; Seat and Engine, but not Furry-Dice

(new-situation)

(*MyCar2 has
  (instance-of (Car))
  (parts ((mustnt-be-a Seat))))

((the number of (the parts of *MyCar2)) = 1)	; Engine

(*MyCar3 has
  (instance-of (Car)))

((the number of (the parts of *MyCar3)) = 2)	; Engine, Seat

(next-situation)

(*MyCar3 has
  (parts ((mustnt-be-a Seat))))			; situation-specific override of default

((the number of (the parts of *MyCar3)) = 1)	; Engine

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

(reset-kb)

(every Car has 
  (parts ((a Engine) (:default (a Seat)) (mustnt-be-a Furry-Dice))))


;;; ======================================================================
;;;		SINGLE VALUED SLOTS
;;; ======================================================================

(reset-kb)

(every Van has (make ((:default *American))))
(make has (instance-of (Slot)) (cardinality (1-to-1)))
(*myvan has (instance-of (Van)) (make (*Japanese)))
(the make of *myvan) ;; Was: ERROR! Unification (*Japanese & *American) failed!

(a Partition with
 (members (European-Country American-Country)))

(from has (cardinality (N-to-1)))
(every Car has
      (from ((:default (a American-Country)))))
(*MyCar has
      (instance-of (Car))
      (from ((a European-Country))))

; was KM(COMMENT: (_European-Country1 & _American-Country2) unified to be _European-Country1)
(not ((the from of *MyCar) isa American-Country))


;;; ======================================================================
;;;	ALLOWING SET CONSTRAINTS TO OVERRIDE A DEFAULT:
;;; ======================================================================

;; This now works...horray!

(every Car has (color ((:default *Blue) (at-most 2 Thing))))
(a Car with (color (*Red *Green)))
((the color of (a Car with (color (*Red *Green)))) = (:set *Red *Green))

;;; this now works too...

(every Age-Value has
       (value ((set-constraint ((the number of (allof TheValues where ((the2 of It) = *year))) <= 1)))))

(every Person has (age ((a Age-Value with (value ((:default (:pair 10 *year))))))))

((the value of (the age of (a Person))) = (:pair 10 *year))

((the value of (the age of (a Person with (age ((a Age-Value with (value ((:pair 20 *year))))))))) = (:pair 20 *year))

(print "descriptions.km")

(reset-kb)

(a Car with (color (*Red)))

(every Car with (color (*Red)))

'(every Car with (color (*Red)))

(Elephant has (superclasses (Animal)))

(every Elephant has 
  (parts ((a Trunk))))

('(every Animal with (parts ((a Trunk)))) subsumes Elephant)

(Car has (superclasses (Vehicle)))

(every Vehicle has (size (*Big)) (weight (*Heavy)))

('(every Vehicle) covers '(a Car with (size (*Big))))

('(a Car) is '(a Vehicle with (weight (*Heavy))))

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

(every Person has
   (liked-food-type ('(every HotDog))))

(every Eating-Event has
       (patient ((a Food)))
       (agent ((a Person with
                  (mood ((if (oneof (the liked-food-type of (the agent of Self))
                              where (It covers (the patient of Self)))
                          then *Happy)))))))

(HotDog has (superclasses (Food)))

((the mood of 
     (the agent of (a Eating-Event with
			(agent ((a Person)))
			(patient ((a HotDog))))))
  = *Happy)
	

;;; Version 2

(reset-kb)

(HotDog has (superclasses (Food)))

(every Person has
   (liked-food-type ('(a HotDog))))

(every Eating-Event has
       (patient ((a Food)))
       (agent ((a Person with
                  (mood ((if (oneof (the liked-food-type of (the agent of Self))
                              where ((the patient of Self) is It))
                          then *Happy)))))))

((the mood of 
     (the agent of (a Eating-Event with
			(agent ((a Person)))
			(patient ((a HotDog))))))
  = *Happy)
	

;;; ---------- version 3

(reset-kb)

; (HotDog has (superclasses (Food)))
; (Eating has (superclasses (Action)))

(every Person has
   (liked-food-type ('(every HotDog))))

(every Person has
        (activity ((must-be-a Action)))           ; the thing the person is doing
	(mood ((if (    (has-value (the Eating activity of Self))
	   	    and ((the liked-food-type of Self) covers 
		         (the patient of (the Eating activity of Self))))
                then *Happy))))

((the mood of (a Person with 
		     (activity ((a Eating with
                                   (patient ((a HotDog))))))))
 = *Happy)

; variant with "oneof"
(every Person has
        (activity ((must-be-a Action)))           ; the thing the person is doing
	(mood2 ((if (    (has-value (the Eating activity of Self))
	   	    and (has-value (oneof (the liked-food-type of Self)
				 where (It covers (the patient of 
					  (the Eating activity of Self))))))
                then *Happy))))


((the mood2 of (a Person with 
		     (activity ((a Eating with
                                   (patient ((a HotDog))))))))
 = *Happy)

;;; ---------- version 4

(reset-kb)

; (HotDog has (superclasses (Food)))
; (Eating has (superclasses (Action)))

(every Person has
   (liked-food-type ('(a HotDog))))		; <- "a"

(every Person has
	(mood ((if (    (has-value (the Eating activity of Self))
	   	    and (has-value (oneof (the liked-food-type of Self)
				    where ((the patient of (the Eating activity of Self))
                                             is It))))		; <===== NOTE "is"
                then *Happy))))

((the mood of (a Person with 
		     (activity ((a Eating with
                                   (patient ((a HotDog))))))))
 = *Happy)

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


(every Parachute has
      (ability ('(every Slowing with
                    (patient ((a Person with
                                 (patient-of ((a Falling with
                                                 (through (*Air))))))))))))

(every Task has
      (goal ((a Action)))
      (possible-instruments ((allof (every Thing)
; Bug!!                              where ((the ability of It) subsumes (the goal of Self))))))
; NEW: need to add check (below)     where ((the ability of It) covers (the goal of Self))))))
			             where ((has-value (the ability of It)) and
					    ((the ability of It) covers (the goal of Self)))))))

(Slowing has (superclasses (Action)))		; "Slowing is a kind of action."

(*Fred has (instance-of (Person)))              ; "Fred is a person."

(*MyParachute has (instance-of (Parachute)))    ; "MyParachute is a parachute."

(a Falling with                                 ; "Fred is falling."			
       (patient (*Fred))
       (through (*Air)))

((the possible-instruments of                    ; "What might slow down Fred?"
         (a Task with 
             (goal ((a Slowing with (patient (*Fred)))))))
 = *MyParachute)

;;; return a class name:

#|
(every Task has
      (goal ((a Action)))
      (possible-instrument-classes (
          (allof (the all-subclasses of Physobj)
;BUG!              where ((the ability of (an instance of It)) subsumes (the goal of Self))))))
                  where ((the ability of (an instance of It)) covers (the goal of Self))))))
|#

(every Task has
      (goal ((a Action)))
      (possible-instrument-classes (
          (allof (the all-subclasses of Physobj)
                  where (     (?x == (an instance of It))
                          and (has-value (the ability of ?x))
                          and ((the ability of ?x) covers (the goal of Self)))))))

(Parachute has (superclasses (Physobj)))        ; "A parachute is a physical object."

((the possible-instrument-classes of            ; "What things might slow down Fred?"
         (a Task with 
             (goal ((a Slowing with (patient (*Fred)))))))
 = Parachute )

;;; ignore  done-cache.km


;;; ignore  efficiency.km


;;; ignore  efficiency2.km

(print "equals.km")

;;; Test various nested equality relationships

((:set 1 2) = (:set 2 1))
((:bag 1 2) = (:bag 2 1))
(not ((:seq 1 2) = (:seq 2 1)))

((:set 1 (:set 1 2)) = (:set 1 (:set 2 1)))
((:set 1 (:bag 1 2)) = (:set 1 (:bag 2 1)))
(not ((:set 1 (:seq 1 2)) = (:set 1 (:seq 2 1))))

((:seq 1 (:set 1 2)) = (:seq 1 (:set 2 1)))
((:seq 1 (:bag 1 2)) = (:seq 1 (:bag 2 1)))
(not ((:seq 1 (:seq 1 2)) = (:seq 1 (:seq 2 1))))

((:bag 1 (:set 1 2)) = (:bag 1 (:set 2 1)))
((:bag 1 (:bag 1 2)) = (:bag 1 (:bag 2 1)))
(not ((:bag 1 (:seq 1 2)) = (:bag 1 (:seq 2 1))))

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

((:set 1 2 2) = (:set 2 1 1))
(not ((:bag 1 2 2) = (:bag 2 1 1)))
(not ((:seq 1 2 2) = (:seq 2 2 1)))

((:bag 1 2 (:set 1 2) (:set 2 1)) = (:bag (:set 1 2) 1 (:set 1 2 2) 2))

(not ((:bag 1 2 (:set 1 2) (:set 2 1)) 
	= (:bag (:set 1 2) 1 (:set 1 2 2) 2 (:set 1 2))))

(not ((:seq 1 2 3) = (:seq 1 2)))

(1 = (:set 1))
(1 = (:set 1 1))
(not (1 = (:bag 1 1)))
(not (1 = (:seq 1 1)))

;;; ======================================================================
;;;		Inequality:
;;; ======================================================================

(reset-kb)

(every Move has
  (origin       ((must-be-a Spatial-Entity)))
  (destination  ((must-be-a Spatial-Entity with
                    (/== ((the origin of Self)))))))    ; ie not the origin

(every Move has
  (origin       ((a Spatial-Entity)))
  (destination       ((a Spatial-Entity))))

(X == (a Move))

(not ((the origin of X) &? (the destination of X)))









(print "errors.km")

;;; These calls shouldn't cause errors to occur

; (setq *ERROR-REPORT-SILENT* 'T) ; KM 2.1
(setq *ON-ERROR* 'IGNORE)	  ; KM 2.2

(the cat with with)

; (not (SETQ *ERROR-REPORT-SILENT* NIL)) ; KM 2.1 put value back to how it was
(SETQ *ON-ERROR* 'DEBUG)		 ; KM 2.2

; Undesirable here - the error aborts out of the entire load, not the
; execution of the buggy command
;(setq *ABORT-ON-ERROR-REPORT* 'T)
;
;(the cat with with)
;
;(setq *ABORT-ON-ERROR-REPORT* NIL)


(print "explanations.km")

(reset-kb)

(base-cost has (cardinality (N-to-1)) (inherit-with-overrides (t)))

(every Car has 
	(base-cost ((1234)))
	(tax (((the sum of (the bag of (the cost of Self))) * 0.1 [TaxComp])))
       (cost ((if   (has-value (the options-cost of Self)) 
	       then ((the base-cost of Self) + (the options-cost of Self)) [Cost])
	      (if   (not (has-value (the options-cost of Self)))
	       then (the base-cost of Self [Cost2])))))

(Nissan has (superclasses (Car)))
(every Nissan has (base-cost (10000)) (options-cost (1000)))

(comment [Cost] 
         (:seq "So, this car costs" (the base-cost of Self) "+"
	       (the options-cost of Self) "=" (the cost of Self) ".") 
	 "A car's cost is its base cost + options cost."
	(:set (:triple Self base-cost *) (:triple Self options-cost *)))

(comment [Cost2] 
         (:seq "So, this car costs" (the base-cost of Self) ".")
	 "A car with unknown options cost just costs its base cost."
	 (:triple Self base-cost *))

(comment [TaxComp] 
         (:seq "The cost of the tax is 0.1 *" (the cost of Self) " = " (the tax of Self) ".")
	 "A car's final tax is 0.1 times its cost."
	 (:triple Self cost *))

#|
;;; Old, obsolete mechanism
(catch-explanations)
(the tax of (a Car with (base-cost (10))))
(print "Explanations:")
(show-explanations)

(catch-explanations)
(the tax of (a Car with (base-cost (10)) (options-cost (1))))
(print "Explanations:")
(show-explanations)
|#

(print (get-justification (:triple (a Car) tax *)))

#|
((get-justification (:triple (a Car) tax *)) =
"--------------------
A car's final tax is 0.1 times its cost.
  A car with unknown options cost just costs its base cost.
  So, this car costs 1234.
The cost of the tax is 0.1 * 1234 = 123.40.
-------------------
")
|#

(print (get-justification (:triple (a Nissan) tax *)))

#|
((get-justification (:triple (a Nissan) tax *)) =
"--------------------
A car's final tax is 0.1 times its cost.
  A car's cost is its base cost + options cost.
  So, this car costs 10000 + 1000 = 11000.
The cost of the tax is 0.1 * 11000 = 1100.00.
-------------------
")
|#

;;; ======================================================================

(reset-kb)

(every Car has 
      (parts ((a Engine with (parts ((a Carburetor))) [R1])
              (a Chassis [R2]))))

(comment [R1] "R1 exit." "R1 entry.")
(comment [R2] "R2 exit." "R2 entry.")

(_Car == (a Car))
(_Engine == (the Engine parts of _Car))
(_Chassis == (the Chassis parts of _Car))

;;; Make sure R2 isn't part of the Engine justification (was in 1.4.5.83)

(print (get-justification (:triple _Car parts _Engine)))
#|
((get-justification (:triple _Car parts _Engine)) =
"--------------------
R1 entry.
R1 exit.
-------------------
")
|#

(print (get-justification (:triple _Car parts _Chassis)))
#|
((get-justification (:triple _Car parts _Chassis)) =
"--------------------
R2 entry.
R2 exit.
-------------------
")
|#

#|
Correct behavior (now)...
USER(3): (km)
KM> (a Car)
(_Car4)
(1 inferences and 27 KB accesses in 0.0 sec)

KM> (the parts of _Car4)
(_Engine5 _Chassis6)
(4 inferences and 109 KB accesses in 0.0 sec)

KM> (justify (:triple _Car4 parts _Engine5))
R1 entry.
R1 exit.
(t)
(1 inferences and 0 KB accesses in 0.0 sec)

KM> (justify (:triple _Car4 parts _Chassis6))
R2 entry.
R2 exit.
(t)
(1 inferences and 0 KB accesses in 0.0 sec)

KM> 
|#

;;; ======================================================================
;;;	With prototypes
;;; ======================================================================

(reset-kb)

(Black-Cat has (superclasses (Cat)))

(_Black-Cat1 has
  (instance-of (Black-Cat))
  (prototype-of (Cat))
  (prototype-scope ((the-class Cat with 
   	(color (*black)) [Comment1])))
  (prototype-participants (_Black-Cat1))
  (color ((*black [Comment2]))))

(comment [Comment1] 
     (:seq "Therefore," Self "is a black cat.") 
     (:seq "All cats which are black are black cats"))

(comment [Comment2] 
     (:seq "Therefore," Self "is colored black.") 
     (:seq "Black cats are black."))

(*Suzie == (a Cat with (color (*black))))
(the color of *Suzie)

;;; Now test:
((get-justification (:triple *Suzie instance-of *)) =
"All cats which are black are black cats
Therefore, suzie is a black cat.")

(new-situation)

((get-justification (:triple *Suzie instance-of *)) =
"All cats which are black are black cats
Therefore, suzie is a black cat.")

(*Suzie2 == (a Cat with (color (*black))))
(the color of *Suzie2)

(color has
  (fluent-status (*Inertial-Fluent)))

;;; Now test:
((get-justification (:triple *Suzie2 instance-of *)) =
"All cats which are black are black cats
Therefore, suzie2 is a black cat.")


;(trace)

((get-justification (:triple *Suzie2 color *)) ==
"Black cats are black.
Therefore, suzie2 is colored black.")

(next-situation)

((get-justification (:triple *Suzie2 color *)) ==
"Black cats are black.
Therefore, suzie2 is colored black.")


;;; ======================================================================


(reset-kb)

(SETQ *DEVELOPER-MODE* T)	; rely on this for more expansive get-justifications 
(SETQ *PRINT-RIGHT-MARGIN* 125)  ; get consistent tabulation in test below

;;; ======================================================================
;;; 		Test must-be-a elements in explanations
;;; ======================================================================
(every Breach has
       (result ((a Spatial-Entity with
		   (plays ((a Portal))))))
       ;; the agent of Breach is the agent in the Creation of the Portal
       (agent ((a Thing)
	       (must-be-a Tangible-Entity with
			  (agent-of ((a Create with
					(result ((the result of Self))))))))))

(*B1 == (a Breach))
(*C1 == (the first of (the agent-of of (the agent of *B1))))
(*S1 == (the result of *C1))

((get-justification (:triple *C1 result *S1)) =
"
subgoal (:triple *C1 result *S1): Computed from:
  (every Breach has (agent ((must-be-a Tangible-Entity with (agent-of ((a Create with (result ((the result of *B1))))))))))
")

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

(every Breach2 has
       (result ((a Spatial-Entity with
		   (plays ((a Portal))))))
       ;; the agent of Breach is the agent in the Creation of the Portal
       (agent ((a Thing with
	         (agent-of ((a Thing) (must-be-a Create with
					(result ((the result of Self))))))))))

(*B2 == (a Breach2))
(*C2 == (the first of (the agent-of of (the agent of *B2))))
(*S2 == (the result of *C2))
((get-justification (:triple *C2 result *S2)) =
"
subgoal (:triple *C2 result *S2): Computed from:
  (every Breach2 has (agent ((a Thing with (agent-of ((must-be-a Create with (result ((the result of *B2))))))))))
")

;;; ----------
	
(every Breach3 has
       (result ((a Spatial-Entity with
		   (plays ((a Portal))))))
       ;; the agent of Breach is the agent in the Creation of the Portal
       (agent ((a Thing with
	         (agent-of ((a Create with
				(result ((the result of Self))))))))))

(*B3 == (a Breach3))
(*C3 == (the first of (the agent-of of (the agent of *B3))))
(*S3 == (the result of *C3))
((get-justification (:triple *C3 result *S3)) =
"
subgoal (:triple *C3 result *S3): Computed from:
  (every Breach3 has (agent ((a Thing with (agent-of ((a Create with (result ((the result of *B3))))))))))
")

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

(every Disperse has
  (object 	  ((a Tangible-Entity)))
  (origin	  ((a Spatial-Entity)))
  (path		  ((a Spatial-Entity)))
  (subevent    	  ((forall (the object of Self)
		     (a Leave with
			(object (It))
			(origin ((the origin of Self)))
			(path ((if (has-value (the path of Self)) 
				   then
				   (the path of Self)))))))))

(*D == (a Disperse))
(*Ob == (the object of *D))
(*Or == (the origin of *D))
(*Pa == (the path of *D))
(*Su == (the subevent of *D))
;;; Tests and evaluation
((the object of *Su) = *Ob)
((the origin of *Su) = *Or)
((the path of *Su) = *Pa)

((get-justification (:triple *Su object *Ob)) = 
"
subgoal (:triple *Su object *Ob): Computed from:
  (every Disperse has (subevent... ((a Leave with (object (*Ob))))))
")

((get-justification (:triple *Su origin *Or)) = 
"
subgoal (:triple *Su origin *Or): Computed from:
  (every Disperse has (subevent... ((a Leave with (origin ((the origin of *D)))))))
")

((get-justification (:triple *Su path *Pa)) =
"
subgoal (:triple *Su path *Pa): Computed from:
  (every Disperse has (subevent... ((a Leave with (path ((if (has-value (the path of *D)) then (the path of *D))))))))
")

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

(reset-kb)

(Big-Entity has (superclasses (Entity)))

(every Buy has
  (object ((a Entity)
 	   (must-be-a Big-Entity))))

; Or this works too:
;(every Buy has
;  (object ((   ((a Entity))
; 	    && ((must-be-a Big-Entity))))))

(*Bu == (a Buy))
(*Bt == (the object of *Bu))
;;; NOTE: Unfortunately the "must-be-a" annotation becomes "a", a change
;;; effected by enforce-val-constraint and not easily recoverable here

#|
((get-justification (:triple *Bu object *Bt)) =
"
subgoal (:triple *Bu object *Bt): Computed from:
  (every Buy has (object ((a Entity))))
  (every Buy has (object ((a Big-Entity))))
")
|#
;;; NO! Removed Feb 2007 -- really the constraint should be on (*Bt instance-of Big-Entity),
;;; not (*Bu object *Bt). This was causing problems as it prevents deletion of the (x object y)
;;; triple, so removed in KM 2.0.53
((get-justification (:triple *Bu object *Bt)) =
"
subgoal (:triple *Bu object *Bt): Computed from:
  (every Buy has (object ((a Entity))))
")

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

(every Buy2 has
  (object ((must-be-a Big-Entity))))

(*B2 == (a Buy2 with (object ((a Entity)))))
((the object of *B2) == (*O2))

;;; NOTE: Unfortunately the "must-be-a" annotation becomes "a", a change
;;; effected by enforce-val-constraint and not easily recoverable here
#|
((get-justification (:triple *B2 object *O2)) =
"
subgoal (:triple *B2 object *O2): Computed from:
  (|<location unknown>| (a Entity))
  (every Buy2 has (object ((a Big-Entity))))
")
|#

((get-justification (:triple *B2 object *O2)) =
"
subgoal (:triple *B2 object *O2): Computed from:
  (|<location unknown>| (a Entity))
")

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

(reset-kb)
(every Truck has (parts ((must-be-a Foo with (age ((the age of (the size of (the width of (a Foo with (age ((the size of (the nam of (a Faz)))))))))))))))

(the parts of (a Truck with (parts ((a Thing)))))	; -> _Thing2

(not (the age of _Thing2)); -> create (the 2nd) Foo

((get-justification (:triple _Foo3 instance-of Foo)) = 
("
subgoal (:triple _Foo3 instance-of Foo): Computed from:
  (every Truck has (parts ((must-be-a Foo with (age... ((a Foo with (age ((the size of (the nam of (a Faz))))))))))))
"))

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

(reset-kb)

(every Truck has (parts ((if (a Foo with (age ((the age of (the size of (the width of (a Bar with (age ((the size of (the nam of (a Faz)))))))))))) then t))))

#|
The explanation annotations are added as below. Note the comments for what they are explanations OF:
(every Truck has 
       (parts ((if (a Foo with 
		      (age ((the age of 
				 (the size of 
				      (the width of 
					   (a Bar with 
					      (age ((the size of 
							 (the nam of 
							      (a Faz (@ Self Truck parts... Foo age... Bar age...))) ; Faz
							 (@ Self Truck parts... Foo age... Bar age)))) ; for Bar age
					      (@ Self Truck parts... Foo age...)))) ; for Bar instance-of
				 (@ Self Truck parts... Foo age)))) ; for Foo age 
		      (@ Self Truck parts...)) ; for Foo instance-of 
		   then t 
		   (@ Self Truck parts))))) ; for Truck parts 
|#

(the parts of (a Truck))
(not (the age of (thelast Foo)))
(not (the age of (thelast Bar)))

;;; Note that (a Faz) is incredibly nested -- the explanation mechanism can still track its origins, though.
( (get-justification (:triple _Faz4 instance-of Faz)) = 
("
subgoal (:triple _Faz4 instance-of Faz): Computed from:
  (every Truck has (parts... ((a Foo with (age... ((a Bar with (age... ((a Faz))))))))))
"))

;;; ========================================

;;; Simplified version of HLO-2022

(reset-kb)

;;; Note: We want an embedded explanation placed on (a Method ...) structure
(every Car has
  (part ((if (the output of (a Method with (input (Self)))) then (a Engine)))))

(every Method has
 (output ((the input of Self)))
 (input ((a Car))))

(the part of (a Car))

( (get-justification (:triple _Method2 instance-of Method)) =  
("
subgoal (:triple _Method2 instance-of Method): Computed from:
  (every Car has (part... ((a Method with (input (_Car1))))))
"))


(SETQ *DEVELOPER-MODE* NIL)	; switch it off again

;;; ======================================================================
;;; Removing explanation tags before asserting, to avoid the problem below
;;; ======================================================================

#|
KM> (a Foo with (parts ((*C1 (@ Foo parts)))))
(_Foo6)

KM> (a Foo2 with (parts ((*C1 (@ Foo2 parts)))))
(_Foo28 #|"a Foo2"|#)

KM> (_Foo6 & _Foo28)
(_Foo6 #|"a Foo&Foo2"|#)

KM> (showme _Foo6)
(_Foo6 has 
  (instance-of (Foo Foo2))
  (parts ((((*C1 (@ Foo parts))) && ((*C1 (@ Foo2 parts)))))))	<============== undesirable, avoided by [2]
|#

(reset-kb)

(_M1 == (a Foo with (parts ((*C1 (@ Foo parts))))))
(_M2 == (a Foo2 with (parts ((*C1 (@ Foo2 parts))))))
(_M1 & _M2)
(the parts-of of *C1)	; failed in KM 2.0.29 and earlier

(reset-kb)

(every Car has
  (parts ((a Engine with (parts (*Cylinder1))))))

(every Car2 has
  (parts ((a Engine with (parts (*Cylinder1))))))

(_Car has (instance-of (Car)))
(_Car2 has (instance-of (Car2)))

(the parts of _Car)
(the parts of _Car2)

((the parts of _Car) & (the parts of _Car2))

(the parts-of of *Cylinder1)

#|
======================================================================
This below example screens for an old bug. annotate-vals on the (every ...) 
statement results in (a Wheel with (position ((front (@ Car has-part Wheel position))))).
When this is desourced, it was going to 
		 (a Wheel with (position ((front))))
rather than	 (a Wheel with (position ( front )))
As a result, the cached-explanations-for _Wheel1, namely (a Wheel with (position (front))),
did not match any of the (desource <inherited-expressions>) on has-part.
The result is that remove-explained-vals found no explained vals, and
hence _Wheel2 was unified with (a Wheel with (position (front))), resulting
in two front wheels. 
This was fixed by modifying the desource operation in KM 2.0.42.
======================================================================
|#

(reset-kb)
(every Car has (has-part ((a Wheel with (position (front))) (a Wheel))))
(a Wheel with (position (front)))
(a Wheel)
(a Car with (has-part (_Wheel2 _Wheel1)))
(not (the position of _Wheel2))
(the position of _Wheel1)
(the has-part of _Car3)
(the position of _Wheel1)
(not (the position of _Wheel2))	; the test!

;;; ======================================================================

(reset-kb)
(every Person has (owns ((a Pet))))
(_Mindy1 has (owns ((a Fish))))
(owns has (cardinality (N-to-1)))
(the owns of _Mindy1) ; -> _Fish1
(_Mindy1 also-has (instance-of (Person)))
(the owns of _Mindy1) ; (_Fish1 #|"a Fish&Pet"|#)

;;; Now test the explanation of the instance-of link:
(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '_Fish1 'instance-of 'Pet))))) 
	      '(every Person has (owns ((a Pet))))))

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

;;; Check (Self) doesn't get broken by sources being appended to it

(reset-kb)
(every Car has (likes ((the age of (Self)))) (age (20)))
(the likes of (a Car))

;;; ======================================================================

(reset-kb)

(every Car has
  (parts ((a Engine with
		(parts ((a Thing) (must-be-a Cylinder))))))
  (age ((:pair (a Number) *year)))
  (color ((the age of (a Engine)))))

(every Engine has
  (age ((a Year))))

(_Car == (a Car))

(_X == (the parts of _Car))
(_Y == (the parts of _X))

(_Number == (the1 of (the age of (thelast Car))))
(_Year == (the color of (thelast Car)))
(_Engine == (thelast Engine))

;;; Check explanations for embedded constraints are recorded
(EVAL (EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '_X 'parts '(must-be-a Cylinder))))))
	      '(every Car has (parts ((a Engine with (parts ((must-be-a Cylinder)))))))))

;;; NEW: Check :pair explanations are recorded
(EVAL (EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Car '#$age '#$(:pair _Number *year))))))
	      '(every Car has (age ((:pair (a Number) *year))))))

;;; NEW: Check embedded instance-of explanations are recorded
(EVAL (EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Number '#$instance-of '#$Number)))))
	      '(every Car has (age... ((a Number))))))

;;; Normal explanation
(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Year '#$instance-of '#$Year)))))
	      '(|every| |Engine| |has| (|age| ((|a| |Year|))))))

;;; Normal explanation
(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Car '#$color '#$_Year)))))
	      '(|every| |Car| |has| (|color| ((|the| |age| |of| (|a| |Engine|)))))))

;;; Check embedded (the X of Y) is annotated
(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Engine '#$instance-of '#$Engine)))))
	      '(|every| |Car| |has| (|color...| ((|a| |Engine|))))))

;;; ======================================================================

;;; Previously was missing explanations for these atomic items

(reset-kb)

(every Teen has (age (*Eighteen)))

(_Teen == (a Teen))

(the age of _Teen)

;;; Previously, didn't do record-explanation-for for the atomic value
(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Teen '#$age '#$*Eighteen)))))
	      '(|every| |Teen| |has| (|age| (|*Eighteen|)))))

(reset-kb)

;;; Previously, no annotation added for numerics like 18
(every Teen has (age (18)))

(_Teen == (a Teen))

(the age of _Teen)

(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Teen '#$age 18)))))
	      '(|every| |Teen| |has| (|age| (18)))))


(reset-kb)

;;; Previously, no annotation added for strings like 18
(every Teen has (age ("18")))

(_Teen == (a Teen))

(the age of _Teen)

(EVAL '(EQUAL (BUILD-RULE (FIRST (FOURTH (FIRST (GET-EXPLANATIONS '#$_Teen '#$age "18")))))
	      '(|every| |Teen| |has| (|age| ("18")))))
(print "fluent-isa.km")

(reset-kb)

(instance-of-is-fluent)

(*InitSituation == (a Situation))

#|
With views:
[1] triggers (the useful-views of *virus), which triggers 
(the instance-of of *virus), which projects (*virus has (instance-of (C2))).
This is going to then clash with the next statement in this file.
Solution: switch the two statements.
|#
(*virus has (instance-of (C1)))
(in-situation *InitSituation)
(*virus has (instance-of (C2)))
(taxonomy)
(next-situation)				; enter _Situation1
(*virus has (instance-of (C3)))
(taxonomy)
(next-situation)				; enter _Situation2
(next-situation)				; enter _Situation3

; OLD: [1]
;(*virus has (instance-of (C4)))		; [1]
;(*virus has (instance-of ((<> C2))))
;(C2 has (instances ((<> *virus))))

; NEW:
(*virus has (instance-of ((<> C2))))
(C2 has (instances ((<> *virus))))
(*virus has (instance-of (C4)))

;;; Must do this too!
;(trace)
(taxonomy)
(next-situation)
(*virus has (instance-of ((<> C4))))
(C4 has (instances ((<> *virus))))
(*virus has (instance-of (C5)))
(taxonomy)
(next-situation)
(next-situation)
(next-situation)

; test!
((the classes of *virus) = (:set C1 C3 C5))

; test the right classes are propagated:
((forall (:set C1 C2 C3 C4 C5) (:seq It (the all-instances of It)))
 = (:set (:seq C1 *virus) (:seq C2 NIL) (:seq C3 *virus) (:seq C4 NIL) (:seq C5 *virus)))

((in-situation *InitSituation (forall (:set C1 C2 C3 C4 C5) (:seq It (the all-instances of It))))
 = (:set (:seq C1 *virus) (:seq C2 *virus) (:seq C3 NIL) (:seq C4 NIL) (:seq C5 NIL)))

;;; ======================================================================

; instance projection

(reset-kb)

(instance-of-is-fluent)			; set it!

(*virus has (instance-of (C1)))
(new-situation)
(*virus has (instance-of (C2)))
(next-situation)
(*virus has (instance-of (C3)))
(next-situation)
(next-situation)
(*virus has (instance-of ((<> C2))))
;;; Must do this too!
(C2 has (instances ((<> *virus))))
(*virus has (instance-of (C4)))
(next-situation)
(*virus has (instance-of ((<> C4))))
(C4 has (instances ((<> *virus))))
(*virus has (instance-of (C5)))
(next-situation)
(next-situation)
(next-situation)

; test!
((the classes of *virus) = (:set C1 C3 C5))

#|
;;; ======================================================================
Below: An obscure bug (fixed): For non-first calls for classes within a 
situation, I forgot to filter out the constraints:
[_Situation2] KM> ((the classes of X) and (the classes of X))
(Car (<> Dog))		<- incorrect		
;;; ======================================================================
|#

(reset-kb)

(instance-of-is-fluent)

(new-situation)

(X == (a Car with (instance-of ((<> Dog)))))

#'(LAMBDA () 
    (= (LENGTH (KM0 '#$((the classes of X) and (the classes of X)))) 1))






;;; ignore  fununif.km


;;; ignore  halo2-clib-one.km


;;; ignore  hlo2200.km

(print "hlo2366.km")

#|
OCT 2009:
The old solution of allowing && for combine-values-by-appending with prototypes (i.e., when eagerlyp) is 
simply inconsistent!

We had:
	(_X has (edge-coordinates ((:seq _DNA1 nil nil))))
	(_Y has (edge-coordinates ((:seq _Nucleotide1 nil nil))))
then _X & _Y unified _DNA1 and _Nucleotide1, even though it's a combine-values-by-appending slot!

Revised: We only do && for combine-values-by-appending slots and eagerlyp when there are NO existentials in
either 1 or the other of the value sets being combined. This is to try to still accomodate the
request in this file.

See comments mentioning hlo2366 in lazy-unify-vals in lazy-unify.lisp.

--------------------

11/2/09 - No, the above fix *still* doesn't work. We get a tortuous case of merging two Atoms:

(in-situation _Situation2217
  (_Atom2321 has 
    (is-basic-structural-unit-of (_Nitrogen-Base2296))
    (is-part-of (_Nitrogen-Base2296))))

(in-situation _Situation2217
  (_Atom2316 has 
    (is-basic-structural-unit-of (_Nucleotide2302))))

where is-basic-structural-unit-of is a combine-values-by-appending slot, and unfortunately produce an &&:

  (_Atom2321 has 
    (is-basic-structural-unit-of (((_Nitrogen-Base2296) && (_Nucleotide2302)))))

This is NOT ok!!! Both items are clones, but we DON'T want them unified!!


======================================================================

HLO-2366

Hey Pete. 
It seems that prototype cloning when combine-values-by-appending is t does not work quite the same as inheritance. This is causing us problems with getting the right slot values unified during problem solving. 

Here is KM's behavior for regular inheritance:

KM> (Cup has (superclasses (Tangible-Entity)))
KM> (every Cup has (object-of ((a Move) (a Move))))
KM> (new-situation)
[_Situation1943] KM> (a Cup with (object-of ((a Move) (a Move))))
[_Situation1943] KM> (the object-of of _Cup1944)
(_Move1945 _Move1946)				; 2 moves

And here is KM's behavior with prototypes:
KM> (Mug has (superclasses (Tangible-Entity)))
KM> (a-prototype Mug)
[prototype-mode] KM> ((the Mug) has (object-of ((a Move) (a Move))))
[prototype-mode] KM> (end-prototype)
KM> (new-situation)
[_Situation1950] KM> (a Mug with (object-of ((a Move) (a Move))))
[_Situation1950] KM> (the object-of of _Mug1951)
(_Move1955 _Move1956 _Move1953 _Move1954)	; 4 moves

In the case of prototypes, the unification with the clone (and its slot values) happens before querying the object-of slot, so that when the object-of slot is queried, the cloned values are already local (and indistinguishable from the "true" local values).

Ideally, we'd like the prototypes to work the same way as the regular KM class.
|#

(reset-kb)

(object-of has (combine-values-by-appending (t)))

(Mug has (superclasses (Tangible-Entity)))
(a-prototype Mug)
((the Mug) has (object-of ((a Move) (a Move))))
(end-prototype)
(a Mug with (object-of ((a Move) (a Move))))
; (showme (thelast Mug))
; (trace)
;((the number of (the object-of of (thelast Mug))) = 2) ; -> WAS 4 moves
; NOV 2009 - no, we CAN'T just unify these like above!!
((the number of (the object-of of (thelast Mug))) = 4)

(Cup has (superclasses (Tangible-Entity)))
(every Cup has (object-of ((a Move) (a Move))))
(a Cup with (object-of ((a Move) (a Move))))
; (showme (thelast Cup))
; (trace)
((the number of (the object-of of (thelast Cup))) = 2) ; -> 2 moves && is done via lazy

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

(reset-kb)

(object-of has (combine-values-by-appending (t)))

(Mug has (superclasses (Tangible-Entity)))
(a-prototype Mug)
((the Mug) has (object-of ((a Move) (a Move))))
(end-prototype)
(_Move01 has (instance-of (Move)))
(_Move02 has (instance-of (Move)))
(a Mug with (object-of (_Move01 _Move02)))
; (showme (thelast Mug))
; (trace)

;((the number of (the object-of of (thelast Mug))) = 2) ; -> WAS 4 moves
; OCT 2009 - no, we CAN'T just unify these like above!!
((the number of (the object-of of (thelast Mug))) = 4)

(Cup has (superclasses (Tangible-Entity)))
(every Cup has (object-of ((a Move) (a Move))))
(_Move11 has (instance-of (Move)))
(_Move12 has (instance-of (Move)))
(a Cup with (object-of (_Move11 _Move12)))
; (showme (thelast Cup))
; (trace)
; ((the number of (the object-of of (thelast Cup))) = 4) ; -> 2 moves && is done via lazy
; OCT 2009 - no, we CAN'T just unify these like above!!
((the number of (the object-of of (thelast Cup))) = 2)


;;; ======================================================================
;;;		REPEAT FOR STRUCTURES
;;; ======================================================================

(reset-kb)

(object-of has (combine-values-by-appending (t)))

(Mug has (superclasses (Tangible-Entity)))
(a-prototype Mug)
((the Mug) has (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
(end-prototype)
(a Mug with (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
; (showme (thelast Mug))
; (trace)
;((the number of (the object-of of (thelast Mug))) = 2) ; -> WAS 4 moves
; NOV 2009 - no, we CAN'T just unify these like above!!
((the number of (the object-of of (thelast Mug))) = 4)

(Cup has (superclasses (Tangible-Entity)))
(every Cup has (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
(a Cup with (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
; (showme (thelast Cup))
; (trace)
((the number of (the object-of of (thelast Cup))) = 2) ; -> 2 moves && is done via lazy

(reset-kb)

(object-of has (combine-values-by-appending (t)))

(Mug has (superclasses (Tangible-Entity)))
(a-prototype Mug)
((the Mug) has (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
(end-prototype)
(_Move01 has (instance-of (Move)))
(_Move02 has (instance-of (Move)))
(a Mug with (object-of ((:pair _Move01 *fast) (:pair _Move02 *fast))))
; (showme (thelast Mug))
; (trace)
; ((the number of (the object-of of (thelast Mug))) = 2) ; -> WAS 4 moves
; OCT 2009 - no, we CAN'T just unify these like above!!
((the number of (the object-of of (thelast Mug))) = 4)

(Cup has (superclasses (Tangible-Entity)))
(every Cup has (object-of ((:pair (a Move) *fast) (:pair (a Move) *fast))))
(_Move11 has (instance-of (Move)))
(_Move12 has (instance-of (Move)))
(a Cup with (object-of ((:pair _Move11 *fast) (:pair _Move12 *fast))))
; (showme (thelast Cup))
; (trace)
((the number of (the object-of of (thelast Cup))) = 2) ; -> 2 moves && is done via lazy

;;; ======================================================================
;;; 2/4/09 CHECK NORMAL UNIFICATION OF STRUCTURES WITH COMBINE VALUES BY APPENDING STILL BEHAVES
;;; ======================================================================

;;; Test this too:
(reset-kb)

(object-of has (combine-values-by-appending (t)))

(_Cat01 == (a Cat))
(_Cat02 == (a Cat))

(_Foo01 == (a Foo with (object-of ((:pair _Cat01 *fast)))))
(_Foo02 == (a Foo with (object-of ((:pair _Cat02 *fast)))))

(_Foo01 & _Foo02)

;;; Make sure the 2 expressions haven't been &&'ed
((the number of (rules-for (the object-of of _Foo01))) = 2)

#|
ERROR: was giving:

(_Foo01 has 
  (object-of ((((:pair _Cat01 *fast)) && ((:pair _Cat02 *fast)))))
  (instance-of (Foo)))

even though it's a combine-values-by-appending slot.
|#

;; ======================================================================
;;; Test this too, when there are no Skolems in the unifying objects:
;; ======================================================================

(reset-kb)

(input-word has (combine-values-by-appending (t)))

(_Foo01 == (a Foo with (input-word ((:pair "cat" n)))))
(_Foo02 == (a Foo with (input-word ((:pair "feline" n)))))

(_Foo01 & _Foo02)

;;; Make sure the 2 expressions haven't been &&'ed
((the number of (rules-for (the input-word of _Foo01))) = 2)

#|
ERROR: was giving:

(_Foo01 has 
  (input-word ((((:pair "cat" n)) && (:pair "feline" n))))
  (instance-of (Foo)))

even though it's a combine-values-by-appending slot.
|#






(print "hydro.km")

;;; To allow database tables to be used in the KB
;;; (EVAL '(LOAD "/home/clarkp/weblink/lisp/utils/db")) ; load database predicates
;;; Better: define it here so we can port this test file

(reset-kb)

(SETQ *LINEAR-PATHS* T)

;;;======================================================================
;;; Define simple utilities for accessing a table
;;;======================================================================

(EVAL '(DEFUN MAKE-TABLE (CONTENTS) CONTENTS))		; SIMPLER FOR READ ONLY!

;;; (TABLE-GET *TEST-TABLE* 'X2 'Y2) ===> 22
(EVAL '(DEFUN TABLE-GET (TABLE X Y)
	  (LET ( (X-ROW (ASSOC X TABLE))
		 (Y-INDEX (POSITION Y (FIRST TABLE))) )
	    (COND ((AND X-ROW Y-INDEX) (ELT X-ROW Y-INDEX))))))

(EVAL '(DEFUN TABLE-MATCH (TABLE ROW-PATTERN)
	  (FIND-PATTERN TABLE ROW-PATTERN)))

;;; ======================================================================

; ======================================================================
;		COMPONENT: HYDRAULIC SYSTEMS
; ======================================================================

#|
Hydraulic Systems Component:
This is a fairly Self-contained component describing the actuators,
the hydraulic systems (but not individual hydraulic components), and the
powers/powers-by relationship between them.
|#

(every hydraulic-system has
  (pumps ((the primary-pump of Self) 
	  (the demand-pump of Self) 
	  (the emergency-pump of Self))))

(left-hydraulic-system has  (superclasses (side-hydraulic-system)))

(every left-hydraulic-system has
  (powers (
	(Self hydraulic-systems-of aircraft pfcs)
;	((the thrust-reverser actuators of 
;		(Self hydraulic-systems-of aircraft)) with (side (*left)))
	(allof (the thrust-reverser actuators of 
		(Self hydraulic-systems-of aircraft))
	 where ((It side) = *left))
	  )))

(center-hydraulic-system has  (superclasses (hydraulic-system)))

(every center-hydraulic-system has
  (primary-pump ((a acmp) (a acmp)))
  (demand-pump ((a adp) (a adp)))
  (emergency-pump ((a rat)))
  (powers (
	(Self hydraulic-systems-of aircraft pfcs)
	(the steering actuators of (Self hydraulic-systems-of aircraft))
	(the landing actuators of (Self hydraulic-systems-of aircraft)))))

(right-hydraulic-system has   (superclasses (side-hydraulic-system)))

(every right-hydraulic-system has
  (superclasses (side-hydraulic-system))
  (powers (
	(the brakes actuators of (Self hydraulic-systems-of aircraft))
	(Self hydraulic-systems-of aircraft pfcs)
;	((the thrust-reverser actuators of 
;		(Self hydraulic-systems-of aircraft)) with (side (*right)))
	(allof (the thrust-reverser actuators of 
		(Self hydraulic-systems-of aircraft))
	 where ((It side) = *right))
	  )))

(side-hydraulic-system has  (superclasses (hydraulic-system)))

(every side-hydraulic-system has
  (primary-pump ((a edp)))
  (demand-pump ((a acmp))))

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

(ac777 has  (superclasses (aircraft)))

(every ac777 has
  (pfcs ((the flap actuators of Self) 
	 (the rudder actuators of Self)))
  (actuators (
	(a nose-steering)
	(a body-steering)
	(a nose-landing)
	(a body-landing)
	(a left-flap)
	(a right-flap)
	(a brakes)
	(a left-thrust-reverser)
	(a right-thrust-reverser)
	(a rudder)))
  (hydraulic-systems (
	(a left-hydraulic-system)
	(a center-hydraulic-system)
	(a right-hydraulic-system))))

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

(steering has (superclasses (actuator)))
(nose-steering has (superclasses (steering)))
(body-steering has (superclasses (steering)))
(landing has (superclasses (actuator)))
(nose-landing has (superclasses (landing)))
(body-landing has (superclasses (landing)))
(flap has (superclasses (actuator)))
(left-flap has (superclasses (flap))) 
(right-flap has (superclasses (flap)))
(brakes has (superclasses (actuator)))
(thrust-reverser has (superclasses (actuator)))
( left-thrust-reverser has (superclasses (thrust-reverser)))
(right-thrust-reverser has (superclasses (thrust-reverser)))
(rudder has (superclasses (actuator)))

(every  left-thrust-reverser has (side (*left)))
(every right-thrust-reverser has (side (*right)))
(every  left-flap has (side (*left)))
(every right-flap has (side (*right)))

; ======================================================================
;		COMPONENT: PUMPS
; ======================================================================

;;; Check SETQ works okay (setq is ok too)
(SETQ *PUMP-TABLE* (MAKE-TABLE
   '(	(NIL *max-gpm *pressure)
	(edp 48.0 3000)
	(adp 53.0 3000)
	(acmp 6.0 2850)
	(rat 10.0 2850))))

(every pump has
  (pressure (#'(LAMBDA () 
		(TABLE-GET *PUMP-TABLE*
;			(KM-UNIQUE0 '(the instance-of of #,Self))
			(KM-UNIQUE0 '(the instance-of of Self))
			'*pressure))))
  (max-gpm (#'(LAMBDA () 
		(TABLE-GET *PUMP-TABLE*
;			(KM-UNIQUE0 '(the instance-of of #,Self))
			(KM-UNIQUE0 '(the instance-of of Self))
			'*max-gpm)))))

(edp has (superclasses (pump)))
(adp has (superclasses (pump)))
(acmp has (superclasses (pump)))
(rat has (superclasses (pump)))

; ======================================================================
;		COMPONENT: FLIGHT CONDITIONS
; ======================================================================

(EVAL '(SETQ *HYDRO-DEMAND-TABLE* (MAKE-TABLE
   '(	(NIL *max-gpm *norm *refused-to *cr-wind-lng *stall-rec 
	        *td-spbrdp *td-tr *ab-lng *to-ret-lg
		*to-ret-te *to-ret-le *taxi-ext-le)
	(nose-steering		 8.8 0 0.5 0 0 0.5 0 0 0 0 0 1)
	(body-steering		17.8 0 1 0 0 0.5 0 0 0 0 0 1)
	(nose-landing		10.0 0 1 0 0 0 0 0 1 0 0 0)
	(body-landing		50.0 0 1 0 0 0 0 0 1 0 0 0)
	(left-flap		15.0 0.01 1 1 1 1 0.5 0.75 0.3 0.3 0.3 0)
	(right-flap		15.0 0.01 1 1 1 1 0.5 0.75 0.3 0.3 0.3 0)
	(brakes		 	3.0 0 0.5 0 0 1 0 0 0 0 0 0)
	(left-thrust-reverser	27.5 0 0 0 0 0 1 1 0 0 0 0)
	(right-thrust-reverser	27.5 0 0 0 0 0 1 1 0 0 0 0)
	(rudder			21.0 0.01 1 1 0.3 0.7 0.5 0.25 0.3 0.3 0.3 0)
	))))

(*norm has (instance-of (flight-condition)))
(*refused-to has (instance-of (flight-condition)))
(*cr-wind-lng has (instance-of (flight-condition)))
(*stall-rec has (instance-of (flight-condition)))
(*td-spbrdp has (instance-of (flight-condition)))
(*td-tr has (instance-of (flight-condition)))
(*ab-lng has (instance-of (flight-condition)))
(*to-ret-lg has (instance-of (flight-condition)))
(*to-ret-te has (instance-of (flight-condition)))
(*to-ret-le has (instance-of (flight-condition)))
(*taxi-ext-le has (instance-of (flight-condition)))

(every actuator has
  (powered-by-pumps (
	(forall (Self actuator-of * hydraulic-systems)
	 where  (It powers Self)
	 (the pumps of It))))
  (demand (((Self max-demand) * (Self demand-fraction))))
  (max-demand (#'(LAMBDA () 
		(TABLE-GET *HYDRO-DEMAND-TABLE*
;			(KM-UNIQUE0 '(the instance-of of #,Self))
			(KM-UNIQUE0 '(the instance-of of Self))
			'*max-gpm))))
  (demand-fraction (#'(LAMBDA () 
		(TABLE-GET *HYDRO-DEMAND-TABLE*
;		(KM-UNIQUE0 '(the instance-of of #,Self))
		(KM-UNIQUE0 '(the instance-of of Self))
;		(KM-UNIQUE0 '(#,Self actuators-of aircraft flight-condition)))))))
		(KM-UNIQUE0 '(Self actuators-of aircraft flight-condition)))))))

; ======================================================================
;		COMPONENT: SUPPLY AND DEMAND
; ======================================================================
#| 
A simple model of supply and demand.
Here we assume that 
  (i) the consumers' demands are given
 (ii) A single consumer shares the demand equally among all suppliers
|#

(every flow has
  (from ((a supplier)))
  (to ((a consumer)))
  (amount (((Self to * demand) / (the number of (Self to * in-flows))))))

(every consumer has
 (in-flows ((allof ((Self consumers-of circuit flows)) 
					where ((It to) = Self)))))

(every supplier has
  (supply ((the sum of (the amount of (the out-flows of Self)))))
  (out-flows ((allof ((Self suppliers-of circuit flows)) 
					where ((It from) = Self)))))

;; ======================================================================
;; BRIDGING PREDICATES; mapping aircraft onto supply and demand component
;; ======================================================================

(ac777 has  (superclasses (circuit)))

(every ac777 has 
  (flows ((forall (Self suppliers)
		(forall2 (Self consumers)
	            where ((It powers) includes It2)
			(a flow with (from (It)) (to (It2)))))))
  (suppliers ((Self hydraulic-systems)))
  (consumers ((Self actuators))))

(hydraulic-system has  (superclasses (supplier)))

(every hydraulic-system has
  (suppliers-of ((Self hydraulic-systems-of))))

(actuator has  (superclasses (consumer)))

(every actuator has
  (consumers-of ((Self actuators-of))))

;;; ======================================================================
;;;		TEST SUITE
;;; ======================================================================

;;; "Q1: What do the hydraulic systems power?"
(the actuators of (a ac777))

;;; "Q2: Does the hydraulic system power the lights?"
((if  (oneof (the powers of (the hydraulic-systems of (a ac777)))
      where (It isa light))
 then *yes 
 else *no)
 = *no)

;;; "Q3: What is the primary-pump of the left HS?"
((the primary-pump of (the left-hydraulic-system hydraulic-systems of (a ac777)))
 isa edp)

;;; "Q4: Which pumps power the landing gear?"
((the number of
  (forall (the hydraulic-systems of (a ac777)) where (It powers landing) 
			(the pumps of It)))
 = 5)

;;; "Q5: What is the demand pump of the nose steering?"
(forall (the hydraulic-systems of (a ac777)) where (It powers nose-steering) 
			(the demand-pump of It))

;;; "Q6: What is the operating pressure of the RAT?"
((the pressure of (a rat))
 = 2850)

;;; "Q7: What is the hydraulic requirement for nose steering during refused take-off?"
((the demand of (the nose-steering actuators of 
		(a ac777 with (flight-condition (*refused-to)))))
 = 4.4)

(SETQ *LINEAR-PATHS* NIL)(print "inequality-pcs.km")

(reset-kb)

(age has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))

(every Person has
  (age ((a Number))))

(every Driving has
  (agent ((a Person)))
  (pcs-list (
    (:triple (the age of (the agent of Self)) >= 16))))

(new-situation)

(do (a Driving with (agent (*Fred))))

;;; Check constraint on Fred's age has been enforced
(not (*Fred &? (a Person with (age (10)))))

;;; But can't do this without assuming preconditions...
(not (try-do (a Driving with (agent (*Joe)))))

;;; But can do this...
(try-do (a Driving with (agent ((a Person with (age (21)))))))

;;; But not this
(not (try-do (a Driving with (agent ((a Person with (age (12))))))))

;;; ========================================

;;; variant...

(reset-kb)

(age has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))
(required-age has (fluent-status (*Inertial-Fluent)))
(actual-age has (fluent-status (*Inertial-Fluent)))

(every Person has
  (age ((a Number))))

(every Driving has
  (agent ((a Person)))
  (required-age (16))
  (actual-age ((the age of (the agent of Self))))
  (pcs-list (
    (:triple (the actual-age of Self) >= (the required-age of Self)))))

(new-situation)

(do (a Driving with (agent (*Fred))))

;;; Check constraint on Fred's age has been enforced
;;; In this case, the costraint is now on the Driving frame...
(not ((thelast Driving) &? (a Driving with (actual-age (10)))))

;;; But can't do this without assuming preconditions...
(not (try-do (a Driving with (agent (*Joe)))))

;;; But can do this...
(try-do (a Driving with (agent ((a Person with (age (21)))))))

;;; But not this
(not (try-do (a Driving with (agent ((a Person with (age (12))))))))

;;; ======================================================================

#|
    (:triple (the age of (the agent of Self)) >= 16))))
changed to...
    (:triple 16 <= (the age of (the agent of Self))))))

This has the disadvantage that, if the first argument in the :triple isn't
of the form (the s of v), then the constraint is NOT asserted and enforced.
|#

(reset-kb)

(age has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))

(every Person has
  (age ((a Number))))

(every Driving has
  (agent ((a Person)))
  (pcs-list (
    (:triple 16 <= (the age of (the agent of Self))))))

(new-situation)

(do (a Driving with (agent (*Fred))))

;;; NOTE: the below FAILS, as described above because the 
;;; constraint on Fred's age has NOT been enforced (see above notes)
;;; (not (*Fred &? (a Person with (age (10)))))

;;; But can't do this without assuming preconditions...
(not (try-do (a Driving with (agent (*Joe)))))

;;; But can do this...
(try-do (a Driving with (agent ((a Person with (age (21)))))))

;;; But not this
(not (try-do (a Driving with (agent ((a Person with (age (12))))))))

;;; ======================================================================
;;;		add-lists
;;; ======================================================================

(reset-kb)

(wealth has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))

(every Person has
  (wealth ((a Number))))

(every Win-Lottery has
  (agent ((a Person)))
  (add-list (
    (:triple (the wealth of (the agent of Self)) > 1000000))))

(new-situation)

(do-and-next (a Win-Lottery with (agent (*Fred))))

;;; Fred has more than $10...
(not (*Fred &? (a Person with (wealth (10)))))

;;; ======================================================================
;;;		INEQUALITIES
;;; ======================================================================

(reset-kb)

(every Person has
  (spouse ()))

(every Marry has
  (agent ((a Person)))
  (pcs-list (
    (:triple (the agent of Self) /= *Sue))))

(new-situation)

;;; Works, BUT doesn't assert the inequality constraint, as KM thinks its
;;; already true. Hmmm...
(try-do (a Marry))

(not (try-do (a Marry with (agent (*Sue)))))

(print "inherit.km")
;;; File: inherit.km
;;; Author: Peter Clark
;;; Date: March 1999
;;; Purpose: This is a vastly complex test of the inheritance etc. machinery.
;;;	It tests slot-hierarchies, situation hierarchies, isa hierarchies,
;;;	and temporal projection, all combined.

;;; ======================================================================
;;; 			*Global situation
;;; ======================================================================

(reset-kb)
(default-fluent-status *Inertial-Fluent) 

(every Vehicle has
  (engine-parts ((a Engine))))

(every Room has
  (parts ((a Door) (a Door-Handle))))

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

(Car has (superclasses (Vehicle Room)))

(every Car has
  (parts ((a Steering-Wheel)))
  (body-parts ((a Chassis)))
  (bumper-parts ((a Bumper))))

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

(*MyCar has
  (instance-of (Car))
  (parts ((a Sunroof) (a Bumper))))

;;; ---------- slot hierarchy ----------

(body-parts has
  (instance-of (Slot))
  (superslots (parts)))

(engine-parts has
  (instance-of (Slot))
  (superslots (parts)))

(bumper-parts has
  (instance-of (Slot))
  (superslots (body-parts)))

(bumper-cover-parts has
  (instance-of (Slot))
  (superslots (bumper-parts)))


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

(Year-1999 has
  (instance-of (Situation))
  (supersituations (*Global Happy-Year))	  ; multiple supersituationss
  (prev-situation (Year-1998)))


(Happy-Year has
  (instance-of (Situation))
  (supersituations (*Global)))

(Year-1998 has
  (instance-of (Situation))
  (supersituations (*Global)))

(Jan-1999 has
  (instance-of (Situation))
  (supersituations (Year-1999)))

;;; ======================================================================
;;;			Happy-Year
;;; ======================================================================

(in-situation Happy-Year)

(every Car has
  (bumper-parts ((a Smiley-Sticker))))	; put happy sticker on in happy years!

;;; ======================================================================
;;;			Year-1998
;;; ======================================================================

(in-situation Year-1998)

(every Car has
  (engine-parts ((a Exhaust-Filter) 	; eg. government required it
		 (a Engine))))

(*MyCar has
  (parts ((a Chassis with 
	     (color (*Blue)))))
  (bumper-cover-parts ((a Bumper-Cover   ; I scratched my car in 1998
			   with (scratched (t))))))

;;; ======================================================================
;;;			Year-1999
;;; ======================================================================

(in-situation Year-1999)

(every Car has
  (engine-parts ((a Exhaust-Filter) 	; eg. government required it
		 (a Engine))))

(*MyCar has
  (parts ((a Chassis with 
	     (color (*Blue))))))


;;; ======================================================================
;;;			Jan-1999
;;; ======================================================================

(in-situation Jan-1999)

(every Car has
  (engine-parts ((a Exhaust-Filter) 	; eg. government required it
		 (a Engine))))

(*MyCar has
  (parts ((a Radio)			; I just added it
	  (a Chassis with 
	 	(condition (*Dirty))))))

;;; ======================================================================
;;;		SOME VALIDATION TESTS
;;; 	( Issued in the situation Jan-1999 )
;;; ======================================================================

#|
(the parts of *MyCar) ::
Will pull information from a zillion places together and check it's all there.
  Value		from:		CLASS/INSTANCE  SLOT		   SITUATION
 _Door8 			Room		parts 		   *Global				
 _Door-Handle9 			Room		parts		   *Global
 _Steering-Wheel7 		Car		parts		   *Global
 _Sunroof6 			*MyCar		parts		   *Global
 _Engine0			Vehicle		engine-parts	   *Global
				Car		engine-parts	   Year-1999
				Car		engine-parts	   Year-1999
 _Exhaust-Filter1 		Car		engine-parts	   Year-1999
				Car		engine-parts	   Jan-1999
 _Chassis5 			Car		body-parts	   *Global
	   [is *Blue]		*MyCar		parts		   Year-1999
	   [is *Dirty]		*MyCar		parts		   Jan-1999
 _Smiley-Sticker4 		Car		bumper-parts	   Happy-Year
 _Bumper3 			Car		bumper-parts	   *Global
				*MyCar		parts		   *Global
 _Bumper-Cover2 [is scratched]	*MyCar		bumper-cover-parts Year-1998
 _Radio11			*MyCar		parts		   Jan-1999
|#

#|
The below is a nasty little beast, failing in 1.4.0-beta36 and earlier.

instance-of is optimized to use 
	1. find-vals (which doesn't use projection)
	2. fast-slotvals-via-projection (which doesn't use supersituations)

Thus it will fail for a query which requires *both* (i.e. projection into a 
  supersituation), which is what's going on here. "(_Bumper-Cover0 isa Bumper-Cover)"
  should be projected from Year-1998 to Year-1999, and then down to the subsituation
  Jan-1999.

The fix is to modify fast-slotvals-via-projection to use supersituations also.
|#

;;; We need to ask this query first, before other queries cache the right answer
;;; without testing the above!

;;; 11/13/03: Now, we explicitly must change to the parent to issue the query. That 
;;; is, a query in situation S will *NOT* be issued in the supersituations of S
;;; any longer.

(in-situation (the supersituations of (curr-situation)))
((the bumper-cover-parts of *MyCar) isa Bumper-Cover)

(in-situation Jan-1999)
((the bumper-cover-parts of *MyCar) isa Bumper-Cover)

;;; ======================================================================
;;;		OTHER TESTS
;;; ======================================================================

;;; Let's check it's all there!
;(trace)
((the number of (the parts of *MyCar)) = 11)

;;; check my scratch got projected from Year-1998 to Year-1999, and down to Jan-1999
;;; 11/13/03: Again, this no longer happens automatically
(in-situation (the supersituations of (curr-situation)))
((the scratched of (the Bumper-Cover parts of *MyCar)) = t)

(in-situation Jan-1999)
((the scratched of (the Bumper-Cover parts of *MyCar)) = t)

;;; "inherited" from supersituation Year-1999
((the color of (the Chassis parts of *MyCar)) = *Blue)

;;; Jan-1999 assertion
((the condition of (the Chassis parts of *MyCar)) = *Dirty)

;;; Check that being dirty in January doesn't imply being dirty all year
(in-situation Year-1999 
	((the condition of (the Chassis parts of *MyCar)) /= *Dirty))

;;; ======================================================================
;;;  IMPORTANT NEW TEST: Check that rules on INSTANCES are inherited
;;;	down to situations, i.e. must inherit instance-rules, not just 
;;;	instance-values and class-rules.
;;; ======================================================================

(reset-kb)

(Fred has
  (age (20))
  (likes ((the friend of Sue))))

;;; situation-specific = t = hack to prevent rule being clobbered in the
;;; global situation (need this until we separate KM's cache from rules)
(likes has
  (instance-of (Slot))
  (situation-specific (t)))

(new-situation)

(Sue has
  (friend (Lisa)))

;;; ERROR! This fails! 
((the likes of Fred) = Lisa)

(km-format t "(the likes of Fred) = ~a~%" (the likes of Fred))

;;; ======================================================================

(reset-kb)

(owns has
  (instance-of (Slot))
  (fluent-status (*Non-Fluent)))

(*Pete has
  (owns ((a Car))))

(new-situation)

(*Pete has
  (owns ((a House))))

((the number of (the owns of *Pete)) = 2)

;;; ----------------------------------------------------------------------
;;;		TEST INHERIT WITH OVERRIDES WORKS IN SITUATIONS...
;;; ----------------------------------------------------------------------
  
(new-situation)
(bar has (instance-of (Slot)) (dont-cache-values (t)))
(baz has (instance-of (Slot)) (dont-cache-values (t)) (inherit-with-overrides (t)))
(every Foo has (bar (*a)) (baz (*b)))
(the bar of (a Foo))
(the baz of (a Foo))


;;; ======================================================================
;;; test constraints don't override expressions with inherit-with-overrides (Dan Tecuci, 9/11/08)

(reset-kb)

(every Chemical-Entity has (atomic-chemical-formula ((a Formula)))) 
(every Hydrocarbon-Molecule has (atomic-chemical-formula ((must-be-a Formula)))) 
(Hydrocarbon-Molecule has (superclasses (Chemical-Entity))) 
(atomic-chemical-formula has (inherit-with-overrides (t)))

;;; [1] Make sure constraint on subclass does NOT override expression on superclass
(the atomic-chemical-formula of (a Hydrocarbon-Molecule))

;;; ignore  inheritance-problem.km

(print "jandj.km")

;;; File: jandj.km
;;; Author: Peter Clark
;;; Date: Aug 99
;;; Purpose: Brief exercise in story representation!

#|
"Jack and Jill Went up the hill 
   To fetch a pail of water. 
       Jack fell down 
    And broke his crown 
 And Jill came tumbling after.  
[       Up Jack got 
     And home did trot 
  As fast as he could caper 
        Went to bed 
   And plastered his head 
 With vinegar and brown paper. ]"

Some common-sense questions:
 1. What was Jack doing at the start? [Going up the hill]
 2. Where was Jack after going up the hill? [at the top?]
 3. What caused Jack to break his crown?
 4. Did Jack ever achieve his goal?

Jack went up the hill -> Jack at top of the hill.
Jack fell down -> Jack at the bottom of top of the hill?

The group Jack and Jill is at the top of the hill.
Jack fell down -> the group is still at the top?

The group is at the top -> Jack is at the top?
|#

(reset-kb)

(default-fluent-status *Non-Fluent)

(e-status has (fluent-status (*Inertial-Fluent)))
(location has (fluent-status (*Inertial-Fluent)))
(brokenp? has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))


;;; ======================================================================
;;;		I: BACKGROUND AND COMMONSENSE KNOWLEDGE
;;; ======================================================================

(e-status has			; epistemological status
  (instance-of (Slot))
  (cardinality (N-to-1))
  (range (EStatus)))		; = *Ghost or NIL (ie. real!)

(location has
  (instance-of (Slot))
  (cardinality (N-to-1)))	; You can only be in one place at one time

(group-members has
  (instance-of (Slot))
  (inverse (container)))	; give inverse a sensible name

;;; Tops can't be Bottoms and vice-versa
(a Partition with
  (members (Top Bottom)))

;;; If a Group is an agent of some event, then all its members are also agents.
;;; Similarly, location propogates.
(every Thing has
  (agent-of ((the agent-of of (the Group container of Self))))
  (location ((the location of (the Group container of Self)))))

(every Person has
  (parts ((a Head with (parts ((a Crown))))
	  (a Body))))

(*Jack has (instance-of (Person)))
(*Jill has (instance-of (Person)))

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

;;; Below is dangerous! Could be very recursive!
;;; But I want a hill, at least, to have a top!
#| (every Thing has
      (parts ((a Top) (a Bottom)))) |#

;;; [1] Unfortunately, Jack ends up at the bottom of the top of the hill.
;;;     ([1] allows this). We'll leave this for now.
(every Hill has
  (parts ((a Top with			; Less dangerous!
	    (parts ((a Bottom)))))))	; [1]

;;; ----------------------------------------
;;; 		ACTIONS
;;; ----------------------------------------

(Action has (superclasses (Event)))
(Going has (superclasses (Action)))

;;; ----------
;;; Going-Up
;;; ----------

;;; "If you're going up something, then your destination is
;;;  the top of that something."
(every Going-Up has-definition
  (instance-of (Going))
  (direction (*Up)))

(Going-Up has (superclasses (Going)))

(every Going-Up has
  (destination ((the Top parts of (the patient of Self)))))

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

(Moving has (superclasses (Action)))

;;; If you move,
;;;   [1] you're no longer at your old location
;;;   [2] any group you were in is no longer at its old location (it's
;;;	become physically dispersed).
(every Moving has
  (del-list ((:triple (the agent of Self) location			; [1]
		      (the location of (the agent of Self)))
	     (forall (the Group container of (the agent of Self))	; [2]
		     (:triple It location (the location of It))))))

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

(Going has (superclasses (Moving)))

(every Going has
  (add-list ((:triple (the agent of Self) location
		      (the destination of Self)))))

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

(Falling has (superclasses (Going)))

(every Falling has
  (destination ((the Bottom parts of (the location of (the agent of Self))))))

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

(Tumbling has (superclasses (Falling)))

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

(Breaking has (superclasses (Action)))

(every Breaking has
  (agent ((a Person)))			; say
  (object ((a Thing)))
  (add-list ((:triple (the object of Self) brokenp? t))))

;;; ======================================================================
;;;		II: THE STORY
;;; ======================================================================

(S1 has 				; Jack and Jill Going
  (instance-of (Situation))
  (next-situation ((:args S2))))

(S2 has 				; Jack Falling
  (instance-of (Situation))
  (next-situation ((:args S3))))

(S3 has 				; the Crown Breaking
  (instance-of (Situation))
  (next-situation ((:args S4))))

(S4 has 				; Jill Tumbling
  (instance-of (Situation))
  (next-situation ((:args S5))))

(S5 has 				; (end)
  (instance-of (Situation)))

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

(in-situation S1)

(a Hill)			; create the Hill

;;; "Jack and Jill went up the hill..."
;;; [1] Better would be (a Going with ...), and then have the automatic classifier realize
;;; this is a Going-Up. But auto-classification is turned off (temporarily?) in situations.
(a Going-Up with				; [1]
  (agent ((a Group with
	    (group-members (*Jack *Jill)))))
  (direction (*Up))
  (patient ((the Hill))))		

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

;;; "...to fetch a pail of water."
((the agent of (the Going)) has
  (goal ('(a Fetching with
	    (patient ((a Pail with
			 (contents ((a Piece with
				      (material (*Water))))))))))))

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

(in-situation S2)

;;; "Jack fell down..."

;;; NOTE: How do we conclude the "going up" is no longer happening?
;;; The rhyme also doesn't say whether they actually got to the top
;;; of the hill. 

;;; "The going is finished." (but did it complete?)
((the Going) has (e-status (*Ghost)))

;;; ("down" is implicit)
(a Falling with
  (agent (*Jack)))

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

(in-situation S3)

;;; "The falling is finished." (but did it complete?)
((the Falling) has (e-status (*Ghost)))

;;; "...and broke his crown..."

;;; NOTE: There's nothing said about the falling causing the
;;; breaking, although a common-sense reasoner should spot this.
;;; The rhyme also doesn't say that this wasn't a deliberate act.

;;; It also doesn't say whether these are sequential or
;;; simultaneous activities.

(a Breaking with
  (agent (*Jack))
  (object ((the Crown (parts *) of *Jack))))

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

(in-situation S4)

;;; "The breaking is finished." (but did it complete?)
((the Breaking) has (e-status (*Ghost)))

;;; "and Jill came tumbling after." (why?)

(a Tumbling with
  (agent (*Jill)))

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

(in-situation S5)

((the Tumbling) has (e-status (*Ghost)))

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

(global-situation)

#| 
======================================================================
Now we unify in the effects of actions. These effects need to be 
added to the situations S1-S4 which we explicitly created earlier.
The effects should be applied just when the action has finished,
ie. has changed from non-*Ghost [1] to *Ghost [2] status.
[3] (do <action>) is rather procedural: It doesn't really mean "do the 
     action", it means "assert the effects of the action in the resulting sitn"
======================================================================

;;; "Forall actions in all situations, where the action was REAL [1] but
;;;  then became a GHOST [2], assert ("do") the effects of the action [3]."
 (forall (:set S1 S2 S3 S4)
	  (forall2 (in-situation It (the all-instances of Action))
	           (if  (    (in-situation It ((the e-status of It2) /= *Ghost)) ; [1]
		         and (in-situation (the next-situation of It)
	 	 	  	   	      ((the e-status of It2) = *Ghost))) ; [2]
	            then (    (in-situation It (do It2))))))	     		 ; [3]
|#

;;; NEW: need to unify resulting situation of ACTION with the name I've already
;;; GIVEN to it.
(S2 == (in-situation S1 (do (the Going with (agent ((the Group)))))))	; not to be confused with the Falling or Tumbling
(S3 == (in-situation S2 (do (the Falling with (agent (*Jack))))))	; not to be confused with the Tumbling
(S4 == (in-situation S3 (do (the Breaking))))
(S5 == (in-situation S4 (do (the Tumbling))))


;;; ======================================================================
;;;			TEST
;;; ======================================================================

;;; What are the group members doing in S1?
;;; Need axiom that a Group's members are doing what the Group is doing.
(in-situation S1 ((the agent-of of *Jack) isa Going))
(in-situation S1 ((the agent-of of *Jill) isa Going))

;;; What is Jill doing in S4? [Answer: Tumbling. <> test excludes the
;;; "ghost" action of Going which Jill was doing in S1 but is now finished]
(in-situation S4 ((the Action with
		    (agent (*Jill))
		    (e-status ((<> *Ghost))))	; <> means "not equal to"
		  isa Tumbling))

;;; Check Jack's Crown is still broken...
(in-situation S1 (not (the brokenp? of (the Crown))))
(in-situation S5 (the brokenp? of (the Crown)))

;;; Jack's whereabouts...
;;; [1] NB need axiom that if the Group is at the top of the hill, so is Jack!
;;; [2] Need axiom that if Jack falls, then the group is no longer at the Top!
(in-situation S2 
	((the location of *Jack) is '(a Top with (parts-of ((a Hill)))))) ; [1]
(in-situation S5 
	((the location of *Jack) isa Bottom))				  ; [2]

;;; Test Jill's whereabouts...
(in-situation S4 
   ((the location of *Jill) is '(a Top with (parts-of ((a Hill))))))
(in-situation S5 
   ((the location of *Jill) isa Bottom))

;;; Check the group no longer has a location (has become physically dispersed)
(in-situation S5 (not (the location of (the Group))))

;;; -- end --



(print "jandj2.km")

;;; File: jandj2.km
;;; Author: Peter Clark
;;; Date: Aug 99
;;; Purpose: Brief exercise in story representation!

#|
"Jack and Jill Went up the hill 
   To fetch a pail of water. 
       Jack fell down 
    And broke his crown 
 And Jill came tumbling after.  
[       Up Jack got 
     And home did trot 
  As fast as he could caper 
        Went to bed 
   And plastered his head 
 With vinegar and brown paper. ]"

Some common-sense questions:
 1. What was Jack doing at the start? [Going up the hill]
 2. Where was Jack after going up the hill? [at the top?]
 3. What caused Jack to break his crown?
 4. Did Jack ever achieve his goal?

Jack went up the hill -> Jack at top of the hill.
Jack fell down -> Jack at the bottom of top of the hill?

The group Jack and Jill is at the top of the hill.
Jack fell down -> the group is still at the top?

The group is at the top -> Jack is at the top?
|#

(reset-kb)

(default-fluent-status *Inertial-Fluent)

(e-status has (fluent-status (*Inertial-Fluent)))
(location has (fluent-status (*Inertial-Fluent)))
(brokenp? has (fluent-status (*Inertial-Fluent)))
(agent has (fluent-status (*Inertial-Fluent)))


;;; ======================================================================
;;;		I: BACKGROUND AND COMMONSENSE KNOWLEDGE
;;; ======================================================================

(e-status has			; epistemological status
  (instance-of (Slot))
  (cardinality (N-to-1))
  (range (EStatus)))		; = *Ghost or NIL (ie. real!)

(location has
  (instance-of (Slot))
  (cardinality (N-to-1)))	; You can only be in one place at one time

(group-members has
  (instance-of (Slot))
  (inverse (container)))	; give inverse a sensible name

;;; Tops can't be Bottoms and vice-versa
(a Partition with
  (members (Top Bottom)))

;;; If a Group is an agent of some event, then all its members are also agents.
;;; Similarly, location propogates.
(every Thing has
  (agent-of ((the agent-of of (the Group container of Self))))
  (location ((the location of (the Group container of Self)))))

(every Person has
  (parts ((a Head with (parts ((a Crown))))
	  (a Body))))

(*Jack has (instance-of (Person)))
(*Jill has (instance-of (Person)))

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

;;; Below is dangerous! Could be very recursive!
;;; But I want a hill, at least, to have a top!
#| (every Thing has
      (parts ((a Top) (a Bottom)))) |#

;;; [1] Unfortunately, Jack ends up at the bottom of the top of the hill.
;;;     ([1] allows this). We'll leave this for now.
(every Hill has
  (parts ((a Top with			; Less dangerous!
	    (parts ((a Bottom)))))))	; [1]

;;; ----------------------------------------
;;; 		ACTIONS
;;; ----------------------------------------

(Action has (superclasses (Event)))
(Going has (superclasses (Action)))

;;; ----------
;;; Going-Up
;;; ----------

;;; "If you're going up something, then your destination is
;;;  the top of that something."
(every Going-Up has-definition
  (instance-of (Going))
  (direction (*Up)))

(Going-Up has (superclasses (Going)))

(every Going-Up has
  (destination ((the Top parts of (the patient of Self)))))

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

(Moving has (superclasses (Action)))

;;; If you move,
;;;   [1] you're no longer at your old location
;;;   [2] any group you were in is no longer at its old location (it's
;;;	become physically dispersed).
(every Moving has
  (del-list ((:triple (the agent of Self) location			; [1]
		      (the location of (the agent of Self)))
	     (forall (the Group container of (the agent of Self))	; [2]
		     (:triple It location (the location of It))))))

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

(Going has (superclasses (Moving)))

(every Going has
  (add-list ((:triple (the agent of Self) location
		      (the destination of Self)))))

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

(Falling has (superclasses (Going)))

(every Falling has
  (destination ((the Bottom parts of (the location of (the agent of Self))))))

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

(Tumbling has (superclasses (Falling)))

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

(Breaking has (superclasses (Action)))

(every Breaking has
  (agent ((a Person)))			; say
  (object ((a Thing)))
  (add-list ((:triple (the object of Self) brokenp? t))))

;;; ======================================================================
;;;		II: THE STORY
;;; ======================================================================

(S1 has 				; Jack and Jill Going
  (instance-of (Situation))
  (next-situation ((:args S2))))

(S2 has 				; Jack Falling
  (instance-of (Situation))
  (next-situation ((:args S3))))

(S3 has 				; the Crown Breaking
  (instance-of (Situation))
  (next-situation ((:args S4))))

(S4 has 				; Jill Tumbling
  (instance-of (Situation))
  (next-situation ((:args S5))))

(S5 has 				; (end)
  (instance-of (Situation)))

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

(in-situation S1)

(a Hill)			; create the Hill

;;; "Jack and Jill went up the hill..."
;;; Was just "Going", but auto-classification is now disabled in local situations.
(a Going-Up with
  (agent ((a Group with
	    (group-members (*Jack *Jill)))))
  (direction (*Up))
  (patient ((the Hill))))

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

;;; "...to fetch a pail of water."
((the agent of (the Going)) has
  (goal ('(a Fetching with
	    (patient ((a Pail with
			 (contents ((a Piece with
				      (material (*Water))))))))))))

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

(in-situation S2)

;;; "Jack fell down..."

;;; NOTE: How do we conclude the "going up" is no longer happening?
;;; The rhyme also doesn't say whether they actually got to the top
;;; of the hill. 

;;; "The going is finished." (but did it complete?)
((the Going) has (e-status (*Ghost)))

;;; ("down" is implicit)
(a Falling with
  (agent (*Jack)))

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

(in-situation S3)

;;; "The falling is finished." (but did it complete?)
((the Falling) has (e-status (*Ghost)))

;;; "...and broke his crown..."

;;; NOTE: There's nothing said about the falling causing the
;;; breaking, although a common-sense reasoner should spot this.
;;; The rhyme also doesn't say that this wasn't a deliberate act.

;;; It also doesn't say whether these are sequential or
;;; simultaneous activities.

(a Breaking with
  (agent (*Jack))
  (object ((the Crown (parts *) of *Jack))))

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

(in-situation S4)

;;; "The breaking is finished." (but did it complete?)
((the Breaking) has (e-status (*Ghost)))

;;; "and Jill came tumbling after." (why?)

(a Tumbling with
  (agent (*Jill)))

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

(in-situation S5)

((the Tumbling) has (e-status (*Ghost)))

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

(global-situation)

#| 
======================================================================
Now we unify in the effects of actions. These effects need to be 
added to the situations S1-S4 which we explicitly created earlier.
The effects should be applied just when the action has finished,
ie. has changed from non-*Ghost [1] to *Ghost [2] status.
[3] (do <action>) is rather procedural: It doesn't really mean "do the 
     action", it means "assert the effects of the action in the resulting sitn"
======================================================================

;;; "Forall actions in all situations, where the action was REAL [1] but
;;;  then became a GHOST [2], assert ("do") the effects of the action [3]."
 (forall (:set S1 S2 S3 S4)
	  (forall2 (in-situation It (the all-instances of Action))
	           (if  (    (in-situation It ((the e-status of It2) /= *Ghost)) ; [1]
		         and (in-situation (the next-situation of It)
	 	 	  	   	      ((the e-status of It2) = *Ghost))) ; [2]
	            then (    (in-situation It (do It2))))))	     		 ; [3]
|#

;;; NEW: need to unify resulting situation of ACTION with the name I've already
;;; GIVEN to it.
#|
PROBLEM:
[1]: IN S1, *Jack is the agent-of of _Going1592
     In S2, *Jack is the agent-of of _Falling1594
So _Going1592 gets projected forward and unifies (&&) with _Falling1594!

We can avoid this by making the first action Going-Up rather than Going,
to make sure && doesn't unify the values:
	(_Going-Up1592 && _Falling1594) = (_Going-Up1592 _Falling1594)
but that's not nice!

A better solution would be not to project agent-of in the first place. That is,
the agent of an action should be SITUATION-SPECIFIC, and vary between situations, and NOT be projected.
|#
(S2 == (in-situation S1 (do (the Going with (agent ((the Group)))))))	; not to be confused with the Falling or Tumbling
(S3 == (in-situation S2 (do (the Falling with (agent (*Jack))))))	; not to be confused with the Tumbling [1]
(S4 == (in-situation S3 (do (the Breaking))))
(S5 == (in-situation S4 (do (the Tumbling))))


;;; ======================================================================
;;;			TEST
;;; ======================================================================

;;; What are the group members doing in S1?
;;; Need axiom that a Group's members are doing what the Group is doing.
(in-situation S1 ((the agent-of of *Jack) isa Going))
(in-situation S1 ((the agent-of of *Jill) isa Going))

;;; What is Jill doing in S4? [Answer: Tumbling. <> test excludes the
;;; "ghost" action of Going which Jill was doing in S1 but is now finished]
(in-situation S4 ((the Action with
		    (agent (*Jill))
		    (e-status ((<> *Ghost))))	; <> means "not equal to"
		  isa Tumbling))

;;; Check Jack's Crown is still broken...
(in-situation S1 (not (the brokenp? of (the Crown))))
(in-situation S5 (the brokenp? of (the Crown)))

;;; Jack's whereabouts...
;;; [1] NB need axiom that if the Group is at the top of the hill, so is Jack!
;;; [2] Need axiom that if Jack falls, then the group is no longer at the Top!
(in-situation S2 
	((the location of *Jack) is '(a Top with (parts-of ((a Hill)))))) ; [1]
(in-situation S5 
	((the location of *Jack) isa Bottom))				  ; [2]

;;; Test Jill's whereabouts...
(in-situation S4 
   ((the location of *Jill) is '(a Top with (parts-of ((a Hill))))))
(in-situation S5 
   ((the location of *Jill) isa Bottom))

;;; Check the group no longer has a location (has become physically dispersed)
(in-situation S5 (not (the location of (the Group))))

;;; -- end --



(print "jeff.km")

;;;;;;;;;;;     FIRST FILE ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; A trial-event knowledge base intended for encoding
;; knowledge about real-time experimental trials in psychology
;; experiments of the kind run by PsyScope or E-Prime
;;

(reset-kb)


;; A TrialEvent is the main item in a Trial
(TrialEvent has
	    (superclasses (TimePeriod)))


;; the status of a trial event will be read and manipulated by the
;; StartEvent and EndEvent actions to determine which actions
;; to do next
(status has 
	(superclasses (TimePeriod))
	(domain (TrialEvent))
	(range (TrialEventStatus))
	(cardinality (N-to-1))
	(inverse ())
	(fluent-status (*Inertial-Fluent))
	(default-value (*NotStarted))
)


(TrialEventStatus has
		  (superclasses (Thing)))

;; the three possible statuses
(*NotStarted has (instance-of (TrialEventStatus)))
(*Occurring has (instance-of (TrialEventStatus)))
(*Finished has (instance-of (TrialEventStatus)))


;; The StartEvent action

(StartEvent has 
	    (superclasses (Action)))

(every StartEvent has
   (object ((a TrialEvent)))   
   (is-possible? ((((the status of (the object of Self)) = *NotStarted)
		   and (forall (the after of (the object of Self))
			       ((the status of It) = *Finished))
		   and (forall (the meets-inverse of (the object of Self))
			       ((the status of It) = *Occurring)))))
		  
   (del-list ( (((forall (the meets-inverse of (the object of Self))
			 (:triple It status *Occurring)))
		&&
		((forall (the starts of (the object of Self))
			 (:triple It status *NotStarted)))
		&&
		((forall (the starts-inverse of (the object of Self))
			 (:triple It status *NotStarted))))) )

   (add-list ( (((forall (the meets-inverse of (the object of Self))
			 (:triple It status *Finished)))
		&&
		((forall (the starts of (the object of Self))
			 (:triple It status *Occurring)))
		&&
		((forall (the starts-inverse of (the object of Self))
			 (:triple It status *Occurring))))) )

	      
;   (add-list ((:triple (the object of Self) status *Occurring)))
   ;; NOTE!! have to add triples (somehow!) to change the status
   ;; of all events w/ starts or starts-inverse = Self
)

(EndEvent has
	  (superclasses (Action)))

(every EndEvent has
   (object ((a TrialEvent)))
   (is-possible? ((((the status of (the object of Self)) = *Occuring)
		   and (forall (the finishes of (the object of Self))
			       ((the status of It) = *Occurring))
		   and (forall (the finishes-inverse of (the object of Self))
			       (the status of It) = *Occurring)
		   and (forall (the during-inverse of (the object of Self))
			       (the status of It) = *Finished))))
   (del-list ((:triple Self status *Occurring)))
   (add-list ((:triple Self status *Finished)))
   ;; NOTE! have to add triples (somehow!) to change the status
   ;; of all the events w/ met-by self
)
	    

(Action has (superclasses (Event)))

(InitTrial has (superclasses (Action)))
(every InitTrial has
    (add-list 
     ( (forall (the instances of TrialEvent)
	       (:triple It status *NotStarted)) ))
)

;;; an example

(*Stim has
       (instance-of (TrialEvent))
       (starts (*ResponsePeriod))
       (starts-inverse (*ResponsePeriod)))

(*ResponsePeriod has
		 (instance-of (TrialEvent))
		 (meets (*Key)))

(*Key has
      (instance-of (TrialEvent)))
		 
;;;;;;;;;;;;; the file called allen.km ;;;;;;;;;;;;;;;;;;;;;;;



;;; Based on Allen's temporal logic ("Maintaining Knowledge about Temporal
;;; Intervals", James Allen, Communications of the ACM, 26(11), 1983,
;;; pp. 832-843.  Reprinted in "Readings in Knowledge Representation".

; Allen's transitivity relations added by Jefferson Provost

(TimePeriod has (superclasses (Thing)))

(timePeriod-relation-group has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (subslots (before after overlaps-interval during
		    during-inverse starts starts-inverse finishes
		    finishes-inverse meets meets-inverse
		    interval-contained-in)))

;;; equal and notEqual are additional relations between TimePeriods,
;;; but they are not subslots of TimePeriod because they're more general
;;; than it.

(equal has
   (instance-of (slot))
   (domain (Thing))
   (range (Thing))
   (cardinality (N-to-N))
   (inverse (equal)))

(notEqual has
   (instance-of (slot))
   (domain (Thing))
   (range (Thing))
   (cardinality (N-to-N))
   (inverse (notEqual)))

;;; X before Y: 
;;; XXX YYY
(before has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (after)))
   
(after has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (before)))

;;; X overlaps-interval Y:
;;; XXX
;;;  YYY
(overlaps-interval has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (overlaps-interval)))

;;; X during Y: 
;;;   XXX
;;;  YYYYY
(during has
   (instance-of (slot))
   (superslots (interval-contained-in))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (during-inverse)))

(during-inverse has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (during)))

;;; X starts Y:
;;;  XXX
;;;  YYYYY
(starts has
   (instance-of (slot))
   (superslots (interval-contained-in))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (starts-inverse)))

(starts-inverse has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (starts)))

;;; X finishes Y:
;;;     XXX
;;;   YYYYY
(finishes has
   (instance-of (slot))
   (superslots (interval-contained-in))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (finishes-inverse)))

(finishes-inverse has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (finishes)))

;;; X meets Y:
;;; XXXYYY
(meets has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (meets-inverse)))

(meets-inverse has
   (instance-of (slot))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (meets)))

;;; interval-contained-in generalizes STARTS, DURING, and FINISHES
(interval-contained-in has
   (instance-of (slot))
   (subslots (equals-interval starts during finishes))
   (domain (TimePeriod))
   (range (TimePeriod))
   (cardinality (N-to-N))
   (inverse (interval-within)))

(interval-within has
		 (instance-of (slot))
		 (subslots (equals-interval starts-inverse during-inverse
					    finishes-inverse))
		 (domain (TimePeriod))
		 (range (TimePeriod))
		 (cardinality (N-to-N))
		 (inverse (interval-contained-in)))

;; equal-interval specializes equal
(equal-interval has
		(instance-of (slot))
		(domain (TimePeriod))
		(range (TimePeriod))
		(cardinality (N-to-N))
		(inverse (not-equal-interval)))

;;
;; The transitivity relations.
;;
(every TimePeriod has
       (before ((the before of (the before of Self))
		(the before of (the interval-contained-in of Self))
		(the interval-within of (the before of Self))
		(the meets of (the before of Self))
		))
       (after ((the after of (the after of Self))
	       (the after of (the interval-contained-in of Self))
	       (the interval-within of (the after of Self))
	       (the meets-inverse of (the after of Self))
	       ))
       (starts ((the starts of (the starts of Self))
		(the starts of (the equal-interval of Self))))
       (starts-inverse ((the starts-inverse of (the starts-inverse of Self))
			(the starts-inverse of (the equal-interval of Self))))

       (finishes ((the finishes of (the finishes of Self))
		  (the finishes of (the equal-interval of Self))))
       (finishes-inverse 
	((the finishes-inverse of (the finishes-inverse of Self))))
       (during ((the during of (the during of Self))))
       (equal-interval (Self (the TimePeriod equal of Self)))
		       
	       
		
)



;;******************
;; examples

(*T1 has
     (instance-of (TimePeriod))
     (before (*T2)))

(*T2 has
     (instance-of (TimePeriod))
     (before (*T3)))
				
(*T3 has
     (instance-of (TimePeriod)))

(*T4 has
     (instance-of (TimePeriod))
     (starts (*T1)))

(*T5 has
     (instance-of (TimePeriod))
     (meets (*T1)))

(*Big1 has
       (instance-of (TimePeriod))
       (during-inverse (*T1 *T2 *T3 *T4 *T5)))

(*Big2 has 
       (instance-of (TimePeriod))
       (after (*Big1)))

;;; Test- 
(new-situation)
(do-and-next (a InitTrial))
((the instances of TrialEvent) = (:set *Key *ResponsePeriod *Stim))
((the status of *Key) = *NotStarted)
((the status of *ResponsePeriod) = *NotStarted)
((the status of *Stim) = (*NotStarted))
(a StartEvent with (object (*Stim)))
(do-and-next (thelast StartEvent))
((the status of *Stim) = *Occurring)
((the status of *ResponsePeriod) = *Occurring)
((the status of *Key) = *NotStarted)

#|
;;;;;;;;;;;;;;;;;;;;; A TRACE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

[_Situation42] KM> (reload-kb "trialevent.km")

KM> (new-situation)
(_Situation43)

[_Situation43] KM> (do-and-next (a InitTrial))
(_Situation45)

[_Situation45] KM> (the instances of TrialEvent)
(*Key *ResponsePeriod *Stim)

[_Situation45] KM> (the status of *Key)
(*NotStarted)

[_Situation45] KM> (the status of *ResponsePeriod)
(*NotStarted)

[_Situation45] KM> (the status of *Stim)
(*NotStarted)

[_Situation45] KM> (a StartEvent with (object (*Stim)))
(_StartEvent46)

[_Situation45] KM> (the del-list of _StartEvent46)
((:triple *Stim status *NotStarted) 
 (:triple *ResponsePeriod status *NotStarted))

[_Situation45] KM> (the add-list of _StartEvent46)
((:triple *Stim status *Occurring) 
 (:triple *ResponsePeriod status *Occurring))

[_Situation45] KM> (do-and-next (thelast StartEvent))
|#
;;; ignore  johns-location.km


;;; ignore  kanal.km

(print "ken.km")

(reset-kb)

(object has 
	(instance-of (Slot)) 
	(situation-specific (t))
	(fluent-status (*Inertial-Fluent)))

(destination has 
	(instance-of (Slot)) 
	(situation-specific (t))
	(fluent-status (*Inertial-Fluent)))

(every Shut-Out has
  (object ((a Tangible-Entity)))
  (destination ((a Enclosure)))
  (resulting-state ((a Be-Shut-Out with
                        (destination ((the destination of Self))))))
;  (pcs-list ((:triple (the object of Self)
;		 object-of
;		 (mustnt-be-a Be-Shut-Out with
;			(destination ((the destination of Self)))))))
  (add-list ((:triple 
                 (the object of Self) 
                 object-of
                 (the resulting-state of Self)))))

(every Admit has
  (object ((a Tangible-Entity)))
  (destination ((a Enclosure)))
;  (defeats ((the+ Be-Shut-Out with
;                (object ((the object of Self)))
;                (destination ((the destination of Self))))))
  (defeats ((every Be-Shut-Out with
		(object ((the object of Self)))
	        (destination ((the destination of Self))))))
;  (defeats ((allof (the Be-Shut-Out object-of of (the object of Self))
;	     where ((the destination of It) = (the destination of Self)))))
  (pcs-list ((:triple (the object of Self)
		      object-of
		      (a Be-Shut-Out with
		         (destination ((the destination of Self)))))))
  (del-list ((forall (every Be-Shut-Out with
			(object ((the object of Self)))
	                (destination ((the destination of Self))))
	     (:triple (the object of Self) object-of It)))))
;  (del-list ((forall ((allof (the Be-Shut-Out object-of of (the object of Self))
;		       where ((the destination of It) = (the destination of Self))))
;	     (:triple (the object of Self) object-of It)))))
		     


(*Fred has (instance-of (Person)))
(*Boodles has (instance-of (Nightclub)))

(Nightclub has (superclasses (Enclosure)))	; ?
(Person has (superclasses (Tangible-Entity)))

(new-situation)

;;; Can't admit a non-shut-out person
(not (try-do-and-next 
	(a Admit with (object (*Fred)) (destination (*Boodles)))))

(try-do-and-next (a Shut-Out with (object (*Fred)) (destination (*Boodles))))

;;; Now should be able to admit him
(try-do-and-next (a Admit with (object (*Fred)) (destination (*Boodles))))

;;;  Can't readmit him
(not (try-do-and-next (a Admit with (object (*Fred)) (destination (*Boodles)))))

(next-situation)

;(trace)

;;; Try again, this time ASSUME that he was shut out in the previous situation
(do-and-next (a Admit with (object (*Fred)) (destination (*Boodles))))

;;; We get bitten by the annoying unification problem

#|
BUG: With pcs-list exposed, KM (i) finds what to delete (NIL), (ii) evaluating
the pcs-list CREATES something X to delete (iii) KM then fails to delete it. Thus
in the next situation we have both X and the added constraint (<> X) = error.
The fix is to collect the add-list *AFTER* the pcs-list has been evaluated, but
this hits another bug in KM which is still to fix.
|#
;;; Shut him out twice - but why don't these work?
(try-do-and-next (a Shut-Out with (object (*Fred)) (destination (*Boodles))))

;;; You can shut him out twice (without the PC stopping this)
(try-do-and-next (a Shut-Out with (object (*Fred)) (destination (*Boodles))))

;;; Should remove *both* of the Be-Shut-Outs
(try-do-and-next (a Admit with (object (*Fred)) (destination (*Boodles))))
(print "km-overview.km")

#|

All buy events have
 - a buyer and a seller (both of type agent)
 - an object which is bought
 - some money equal to the cost of the object
 - two `give' subevents, in which:
	1. The buyer gives the money to the seller
	2. The seller gives the object to the buyer.''

(Buy has (superclasses (Event)))
	
(every Buy has
  (buyer ((a Agent)))
  (object ((a Thing)))
  (seller ((a Agent)))
  (money ((the cost of (the object of Self))))
  (subevent1 ((a Give with
               (agent ((the buyer of Self)))
               (object ((the money of Self)))
               (rcpt ((the seller of Self))))))
  (subevent2 ((a Give with
               (agent ((the seller of Self)))
               (object ((the object of Self)))
               (rcpt ((the buyer of Self)))))))
|#

(reset-kb)

"--- instances ---"

*Fred

1

"--- existential quantification ---"

(a Cat)

(age has
      (instance-of (Slot))
      (domain (Physobj))
      (range (Number))
      (inverse (is-age-of))
      (cardinality (N-to-1)))         ; one age per thing

"--- instance frames ---"

(*Fred has (instance-of (Person)))

(*Fred has (age (32)))

(showme *Fred)

(the age of *Fred)

(*Fred has (owns ((a Car))))

(the owns of *Fred)

(showme (thelast Car))

"--- inverses ---"

(the owns-of of (thelast Car))

"--- embedded units ---"

(*Joe has (instance-of (Person)) (owns ((a Car with (color (*Red))))))

"--- access paths ---"

(the color of (the owns of *Joe))

; (*Joe owns * color) - no longer valid

"--- class frames and inheritance ---"

(Person has (superclasses (Physobj)))

(every Person has (lives-in ((a House))))

(every House has (parts ((a Door) (a Roof))))

(the lives-in of *Joe)

(the parts of (the lives-in of *Joe))

"--- tracing ---"

;(trace)	 - not for test suite

(the parts of (the lives-in of *Joe))

(untrace)

(taxonomy)

"--- rules ---"

(every Person has
      (is-voter ((if ((the age of Self) >= 18) then *Yes
                  else (if ((the age of Self) < 18) then *No)))))

(the is-voter of *Fred)

(*Joe has (age (12)))

(the is-voter of *Joe)

"--- Self ---"

(*Fred has (favorite-color (*Blue)))

(every Person has (likes-color ((the favorite-color of Self))))

(the likes-color of *Fred)

"--- set expressions ---"

(every Person)

(allof (the all-instances of Person) where ((the age of It) > 18))

(forall (the all-instances of Person) where ((the age of It) > 18) (the favorite-color of It))

"--- arithmetic ---"

(1 + 1)

(every Person has (age-in-days (((the age of Self) * 365))))

(the age-in-days of *Fred)

"--- reference by description ---"

(the Person with (favorite-color (*Blue)))

(every Person with (favorite-color (*Blue)))

"--- multiple inheritance ---"

(every Big-Car has 
        (parts ((a Engine with (size (*Large))))))

;; "Every powerful car has a powerful engine."
 (every Powerful-Car has
        (parts ((a Engine with (power (*Lots))))))

;; "Suburbans are both big and powerful cars."
 (Suburban has 
        (superclasses (Big-Car Powerful-Car)))

;;; "What are the parts of a Suburban?"
 (the parts of (a Suburban))

;;; "Show me the frame representing the last engine."
;;; [Note: Here KM makes a non-deductive step, deciding the two 
;;;  inherited Engines are coreferential because they are (i) of the
;;;  same class (or one's classes subsumes the others') and (ii) their
;;;  unification doesn't violate any constraints.
;;;; Thus: The resulting Engine is both powerful and average-sized]
(showme (thelast Engine))

;(every Car has (parts ((a Engine with (size (*Average))))))
;(Car has (superclasses (Vehicle)))
;(every Vehicle has (parts ((a Engine with (power (*Lots))))))
;(the parts of (a Car))
;(showme (thelast Engine))

"--- another example ---"

(every Person has (parts ((a Head) (a Leg) (a Leg))))

(*Fred has (parts ((a Leg))))

(the parts of *Fred)

"--- constraints ---"

(every Person has (friends ((must-be-a Person))))

(every Person has (spouse ((<> Self))))

; Deliberate error for km-overview.script but don't want this in test-suite.km
;(*Fred has (spouse (*Fred)))

;(the spouse of *Fred)

(every Airplane has (parts ((exactly 2 Wing))))

"--- defined classes ---"

(every Mexican has-definition (instance-of (Person)) (lives-in (*Mexico)))

(*Fred has (lives-in (*Mexico)))

(every Mexican has (mood (*Happy)))

(the mood of *Fred)

(the mood of (a Person with (lives-in (*Mexico))))

"--- text generation ---"

(every Remove has
  (text ((:seq "Remove" (the object of Self) "from" (the location of Self)))))

(the text of (a Remove with 
		(object ((a Sample)))
		(location ((a Box)))))

(make-sentence (the text of (a Remove with 
		(object ((a Sample)))
		(location ((a Box))))))

(make-sentence (the text of (a Remove with 
		(object ((a Disk)))
		(location ((a Disk-Drive))))))


"--- slot hierarchies ---"

(parts has (instance-of (Slot)) (subslots (mechanical-parts)))

(every Airplane has (mechanical-parts ((a Jet-Engine))))

(the parts of (a Airplane))

"--- situations ---"

(*Mike has (birthdate (1963)))

(birthdate has
      (instance-of (Slot))
      (fluent-status (*Non-Fluent)))

(age has
      (instance-of (Slot))
      (fluent-status (*Inertial-Fluent)))

(new-situation)

(*Mike has (age (27)))

(the age of *Mike)

; (global-situation)

; (not (the age of *Mike))

(in-situation (thelast Situation))

(the birthdate of *Mike)

(next-situation)

(the age of *Mike)

(next-situation)

(*Mike has (age (28)))

(the age of *Mike)

(global-situation)

(in-situation (thelast Situation) (the age of *Mike))

(allof (the all-instances of Situation) where (in-situation It ((the age of *Mike) = 27)))

"--- actions ---"

(position has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Action has (superclasses (Event)))

(Switching-On has (superclasses (Action)))
(every Switching-On has
  (object ((a Switch)))
  (del-list ((:triple (the object of Self) position *Down)))
  (add-list ((:triple (the object of Self) position *Up))))

(new-situation)

(*MySwitch == (a Switch with (position (*Down))))

(do-and-next (a Switching-On with (object (*MySwitch))))

(the position of *MySwitch)

(curr-situation)

(the prev-situation of (curr-situation))

"--- previous situations are preserved ---"

(in-situation (the prev-situation of (curr-situation)) (the position of *MySwitch))

(allof (the all-instances of Situation) where (in-situation It ((the position of *MySwitch) = *Down)))


(print "line.km")

;;; Fred moves up the line to get a hamburger...

(reset-kb)

(agent has (fluent-status (*Inertial-Fluent)))
(object has (fluent-status (*Inertial-Fluent)))
(location has (fluent-status (*Inertial-Fluent)))
(next-event has (fluent-status (*Fluent)))
(subevent has (fluent-status (*Non-Fluent)))
(first-subevent has (fluent-status (*Non-Fluent)))

(every Move-Forward has
  (agent ((a Thing)))
  (del-list ((:triple (the agent of Self) location 
				(the location of (the agent of Self)))))
  (add-list ((:triple (the agent of Self) location
				(the forward-position of 
					(the location of (the agent of Self)))))))

(every Buy-Hamburger has
  (agent ((a Thing)))
  (first-subevent ((the Move-Forward subevent of Self)))
  (subevent 
    ((a Move-Forward with
      (agent ((the agent of Self)))
      (next-event ((if   ((the location of (the agent of Self)) isa Counter)
		    then (the Order subevent of Self))
		   (if   (not 
			  ((the location of (the agent of Self)) isa Counter))
		    then (the Move-Forward subevent of Self)))))
    (a Order with
      (agent ((the agent of Self)))
      (object ((a Hamburger)))))))

(every Order has
  (add-list ((:triple (the agent of Self) posesses (the object of Self)))))


#|
*A *B *C *D *Counter
|#
(*A has (forward-position (*B)))
(*B has (forward-position (*C)))
(*C has (forward-position (*D)))
(*D has (forward-position (*Counter)))

(*Counter has (instance-of (Counter)))

(new-situation)

(*Fred has (location (*A)))

(*FredsPlan == (a Buy-Hamburger with (agent (*Fred))))

(do-plan *FredsPlan)

;; tests
((the location of *Fred) = *Counter)
((the posesses of *Fred) isa Hamburger)



(print "loadkb.km")

(reset-kb)

(a Cat)
(save-kb "tmp.km")
(load-kb "tmp.km")




;;; ignore  looping.km


;;; ignore  looping2.km

(print "looping3.km")

#|
This previously caused infinite loop as handle-looping didn't add new
entry to stack before recursing.

We have    Breach2 
		agent Thing
			agent-of Create

and so Create && Breach2 unify (as Breach2 isa Thing, rather 
idiosyncratically). Create = Breach2 has (result ((result of Breach2))) and
hence the looping.

In this case, the attempt to recover from the looping causes more looping
which isn't detected, as the recovery omited to stack the recovery call
(simple bug).
|#

(reset-kb)

(every Breach2 has
       (result ((a Spatial-Entity with
		   (plays ((a Portal))))))
       ;; the agent of Breach is the agent in the Creation of the Portal
       (agent ((a Thing with
	         (agent-of ((a Thing) (must-be-a Create with
					(result ((the result of Self))))))))))

(*B2 == (a Breach2))
(*C2 == (the first of (the agent-of of (the agent of *B2))))
(*S2 == (the result of *C2))

#|
KM(20): (reload-kb "looping.km")
Resetting KM...
Loading looping.km...
Resetting KM...
1 -> (every Breach2 has
      (result ((a Spatial-Entity with (plays ((a Portal))))))
      (agent
       ((a Thing with
         (agent-of
          ((a Thing)
           (must-be-a Create with (result ((the result of Self))))))))))+A
(Will now trace absolutely everything)
1 -> (every Breach2 has
      (result ((a Spatial-Entity with (plays ((a Portal))))))
      (agent
       ((a Thing with
         (agent-of
          ((a Thing)
           (must-be-a Create with (result ((the result of Self))))))))))z
1 <- (Breach2)                             [(every
                               ...
1 -> (*B2 == (a Breach2))
1 <- (*B2)                                 [(*B2 == (a Breach2))]
1 -> (*C2 == (the first of (the agent-of of (the agent of *B2))))
2  -> (the first of (the agent-of of (the agent of *B2)))
3   -> (the agent-of of (the agent of *B2))
4    -> (the agent of *B2)
4     (1) From inheritance: (a Thing with
                             (agent-of
                              ((a Thing)
                               (must-be-a
                                Create
                                with
                                (result ((the result of *B2)))))))
5     -> (a Thing with
          (agent-of
           ((a Thing)
            (must-be-a Create with
             (result ((the result of *B2)))))))  [for (the
                                                       agent
                                                       of
                                                       *B2)]
5     <- (_Thing1)                             [(a
                                   ...
4    <- (_Thing1)                             [(the agent of *B2)]
4    -> (the agent-of of _Thing1)
4     (1) Local value(s): (:set (a Thing)
                           (must-be-a Create with
                            (result ((the result of *B2))))
                           *B2)
5     -> (:set (a Thing)
          (must-be-a Create with (result ((the result of *B2))))
          *B2)  [for (the agent-of of _Thing1)]
6      -> (a Thing)                      [for (the agent-of of _Thing1)]
6      <- (_Thing2)                             [(a
                                   ...
5     <- (_Thing2 *B2)                         [(:set
                                ...
4     (1b) Test values against constraints ((must-be-a
                                             Create
                                             with
                                             (result
                                              ((the result of *B2)))))
4     Enforcing constraints ((must-be-a Create with
                              (result ((the result of *B2)))))
5     -> (_Thing2 & (a Create with (result ((the result of *B2)))))
5     <- (_Thing2)                             [(_Thing2
                             ...
5     -> (*B2 & (a Create with (result ((the result of *B2)))))
5     <- (*B2)                                 [(*B2
                                 ...
4    <- (_Thing2 *B2)                         [(the agent-of of _Thing1)]
3   <- (_Thing2 *B2)                         [(the
                                 ...
3   -> (the first of (:set _Thing2 *B2))
3   <- (_Thing2)                             [(the
                                 ...
2  <- (_Thing2)                             [(the
                                 ...
(COMMENT: (*C2 & _Thing2) unified to be *C2)
1 <- (*C2)                                 [(*C2
                                 ...
1 -> (*S2 == (the result of *C2))
2  -> (the result of *C2)
2   (1) Local value(s): (the result of *B2)
3   -> (the result of *B2)               [for (the result of *C2)]
3    (1) Local value(s): (the result of *B2)
3    Looping on (the result of *B2)!
3    Just using values found so far, = ((the result of *B2))...
3    Looping on (the result of *B2)!
3    Just using values found so far, = ((the result of *B2))...
3    Looping on (the result of *B2)!
3    Just using values found so far, = ((the result of *B2))...
|#

;;; ignore  looping4.km

(print "misc.km")

;;; ======================================================================
;;; Miscellaneous tests that bugs are still removed!
;;; ======================================================================

(reset-kb)

;;; ======================================================================
;;;		UNIFICATION OF INSTANCES
;;; ======================================================================

;; An instance with a definition. Successful classification causes unification 
;;; with this instance, rather than placing it as a class.

(London has-definition
   (instance-of (City))		; most general class
   (capital-of (UK)))

(London has
  (instance-of (Big-City))	; most specific class
  (population (10000000)))

(Big-City has (superclasses (City)))

;;; Demo query:
(the population of (a City with (capital-of (UK))))

;;; --------------------
;;; Ping Xue pointed out this bug in KM1.2.2, now fixed in 1.3.

(reset-kb)

(London has-definition 
   (instance-of (City)) 
   (size (Big)))

(the City with (size (Big)))		; fails in 1.2.2, should return London

;;; ======================================================================
;;;		SET UNIFICATION
;;; ======================================================================

(reset-kb)

;;; Check set unification bug is removed
((the number of (((a Car) (a Car) (a Car) *MyCar) && (*MyCar (a Car) (a Car)))) = 4)

((the number of (((a Cat) *MyCat) && (*MyCat))) = 2)

;;; Similarly with situations (where the problem first appeared)

(_S1 has (instance-of (Situation)) (supersituation (*Global)))

(_S2 has (instance-of (Situation)) (supersituation (*Global)))

(_S1 == _S2)

(in-situation _S1)

(showme _S1)

(showme _S2)

(not (_S2 = *Global))		;;; <-- check no faulty bindings!

(in-situation *Global)

;;; ======================================================================
;;;	PROJECTION OF CLASS-MEMBERSHIP OVER MULTIPLE SITUATIONS
;;; ======================================================================

(new-situation)

(*FredsCar has (instance-of (Car)))

(do-and-next nil)
(do-and-next nil)
(do-and-next nil)

(*FredsCar isa Car)		 ; The test! Should be still projected.

;;; ======================================================================

(reset-kb)
;((the name of (:seq *pete *joe)) = ("pete and joe"))
;((the name of (:seq *pete *joe *mike)) = ("pete, joe, and mike"))
;((the name of (:set (:seq *pete *joe) (:seq *sue *mike (:set *fred *alan)))) 
;	 = ("pete and joe and sue, mike, fred, and alan"))

((make-phrase (andify (:set *pete *joe))) = "pete and joe")
((make-phrase (andify (:set *pete *joe *mike))) = "pete, joe, and mike")
((make-phrase (andify (:set (make-phrase (andify (:set *pete *joe *john)))
	   		   (make-phrase (andify (:set (make-phrase (andify (:set *sue *mike *steve)))
					              (make-phrase (andify (:set *fred *alan *bob)))))))))
	= "pete, joe, and john and sue, mike, and steve and fred, alan, and bob")


;;; ======================================================================
;;;	Check km-assert does a union rather than unification of values
;;; ======================================================================
#|
Suppose _Car1 is *Red in Situation1. Then we paint _Car2 *Red, to reach Situation2:

	SITUATION1			SITUATION2

	*Red				ADD: (_Car2 color *Red)
	  color-of: _Car1		     (*Red color-of _Car2)

When adding (*Red color-of _Car2), we want to gather the old values of (*Red color-of),
namely _Car1, and then *append* ****NOT UNIFY*** the new value, _Car2, to that list.
Otherwise, _Car1 and _Car2 will be unified!
|#

(reset-kb)

(EVAL '(PROGN (SETQ *OLD-LINEAR-PATHS* *LINEAR-PATHS*) T))
(SETQ *LINEAR-PATHS* T)

(Action has (superclasses (Event)))
(Painting has (superclasses (Action)))

(color has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(every Painting has
  (object ((a Thing)))
  (color ())
  (del-list ((:triple (Self object) color (Self object * color))))
  (add-list ((:triple (Self object) color (Self color)))))

(owned-by has 
  (instance-of (Slot))
  (fluent-status (*Non-Fluent)))
  
(licence-plate has 
  (instance-of (Slot))
  (fluent-status (*Non-Fluent)))
  
(new-situation)
(a Car with 
   (color (*Red))
   (owned-by (*Joe))
   (licence-plate ("RED123")))

(a Car with
   (color (*Blue))
   (owned-by (*Pete))
   (licence-plate ("BLU456")))

;;; Old Bug: This will unify the two cars!
(do-and-next (a Painting with
		(object ((the Car with (owned-by (*Pete)))))
		(color (*Red))))

;;; Check they are still distinct!
((the number of (every Car)) = 2)	

((the color of (the Car with (owned-by (*Pete)))) = *Red)
((the color of (the Car with (owned-by (*Joe)))) = *Red)
((the licence-plate of (the Car with (owned-by (*Pete)))) = "BLU456")
((the licence-plate of (the Car with (owned-by (*Joe)))) = "RED123")

;;; ======================================================================
;;;		"SOFT LANDING" FROM A LOOP DETECTION
;;; ======================================================================
#|
Under KM1.4.0-beta3, in the local situation KM does 
  (_Engine23 [from *Global] && (a Engine with (connects ((the Wheels parts of _Car34)))))
Before unifying, KM does a subsumption check that (a Engine...) subsumes _Engine23,
requiring expanding the definite expression (the Wheels parts of...), which triggers
a looping detection on the original query (the parts of ...). So this query fails,
triggering (successful) projection from the previous situation.

Under the KM1.4.0-beta4, KM caches partial computation of values. Here, before this
subsumption check, (_Wheels22 _Engine23) is computed (as in beta3), and cached 
(unlike beta3). When the loop is later detected, KM does a "soft landing" by retrieving 
the cached values (thus not triggering projection), rather than just failing returning
NIL (which triggered projection in beta3).

In addition, under beta4, we add in a quick check in the subsumption checker to 
prevent unnecessary expansion of a few paths too, including this one.
|#

(EVAL '(PROGN (SETQ *LINEAR-PATHS* *OLD-LINEAR-PATHS*) T))

(reset-kb)

(every Car has
  (parts ((a Engine with (connects ((the Wheels parts of Self))))
	  (a Wheels))))

(new-situation)

(next-situation)

(in-situation *Global (a Car))

;;; This triggers projection in KM1.4.0-beta3, but should not in more recent versions.
;;; No easy way of spotting the error
(the parts of (thelast Car))

;;; ======================================================================
;;; Test single-valued slots force unification of values

(reset-kb)

(every Person has 
  (spouse ((a Person))))

(Man has (superclasses (Person)))

(every Man has
  (spouse ((a Woman))))

(spouse has
  (instance-of (Slot))
  (cardinality (N-to-1)))

((the number of (the spouse of (a Man))) = 1)

;;; ======================================================================
;;;   Check the conditional nature of projecting single-valued slots:
;;; ======================================================================

(reset-kb)

(spouse has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(new-situation)

(*Fred has (spouse (*Sue)))

(next-situation)

(*Fred has (spouse (*Jane)))

;;; Check *Sue doesn't get projected so *Fred has two wives
((the spouse of *Fred) = *Jane)

;;; ======================================================================
;;; Check that situation-specific values are projected, even
;;; if there is a global expression for computing them.
;;; (This test only succeeds with eager projection, in 1.4.0-beta4+)

(reset-kb)

(parts has
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(every Car has (parts ((a Engine))))

(new-situation)

(*MyCar has (instance-of (Car)))

;(_X == (the parts of *MyCar))
(*MyCar has (parts (_X)))

(next-situation)

((the parts of *MyCar) = _X)

;;; ======================================================================

((the number of nil) = 0)

;;; ======================================================================
;;;	Check subslot values are unioned, rather than unified
;;; ======================================================================

(reset-kb)

(parts has
  (instance-of (Slot))
  (subslots (body-parts engine-parts)))

(every Car has
  (body-parts ((a Bolt)))
  (engine-parts ((a Bolt))))

((the number of (the parts of (a Car))) = 2)

; ======================================================================
;		TEST ALL AGGREGATION SLOTS
; ======================================================================

(reset-kb)
 
(*MySet has (members (1 2 3 4 5 6 7 8 9 10)))

((the first of (the members of *MySet)) = 1)
((the second of (the members of *MySet)) = 2)
((the third of (the members of *MySet)) = 3)
((the fourth of (the members of *MySet)) = 4)
((the fifth of (the members of *MySet)) = 5)
; get rid of these again...
;((the sixth of (the members of *MySet)) = 6)
;((the seventh of (the members of *MySet)) = 7)
;((the eighth of (the members of *MySet)) = 8)
;((the ninth of (the members of *MySet)) = 9)
;((the tenth of (the members of *MySet)) = 10)
((the last of (the members of *MySet)) = 10)
((the min of (the bag of (the members of *MySet))) = 1)
((the max of (the bag of (the members of *MySet))) = 10)
((the sum of (the bag of (the members of *MySet))) = 55)
;((the difference of (the bag of (the members of *MySet))) = -53)
;((the product of (the bag of (the members of *MySet))) = 3628800)
;((the quotient of (the bag of (the members of *MySet))) = 1/3628800)
((the number of (the members of *MySet)) = 10)

;;; ========================================
;;;	Check unification is global...
;;; ========================================

(reset-kb)

(_Car1 has
  (instance-of (Car))
  (parts (*part1)))

(_Car2 has
  (instance-of (Car))
  (parts (*part2)))

(_S1 has (instance-of (Situation)))

(in-situation _S1)

(_Car1 has
  (instance-of (Car))
  (parts (*part3)))

(_Car2 has
  (instance-of (Car))
  (parts (*part4)))

(_Car1 == _Car2)

;; was 3 in km 1.4.0-beta5 
((the number of (the parts of _Car1)) = 4)

;;; Test unifying situations without error:

; Can't do this now with situations mode. It's a weird thing to do anyway!
; (_S1 == *Global)
; ((the number of (the parts of _Car1)) = 4)

;;; ======================================================================
;;; Check proper reset of cache
;;; ======================================================================

(reset-kb)

(every Car has (parts ((a Wheel))))

(*MyCar has (instance-of (Car)))

((the number of (the parts of *MyCar)) = 1)   ; *MyCar parts flagged as done

(every Car has (parts ((a Engine))))		; add new property; should unflag *MyCar

((the number of (the parts of *MyCar)) = 2)

(Car has (superclasses (Vehicle)))

(every Vehicle has (parts ((a Seat))))		; should unflag *MyCar again

((the number of (the parts of *MyCar)) = 3)

;;; ======================================================================
;;; Check forced slot-val unification during "has" for single-valued slots.
;;; ======================================================================
 
(reset-kb)

(owner has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(*MyCar has (owner (*Pete)))

(*MyCar has (owner ((a Person))))

;;; Check *Pete and _Person23 are unified:
((the number of (the owner of *MyCar)) = 1)

;;; ----------------------------------------------------------------------
;;;		Check situation-specific is copied to inverse slots:
;;; NO LONGER USED
;;; ----------------------------------------------------------------------
;
;(reset-kb)
;
;(loves has 
;  (instance-of (Slot)) 
;  (situation-specific (t)) 
;  (inverse (loved-by)))
;
;(loves situation-specific)
;(loved-by situation-specific)

;;; ======================================================================
;;; Test proper augmentation and subsumption tests with single-valued slots

(reset-kb)

(spouse has 
  (instance-of (Slot))
  (cardinality (N-to-1)))

;;; ignore unmarried people for now!
(every Man has (spouse (((a Person) & (must-be-a Woman)))))

(every Man has (spouse ((a Person))))

(every Man has (spouse (((must-be-a Animate-Object) & (a Person)))))

((the spouse of (a Man)) isa Person)
((the spouse of (a Man)) isa Woman)
((the spouse of (a Man)) isa Animate-Object)

;;; ======================================================================
;;;		collect-applicable-rule-sets bug
;;; This procedure removed for the 1.4.0-beta11+ releases
;;; ======================================================================
;;; Subtle bug in 1.4.0-beta9&10:
;;; If Put-In-Box exists in *Global, then don't evaluate (a Box with (color (*Red)))
;;; in a specific situation. 
;;; This turns out to be wrong in two cases:
;;;	(1) It is in global, but doesn't have any instance-of links. This is a side-effect
;;;	    of do-and-next, which asserts (_Put-In-Box23 has (creates (_Situation26)))
;;;     (2) If its local instance-ofs differ from the *Global, eg. as a result of classification.


;;; ---------- (1) ----------

(reset-kb)

(Action has (superclasses (Event)))
(Put-In-Box has (superclasses (Action)))

(every Put-In-Box has
  (destination ((a Box with
		  (color (*Red))))))

(new-situation)

(do-and-next (a Put-In-Box))

(the color of (the destination of (thelast Put-In-Box)))	; fails in beta 9 & 10

;;; ---------- (2) ----------
#|

NEW: KM 1.4.0.52 - now classification is disabled in local situations.

(reset-kb)

;;; ---

(every Red-Box has-definition
  (instance-of (Box))
  (color (*Red)))

(every Red-Box has
  (appearance ((a Pretty-Appearance))))

(*My-Box has (instance-of (Box)))

(new-situation)

(*My-Box has (color (*Red)))	; so it is locally a Red-Box

(the appearance of *My-Box)					; fails in beta 9 & 10
|#
;;; ======================================================================
;;; Check proper listification of single-valued slots (KM1.4.0-beta11 bug)
;;; ======================================================================

(reset-kb)

(spouse has
  (instance-of (Slot))
  (inverse (spouse))
  (cardinality (1-to-1)))

(*Pete has
  (instance-of (Person))
  (spouse ((a Person))))

(*Pete has
  (spouse ((a Adult))))

(*Marianne has
  (spouse (*Pete)))

#|
Buggy structure in KM1.4.0-beta11, missing a set of parentheses:
(*Pete has 
  (instance-of (Person))
  (spouse ((a Person)
           &
           (a Adult)
           &
           *Marianne)))
should be:
(*Pete has 
  (instance-of (Person))
  (spouse (((a Person) & (a Adult) & *Marianne))))
|#

((the spouse of *Pete) = *Marianne)

;;; ======================================================================
;;; (allof ... must ...):  New command for KM1.4.0
;;; ======================================================================

(allof (:set 1 2 3) must (It > 0))
(allof2 (:set 1 2 3) must (It2 > 0))

;;; KM1.4.0-beta18
(allof (:set 1 2 3 4 5 6 7 8 9 10) where (It > 5) must (It > 5))
(allof2 (:set 1 2 3 4 5 6 7 8 9 10) where (It2 > 5) must (It2 > 5))

;;; ======================================================================

;;; This failed under 1.4.0-beta16, as I forgot to check that 
;;; *with* constraints, two nils unify successfully.

(reset-kb)

(_S1 has (instance-of (Situation)))

(in-situation _S1 (Fred has (location ((<> *House)))))

(_S2 has (instance-of (Situation)))

(in-situation _S2 (Fred has (age (20))))

(_S1 & _S2)

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

;;; Check this is now allowed (was blocked previously)
(t has (instance-of (T-Class)))

;;; ======================================================================
;;;	Check touched instances are added to the stack
;;; ======================================================================

(reset-kb)

(Vehicle has (superclasses (Thing)))

(Car has (superclasses (Vehicle)))

(*Wheel1 has (instance-of (Wheel)))

;;; All the cars have a common wheel! (Just for testing purposes!)
(every Car has
  (parts (*Wheel1 (a Wheel) (a Wheel) (a Wheel) (a Engine) (a Chassis))))

(the number of (the Wheel parts of (a Car)))

(show-context)

(new-context)

;;; Check the car is pulled in from the wider KB.
;; 3.7.00 - no - revise criteria for adding to context, it's only when a new obj is CREATED now
;; (the Car with (parts (*Wheel1)))

;;; ======================================================================

(reset-kb)

;; little test on (a C1 with (instance-of (C2))) form

(every Car has (size (Big)))

(every Vehicle has (size (Very-Big)))

(X == (a Car with
	(instance-of (Vehicle))
	(color (*Pink))))

((the size of X) = (:set Big Very-Big))
((the color of X) = *Pink)

;;; ======================================================================

;;; These shouldn't generate error messages (but did in beta-28-)
((evaluate 't) = t)
((evaluate (:set 'Cat 'Dog)) = (:set Cat Dog))

;;; ======================================================================
;;;	Check cardinality reversal working (wasn't in KM1.4-beta31)
;;; ======================================================================

(wife has (cardinality (1-to-1)) (inverse (husband)))

(*Sue has (husband ((a Person with (size (*Big))))))

(*Sue has (husband ((a Person with (age (*Young))))))

;;; Check the two person's were unified, based on the 1-to-1 constraint:
((the number of (the husband of *Sue)) = 1)	; was 2 in 1.4.0 beta-31

;;; ======================================================================
;;; Check '(...) is considered a structured instance:
;;; ======================================================================

;; was 2 in beta-32
((the number of (the foo of (a Bar with (foo ('(every Dog) '(every Dog)))))) = 1)

;;; ======================================================================

;;; Allow "an instance of" to map over multiple classes, e.g.
;;; (an instance of (:set Dog Cat)) -> (_Dog93 _Cat94)

; Neah, don't allow '(a Cat)
;((an instance of (:set Dog Cat)) covers '(a Cat))
;((an instance of (:set Dog Cat)) covers '(a Dog))

;;; This is okay though... 
(Cat covers (an instance of (:set Dog Cat)))
(Dog covers (an instance of (:set Dog Cat)))


;;; ======================================================================
;;;		UNQUOTING
;;; ======================================================================

((1 +   (2 + 3) + 4) =   10)
('(1 +   (2 + 3) + 4) = '(1 + (2 + 3) + 4))
('(1 + #,(2 + 3) + 4) = '(1 + 5 + 4))

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

(Pete has (friends (Joe Sue)))

('(a Person with (likes (Mike #,(the friends of Pete) Ellen))) = 
 '(a Person with (likes (Mike (:set Joe Sue) Ellen))))

((the likes of (evaluate '(a Person with (likes (Mike #,(the friends of Pete) Ellen)))))
 = (:set Mike Joe Sue Ellen))

;;; Sue has no friends
(X == (evaluate '(a Person with (likes (Mike #,(the friends of Sue) Ellen)))))
((the likes of X) = (:set Mike Ellen))

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

(every Airplane-Engine has
  (parts-of ((a Airplane)))
  (purpose ('(every Flying with
		(agent (#,(the parts-of of Self)))))))

(*MyAirplane-Engine has (instance-of (Airplane-Engine)))
(*MyAirplane has 
  (instance-of (Airplane))
  (parts (*MyAirplane-Engine)))

((the purpose of *MyAirplane-Engine) = '(every Flying with (agent (*MyAirplane))))

;;; ======================================================================

;;; nest nils handled properly:

(nil &? 1)
(1 &? nil)
;(nil &+? 1)	; no longer implemented
;(1 &+? nil)	; no longer implemented

(((:args 1 2) & 1) = (:args 1 2))
(((:args 1 2) & (:args 1)) = (:args 1 2))
((1 & (:args 1 2)) = (:args 1 2))
(((:args 1) & (:args 1 2)) = (:args 1 2))

;;; ======================================================================

;;; Slightly cryptic - test unification of structures under
;;; single-valued slot constraints.

(color has (cardinality (1-to-1)))

(red has (color-of ((:args pete joe))))

(_Thing01 == (a Thing with (color ((:args red _Thing02)))))

;;; Shouldn't generate an error - failed due to typo' in KM 1.4.0-beta37
(the color of _Thing01)

(the color-of of red)
(_Thing01 = pete)
(_Thing02 = joe)

;;; ======================================================================
;;;		CLASSIFICATION CONSISTENCY CHECK
;;; ======================================================================

;;; Slightly weird test, to check consistency of classes are checked when classifying

(reset-kb)

(every Container@Empty has-definition
  (instance-of (Container))
  (contents ((mustnt-be-a Thing))))

;;; [1] Actually, this constraint isn't tested by KM (it's not
;;; provably false).
(every Container@NotEmpty has-definition
  (instance-of (Container))
  (contents ((at-least 1 Thing))))	; [1]

(a Partition with
  (members (Container@Empty Container@NotEmpty)))

;;; fails in beta-38 and earlier
((the classes of (a Container)) 
	/= (:set Container@Empty Container@NotEmpty))

;;; ------------------------------
;;; routine test

(every PetFish has-definition
  (instance-of (Pet Fish)))

(((a Pet) & (a Fish)) isa PetFish)

;;; ======================================================================
;;;		CONTAINERS; use attributes, not classification
;;; ======================================================================

(reset-kb)

(EVAL '(PROGN (SETQ *OLD-LINEAR-PATHS* *LINEAR-PATHS*) T))
(SETQ *LINEAR-PATHS* T)

(is-open has
  (instance-of (Slot))
  (situation-specific (t))
  (fluent-status (*Fluent))	; i.e. non-inertial fluent
  (cardinality (N-to-1)))

(prevents has  
  (fluent-status (*Fluent))
  (situation-specific (t)))


(permits has  
  (fluent-status (*Fluent))
  (situation-specific (t)))

(intersects has
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

;;; simplification - assume very container has one Portal
(every Container has
  (intersects ((a Portal)))	; [1]
  (is-open (((the aperture of (the Portal intersects of Self)) = *Open)))
  (permits ((if   (Self is-open) 
	     then '(every Move with (through (#,(Self intersects Portal)))))))
  (prevents ((if   (not (Self is-open))
	      then '(every Move with (through (#,(Self intersects Portal))))))))

(Action has (superclasses (Event)))

(aperture has 
  (instance-of (Slot))
  (fluent-status (*Inertial-Fluent)))

(Open has (superclasses (Action)))
(every Open has
  (add-list ((:triple (Self opened) aperture *Open))))

(Close has (superclasses (Action)))
(every Close has
  (del-list ((:triple (Self closed) aperture *Open))))

(*MyContainer has
  (instance-of (Container)))

(new-situation)

(not (the permits of *MyContainer))
(the prevents of *MyContainer)

;(km-format t "In situation ~a~%" (curr-situation))
;(km-format t "        permits: ~a~%" (the permits of *MyContainer))
;(km-format t "        prevents: ~a~%" (the prevents of *MyContainer))

(do-and-next (a Open with (opened ((*MyContainer intersects Portal)))))

;(km-format t "In situation ~a~%" (curr-situation))
;(km-format t "        permits: ~a~%" (the permits of *MyContainer))
;(km-format t "        prevents: ~a~%" (the prevents of *MyContainer))

(the permits of *MyContainer)
(not (the prevents of *MyContainer))

(do-and-next (a Close with (closed ((*MyContainer intersects Portal)))))

;(km-format t "In situation ~a~%" (curr-situation))
;(km-format t "        permits: ~a~%" (the permits of *MyContainer))
;(km-format t "        prevents: ~a~%" (the prevents of *MyContainer))

(not (the permits of *MyContainer))
(the prevents of *MyContainer)

#|
KM> (reload-kb "cont3.km")
In situation (_Situation101)
	permits: NIL
	prevents: ('(every Move with (through (_Portal102))))
In situation (_Situation104)
	permits: ('(every Move with (through (_Portal102))))
	prevents: NIL
In situation (_Situation106)
	permits: NIL
	prevents: ('(every Move with (through (_Portal102))))
|#

(EVAL '(PROGN (SETQ *LINEAR-PATHS* *OLD-LINEAR-PATHS*) T))

;;; ======================================================================
;;; This should be allowed!

(1 & (a Coordinate))

;;; ============================================================
;;;		HANDLING MULTIPLE NAMES
;;; ============================================================

(reset-kb)
(a Man)
(the name of (thelast Man))
(a Person)
(the name of (thelast Person))
((thelast Man) == (thelast Person))
((make-sentence (thelast Man)) = "The man.")

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

;; Check class names get dereferenced:

(_Engine == Engine)
(_Class == Car)
(every _Class has (parts ((a _Engine))))
((the parts of (a _Class)) isa Engine)

;;; ======================================================================
;;; This rather cryptic test checks for a bug where KM was mistakenly taking
;;; constraints from one situation to another.

(reset-kb)

(*Car has (instance-of (Car)))
(_Fred1 has (instance-of (Man)))
(_Fred2 has (instance-of (Person)))

(new-situation)

(_Fred1 has (owns (*Car)))
(_Fred2 has (age (23)))

(next-situation)

(_Fred1 has (owns ((<> *Car))))
(_Fred2 has (owns ((a Tree))))

(_Fred1 &! _Fred2)

(not (_Fred1 &? (a Thing with (owns (*Car)))))

;;; ----------
;;; Yet another test...
;;; Here these should unify, even though age hasn't any explicit values,
;;; and also preserve the constraints in the unified result.

(reset-kb)

(_Cat1 == (a Cat with (age ((<> foo)))))
(_Dog1 == (a Dog with (age ((<> bar)))))
(_Cat1 &! _Dog1)

(not (_Cat1 &? (a Thing with (age (foo)))))
(not (_Cat1 &? (a Thing with (age (bar)))))

(reset-kb)

(age has (instance-of (Slot)) (cardinality (N-to-1)))

(_Cat1 == (a Cat with (age ((<> foo)))))
(_Dog1 == (a Dog with (age ((<> bar)))))
(_Cat1 &! _Dog1)

(not (_Cat1 &? (a Thing with (age (foo)))))
(not (_Cat1 &? (a Thing with (age (bar)))))

;;; But note: This unification loses the (<> bar) constraint, as the first item is
;;; deemed to subsume the second.
; (showme ((a Cat with (age ((<> foo)))) & (a Cat with (age ((<> bar))))))

;;; ========================================

;;; Failed in beta46; instance-of constraint prevented default Thing being used
((the classes of (a Thing with (instance-of ((<> Physobj))))) = Thing)

;;; ======================================================================

#|
beta46 error with eager unification:
  (_Move3 _Enter4) &&! (_Enter5) -> (_Enter5 _Enter4), even if _Move3 has
   constraint to (instance-of ((<> Enter))
|#

( (the number of 
   (the Lego likes of 
     (   (a Person with (likes ((a Thing with (instance-of ((<> Lego)))) (a Lego)))) 
      &! (a Person with (likes ((a Lego)))))
  )) = 1 )					; was 2 in beta46

( (the number of 
   (the Lego likes of 
     (    ((a Person with (likes ((a Thing with (instance-of ((<> Lego)))) (a Lego)))))
      &&! ((a Person with (likes ((a Lego))))))
  )) = 1 )					; was 2 in beta46

;;; ----------
;;; Check that instance-of constraints are checked (uses *built-in-slots-with-constraints*)

((the number of (((a Thing with (instance-of (Car)))) &&  ((a Thing with (instance-of ((<> Car))))))) = 2)
((the number of (((a Thing with (instance-of (Car)))) &&! ((a Thing with (instance-of ((<> Car))))))) = 2)

;;; This shouldn't fail with a noisy error!
;;; (ignore-result nil)
;;; No, it should! e.g. 
;;; (every TangibleThing has
;;;   (contains-of ((ignore-result (the contains of (the parts-of of Self))))))

;;; ======================================================================
;;;		(an instance of ... [with ...]) macro
;;; ======================================================================

((an instance of (:set Dog Mouse) with (instance-of (Cat))) isa Dog)
((an instance of (:set Dog Mouse) with (instance-of (Cat))) isa Cat)
((an instance of (:set Dog Mouse) with (instance-of (Cat))) isa Mouse)

((an instance of Dog with (instance-of (Cat Mouse))) isa Dog)
((an instance of Dog with (instance-of (Cat Mouse))) isa Cat)
((an instance of Dog with (instance-of (Cat Mouse))) isa Mouse)

((an instance of Dog) isa Dog)

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

((:set "cat") includes "cat")	 ; check :test #'equal is used

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

(Pete has (age ((:default (1 + 2)))))	; check :default comment is allowed
((the age of Pete) = 3)


;;; ======================================================================

#|
subevent hierarchy for some actions...

	 A
      /  |  \
    A1  A2  A3
   /  \
  A11 A12
|#

(reset-kb)


(A has
  (instance-of (Event))
  (subevents (A1 A2 A3))
  (first-subevent (A1)))

(A1 has 
  (instance-of (Event))
  (subevents (A11 A12))
  (first-subevent (A11))
  (next-event (A2)))

(A2 has 
  (instance-of (Event))
  (next-event (A3)))

(A3 has (instance-of (Event)))

(A11 has 
  (instance-of (Event))
  (next-event (A12)))

(A12 has 
  (instance-of (Event)))

(every Event has
  (ordered-subevents ((the first-subevent of Self)
		      (the subsequent-events of (the first-subevent of Self))))
  (subsequent-events ((the next-event of Self)
		      (the subsequent-events of (the next-event of Self))))
  (ordered-all-events (
     Self 
     (the ordered-all-events of (the ordered-subevents of Self))))
  (ordered-leaf-events (
     ((the ordered-leaf-events of (the ordered-subevents of Self)) or Self)
     (the ordered-leaf-events of (the subsequent-events of Self)))))

;;; test...
((the ordered-all-events of A) = (:set A A1 A11 A12 A2 A3))

((the ordered-leaf-events of A) = (:set A11 A12 A2 A3))

;;; ---------- Writer bug in 1.4.0.52 (fixed now)

(Falling-Situation has (superclasses (Situation)))

(in-every-situation Falling-Situation
  ((the agent of TheSituation) has (feelings (*Scared))))

(showme Falling-Situation)

;; ======================================================================

((forall-seq (:seq 1 2 3 3) (It + 1)) 
	= (:seq 2 3 4 4))

((forall-seq (:seq 1 2 3 3) where (It >= 2) (It + 1))
	= (:seq 3 4 4))

(*Fred has (likes (*Sue *Mike)))
(*Sue has (likes (*Mary)))

((forall-seq (:seq *Fred *Sue *Mary) (the likes of It)) =
	(:seq (:set *Sue *Mike) *Mary NIL))

((:seq (:set *Sue *Mike) *Mary NIL *Mary) = 
	((:seq (:set *Sue *Mike) *Mary NIL *Mary)))

;;; ======================================================================

(reset-kb)

(*Fred has (friends (*Mike)))
(*Fred has (friends (*Joe)))

;;; Check inverses installed with two separate add statements
((the friends-of of *Joe) = *Fred)

;;; ======================================================================

(reset-kb)

(every Person has
  (age ((constraint (TheValue < 100)) (a Number) (at-most 1 Number))))

(Man has (superclasses (Person)))
(every Man has 
  (age ((a Big-Number))))

((constraints-for (the age of (a Person))) = (:set '(constraint (TheValue < 100)) '(at-most 1 Number)))
((rules-for (the age of (a Person))) = (:set '(constraint (TheValue < 100)) '(a Number) '(at-most 1 Number)))
(not (rules-for (the foo of (a Person))))

((constraints-for (the age of (a Man))) = (:set '(constraint (TheValue < 100)) '(at-most 1 Number)))
((rules-for (the age of (a Man))) = 
	'(((a Big-Number)) &&
	   ((constraint (TheValue < 100)) (a Number) (at-most 1 Number))))


;;; ======================================================================
;;;		also-has
;;; ======================================================================

(SETQ *LINEAR-PATHS* T)

(reset-kb)

(*Fred also-has (friends ((a Person))))
(*Fred also-has (friends ((a Person))))
(*Fred also-has (friends ((a Person))))

((the number of (the friends of *Fred)) = 3)

(*Fred also-has (friends (*Sue)))
(*Fred also-has (friends (*Sue)))

((the number of (the friends of *Fred)) = 4)

(*Fred has (friends ((a Person))))

((the number of (the friends of *Fred)) = 4)

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

(every Man also-has (friends ((a Person))))
(every Man also-has (friends ((a Person))))
(every Man also-has (friends ((a Person))))

((the number of (the friends of (a Man))) = 3)

(every Man also-has (friends (*Sue)))
(every Man also-has (friends (*Sue)))

((the number of (the friends of (a Man))) = 4)

(every Man has (friends ((a Person))))

((the number of (the friends of (a Man))) = 4)

;;; ======================================================================
;;; single-valued slots: Check (X Y) is stored as ((X & Y)), not (X Y)
;;; ======================================================================

(destination has 
  (cardinality (1-to-1)))

;;; Check this is stored as ((X & Y)), not (X Y)
(every Foo has
  (destination ((a Place)
                (if (has-value (the agent of Self))
                  then (the location of (the agent of Self))))))

;;; Was 2 in KM 1.4.3.1
((the number of
  (the destination of (a Foo with (agent ((a Thing with (location ((a Place))))))))) = 1)

;;; ======================================================================
;;;		TEST UNDO FACILITY
;;; ======================================================================

(reset-kb)

(start-logging)

(checkpoint "starting point")

(a Car)

(a Car)

((the number of (the instances of Car)) = 2)

(undo)

((the number of (the instances of Car)) = 0)

(stop-logging)

;;; ---------- 4/6/01

;((the average of (:set 1 2 3)) = 2)
((the average of (:bag 1 2 3)) = 2)

;;; allow this 
((the min of 3.5) = 3.5)
((the max of 3.5) = 3.5)

((the min of (:set 3.5 4)) = 3.5)
((the max of (:set 3.5 3)) = 3.5)

;;; default append is to create a sequence
((1 append 2) = (:seq 1 2))
(((:seq 1) append 2) = (:seq 1 2))
(((:bag 1) append 2) = (:bag 1 2))
((1 append (:bag 2)) = (:bag 1 2))

((the sum of NIL) = 0)
((the average of NIL) = 0)

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

(object has
   (instance-of (Relation))
   (superslots ())
   (subslots ())
   (domain (Event))
   (range (Entity))
   (inverse (object-of))
   (fluent-status (*Inertial-Fluent))
   (situation-specific (t))
   (cardinality (N-to-1)))

; check inverses recognized now
((the range of object-of) = Event)
((the domain of object-of) = Entity)
((the cardinality of object-of) = 1-to-N)
;((the situation-specific of object-of) = t)		; redundant now
((the fluent-status of object-of) = *Inertial-Fluent)
((the inverse of object-of) = object)

;;; ======================================================================
;;;		TAXONOMY FUNCTIONS
;;; ======================================================================

(reset-kb)

(every Physobj has
  (parts ((Self d-parts) (Self d-parts * parts))))

(Car has (superclasses (Physobj)))

(every Car has (d-parts ((a Engine) (a Chassis) (a Body))))

(Engine has (superclasses (Physobj)))

(every Engine has 
    (d-parts ((a Carburetor) (a Battery) (a Combustion-chamber))))

(Body has (superclasses (Physobj)))

(every Body has 
  (d-parts ((a Door) (a Door) (a Frame) (a Windshield))))

(Door has (superclasses (Physobj)))

(every Door has
  (d-parts ((a Handle) (a Window) (a Panel))))

(every Physobj has
          (parts ((the d-parts of Self)
		  (the parts of (the d-parts of Self))))
          (leaf-parts ((allof (the parts of Self) 			; [1]
			 where (not (the d-parts of It))))))		; [2]

(taxonomy)

(taxonomy Physobj)

(_X == (a Car))

(taxonomy _X d-parts)

;;; ======================================================================
;;;		TEST FOR THE (@ ...) SOURCE REPRESENTATION
;;; ======================================================================

(reset-kb)

(every Car has
  (parts ((:seq 1))))

(BigCar has (superclasses (Car)))
(every BigCar has
  (parts ((:seq 1 2))))

;;; Generated an error: sourcing turned (:seq 1) -> (:seq 1 (@ Car)), and then
;;; I failed to remove the @ from the structure.
(the parts of (a BigCar))

;;; A rather low-level way of testing that is0 removes sources from structured-vals
#'(LAMBDA () (COND ((IS0 '(:triple 1 2 3)  '(:triple (a Number) (a Number) (a Number) (@ Car))) '(t))))

;;; ======================================================================

;;; KM 1.4.5.8 and earlier, this produced (the number of 1), an unevaluated structure!
(((the number of foo) & (the number of foo)) = 1)


;;; ======================================================================
;;;	NEW: explicitly for Shaken: now-has, which overwrites old values
;;; ======================================================================

;;; Check we have enough explanations...

(reset-kb)

(Car has (prototypes (_Car1)))
((the prototypes of Car) = _Car1)
((the prototype-of of _Car1) = Car)

;;; Special overwrite function...

(Car now-has (prototypes (_Car2)))
((the prototypes of Car) = _Car2)
((the prototype-of of _Car2) = Car)
(not ((the prototype-of of _Car1) = Car))

(new-situation)

(Car now-has (prototypes (_Car3)))
((the prototypes of Car) = _Car3)
((the prototype-of of _Car3) = Car)
(not ((the prototype-of of _Car2) = Car))
(not ((the prototype-of of _Car1) = Car))

;;; ======================================================================

;;; check also-has does an "&". But this little script doesn't really
;;; test anything.

(reset-kb)

(spouse has
  (cardinality (N-to-1)))

(*Fred has
  (spouse (*Mary)))

(*Fred also-has
  (spouse ((a Woman))))

(showme *Fred)

(*Fred & (a Thing with (spouse ((a Thing)))))

((the spouse of *Fred) = *Mary)

;;; ======================================================================
;;;	bug with dereferencing in `includes' statement...
;;; ======================================================================

(reset-kb)

(base has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(_Water1 has (instance-of (Water)))
(_Water2 has (instance-of (Water)))
(_Thing1 has (instance-of (Thing)))

(_Thing1 has (base (_Water1)))
(_Thing1 also-has (base (_Water2)))

;;; This used to fail because _Water2 was dereferenced BEFORE
;;; the query (the base of _Thing1), which binds _Water2 to _Water1!
;;; To avoid this, we compute both parts THEN dereference both, just
;;; to be safe.
((the base of _Thing1) includes _Water2)

;;; ======================================================================

((theNth 1 of (:set 1 2 3 4 5 6 7 8 9 10)) = 1)
((theNth 10 of (:set 1 2 3 4 5 6 7 8 9 10)) = 10)

;;; was (:seq 1 2 3 5 4) in KM 1.4.5.14
((the seq of ((1 2 3) && (2 3 4 5))) = (:seq 1 2 3 4 5))

;;; ======================================================================
;;;		TEST dont-cache-values slot
;;; ======================================================================

(text-def has
  (instance-of (Slot))
  (inherit-with-overrides (t))
  (dont-cache-values (t)))

(every Person has 
  (text-def ("A person")))

(Man has (superclasses (Person)))
(every Man has 
  (text-def ("A man")))

(*Pete has 
  (instance-of (Person)))

((the text-def of *Pete) = "A person")

(*Pete has 
  (instance-of (Man)))

;;; NB Not ("A man" "A person")
((the text-def of *Pete) = "A man")

;;; ======================================================================
;;;	Check caching is switched *off* with dont-cache-values
;;; ======================================================================

(reset-kb)
(Foo has (superclasses (Object)))

(bar has (instance-of (Slot)))
(baz has (instance-of (Slot))
         (dont-cache-values (t)))
(barbaz has (instance-of (Slot)))

(every Foo has
   (bar (1))
   (baz ((the bar of Self)))
   (barbaz ((if ((the baz of Self) = 1)
             then (the baz of Self)
             else (the bar of Self))))
)

(_X == (a Foo))
(the bar of _X)
(the baz of _X)
(the barbaz of _X)	; This shouldn't fail

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

;;; Test inverse always works...
((the inverse of asdf) = asdf-of)

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

(1 / 0) 	; shouldn't error out
((0 / 1) = 0)
((0 / 0) = 1)

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

;;; From Ken Barker 8/16/02:
;;; This failed, as NIL & NIL -> NIL was considered failure before. Fixed now
((:pair 1 NIL) & (:pair (a Number) NIL))

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

;;; Here, we test that a structured value gets decommented before unification.
;;; (By default, unifications on slot-values only have the top-level decommented, but
;;;  we need to go further when those values are themselves structures).
(every Foo has (age (((:pair 4.25 *liter) &+ (:pair 4.25 *liter [comment])))))
(the age of (a Foo))

(print (make-sentence 0.123413))

;; ---------- tolerance

(4.99999 = 5.0)

(every Person2 has (age (5)))
(every Person has (age (4.999999)))
(P has (superclasses (Person Person2)))
((the number of (the age of (a P))) = 1)	; unify the two numbers

;;; ======================================================================

(reset-kb)

(every Car has (parts ((a Wheel))))

((the number of (the parts of (a Car))) = 1)

(every Car also-has (parts ((a Wheel))))

((the number of (the parts of (a Car))) = 2)

(every Car now-has (parts ((a Wheel))))

((the number of (the parts of (a Car))) = 1)

(parts has (cardinality (N-to-1)))

(every Car also-has (parts ((a Wheel))))

((the number of (the parts of (a Car))) = 1)

(every Car now-has (parts ((a Wheel))))

((the number of (the parts of (a Car))) = 1)

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

;;; Should succeed!
(numberp 3)

;;; ---------- +/- expressions


(not (99 = 100 +/- 0.01))
(99 = 100 +/- 1 %)
(not (99 = 100 +/- 0.1 %))
(0 = 0.00001 +/- 0.001)
(not (0 = 0.00001 +/- 1 %))
(-99 = -100 +/- 1 %)

;;; ---------- tolerance

(0.00001 /= 0.00002)
(4.99999  = 5.00000)
(499999  /= 500000)

(not (0.00001 = 0.00002))
(not (4.99999  /= 5.00000))
(not (499999  = 500000))


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

((?x == 2) and ((?x + ?x) = 4))

(  ((?x == (:set 2 3)) and (forall ?y in ?x ?y))
 = (:set 2 3))

(((a Cat) == *Fred) and (1 + 1))

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

;;; Make sure this doesn't generate an error
#'(LAMBDA () '('(this is a quoted expression)))	

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

(1 /== 2)

(SETQ *LINEAR-PATHS* NIL)

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

(reset-kb)

(Super2 has (superclasses (Super1)))
(Super3 has (superclasses (Super1 Super2)))

;;; Check Super1 is removed during the (... has ...) assertion above
((the superclasses of Super3) = Super2)

(foo has
  (range (String Thing)))

;;; Note, not String
((the range of foo) = Thing)

;;; ======================================================================

;;; Check redundancies are removed in both directions...

(reset-kb)

(Foo has (superclasses (Action)))

(_Foo30 has (prototype-of (Foo Action)))

;;; Check redundancy removed
((the prototype-of of _Foo30) = Action)

;;; Check inverse redundancy removed
(not (the prototypes of Foo))

;;; ======================================================================
;;;		test store/restore
;;; ======================================================================

(store-kb)

(*x has (parts (*y)))
((the parts of *x) = *y)

(restore-kb)

(not ((the parts of *x) = *y))

(SETQ *X* (GET-KB))

(*x has (parts (*y)))
((the parts of *x) = *y)

(EVAL (PUT-KB *X*))

(not ((the parts of *x) = *y))

;;; ======================================================================

(reset-kb)

(SETQ *BUILT-IN-REMOVE-SUBSUMERS-SLOTS* (REMOVE 'instance-of *BUILT-IN-REMOVE-SUBSUMERS-SLOTS*))

(Lose has (superclasses (Action)))
(Remove has (superclasses (Action)))
(Tangible-Entity has (superclasses (Entity)))

(every Remove has (object ((a Tangible-Entity))))
(every Lose has (object ((a Entity))))
(every Action has (object ((must-be-a Thing))))

#|
with instance-of removed from the subsumers slot, answer = (Tangible-Entity Thing Entity).
Before, optimization [4] in unify-with-existential-expr in lazy-unify.lisp was causing a difference.
|#
( (the instance-of of (the object of (a Remove with (instance-of (Lose))))) 
  =  
  (the instance-of of (the object of (a Lose with (instance-of (Remove))))))

;;; Make sure these don't bomb
(showme Remove)
(showme-all Remove)
(showme (a Remove))
(showme-all (a Remove))

;;; Put it back again
(SETQ *BUILT-IN-REMOVE-SUBSUMERS-SLOTS* '(instance-of classes superclasses member-type))

;;; ----------------------------------------------------------------------
;;;		Test deletion and dereference-kb
;;; ----------------------------------------------------------------------


(reset-kb)
(a X)
(a X)
(a Y)
(Foo has (r ((_X1 & _X2) (_X2 & _Y3))))
(_Y3 == _X1)
(delete _Y3)
(showme Foo)
(dereference-kb)
(showme Foo)

(reset-kb)
(a X)
(a X)
(a Y)
(a F)
(Foo has (r ((_X1 & _X2) (_X2 & _Y3))))
(_F4 == _X1)
(_Y3 == _F4)
(delete _Y3)
(showme Foo)
(dereference-kb)
(showme Foo)

(*tree has (color (*red *blue)))
(*tree also-hasnt (color (*blue)))
((the color of *tree) = *red)

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

;;; Test that existentials are not considered equal.
;;; Thus (a Jump with (subevents ((a Move) (a Move)))) retains *both* Moves
((a Move) /= (a Move))
((:pair (a Move) 1)  /= (:pair (a Move) 1))

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

(reset-kb)

(every Person has (parent ((a Person))))

;;; Check doesn't kill the system
((the number of (the (parent * 100) of (a Person))) = 100)


;;; ignore  missing-rm2.km

(print "must-be.km")

;;; ======================================================================
;;;		must-be expressions:
;;; ======================================================================

(reset-kb)

(every Car has 
  (owner ((must-be-a Person))))

(*MyCar has 
  (instance-of (Car)))

(not (the owner of *MyCar))		; no instance created

(*MyCar has 
  (owner (*Pete)))

(the owner of *MyCar)

(*Pete isa Person)

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

(every Car has 
  (owner ((must-be-a Person with (age (*Adult))))))

(the owner of *MyCar)

((the age of *Pete) = *Adult)


(*MyCar has (owner (*Sue)))

((the owner of *MyCar) = (:set *Pete *Sue))

((the age of *Sue) = *Adult)

(age has
  (instance-of (Slot))
  (cardinality (N-to-1)))

; The below (correctly) generates a unification failure in KM,
; as child Mike violates the (must-be-a Person with (age (*Adult)))
; constraint
; (*Mike has (age (*Child)))
; (*MyCar has (owner (*Mike)))
; (the owner of *MyCar)

;;; ----------------------------------------
;;; Now let's try with single-valued slots
;;; ----------------------------------------

(reset-kb)

(owner has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(*MyCar has (owner (*Pete)))

(*MyCar has (owner ((a Person))))

((the number of (the owner of *MyCar)) = 1)

(every Car has 
  (owner ((must-be-a Person))))

(*MyCar has 
  (instance-of (Car)))

(*MyCar has
  (owner (*Pete)))

(every Car has
  (owner ((must-be-a Person with (abilities (*Driver))))))

(*MyCar has
  (owner ((a Person with (abilities (*Singing))))))

;;; ======================================================================
;;;		TEST CONSTRAINT ENFORCEMENT
;;; ======================================================================

(reset-kb)

(every Car has 
  (owner ((must-be-a Person))))

(*MyCar has 
  (instance-of (Car)))

(not (the owner of *MyCar))		; no instance created

(*MyCar has 
  (owner (*Pete)))

(the owner of *MyCar)

(*Pete isa Person)

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

(every Car has 
  (owner ((must-be-a Person with (age (*Adult))))))

(the owner of *MyCar)

((the age of *Pete) = *Adult)


(*MyCar has (owner (*Sue)))

((the owner of *MyCar) = (:set *Pete *Sue))

((the age of *Sue) = *Adult)

(age has
  (instance-of (Slot))
  (cardinality (N-to-1)))

; The below (correctly) generates a unification failure in KM,
; as child Mike violates the (must-be-a Person with (age (*Adult)))
; constraint
; (*Mike has (age (*Child)))
; (*MyCar has (owner (*Mike)))
; (the owner of *MyCar)

;;; ----------------------------------------
;;; Now let's try with single-valued slots
;;; ----------------------------------------

(reset-kb)

(owner has
  (instance-of (Slot))
  (cardinality (N-to-1)))

(*MyCar has (owner (*Pete)))

(*MyCar has (owner ((a Person))))

((the number of (the owner of *MyCar)) = 1)

(every Car has 
  (owner ((must-be-a Person))))

(*MyCar has 
  (instance-of (Car)))

(*MyCar has
  (owner (*Pete)))

(every Car has
  (owner ((must-be-a Person with (abilities (*Driver))))))

(*MyCar has
  (owner ((a Person with (abilities (*Singing))))))

((the abilities of (the owner of *MyCar)) 
	= (:set *Singing *Driver))		; yes!

(new-situation)

;;; Situation-specific 
(every Car has (owner ((must-be-a Person with (abilities (*Jumping))))))

((the abilities of (the owner of *MyCar)) 
	= (:set *Singing *Driver *Jumping))	

(new-situation)

;;; Situation-specific
(every Car has (owner ((must-be-a Person with (abilities (*Laughing))))))

;;; Check other situation doesn't get incorporated
((the abilities of (the owner of *MyCar)) 
	= (:set *Singing *Driver *Laughing))

;;; ======================================================================
;;;		Check unification rules:
;;; Redefined beta-22 to place constraints on a slot.
;;; ======================================================================

((the owns of (a Person with (owns (((must-be-a Car) & (a Thing)))))) isa Car)
((the owns of (a Person with (owns (((a Thing) & (must-be-a Car)))))) isa Car)
((the owns of (a Person with (owns ((((must-be-a Car) & (must-be-a Red-Thing)) & (a Car)))))) isa Car)
((the owns of (a Person with (owns ((((must-be-a Car) & (must-be-a Red-Thing)) & (a Car)))))) isa Red-Thing)


((the owns of (a Person with (owns ((((must-be-a Car)) && ((a Thing))))))) isa Car)
((the owns of (a Person with (owns ((((a Thing)) && ((must-be-a Car))))))) isa Car)
((the owns of (a Person with (owns (((((must-be-a Car)) && ((must-be-a Red-Thing))) && ((a Car))))))) isa Car)
((the owns of (a Person with (owns (((((must-be-a Car)) && ((must-be-a Red-Thing))) && ((a Car))))))) isa Red-Thing)

((the owns of (a Person with (owns ( ( (( ((must-be-a Car) *Fred) && ((must-be-a Red-Thing) *Joe) )) && ((must-be-a Dog) *Mike) )))))
	= (:set *Fred *Joe *Mike))

(*Fred isa Car)
(*Fred isa Red-Thing)
(*Fred isa Dog)
(*Joe isa Car)
(*Joe isa Red-Thing)
(*Joe isa Dog)
(*Mike isa Car)
(*Mike isa Red-Thing)
(*Mike isa Dog)



(print "no-inheritance.km")

(reset-kb)

(SETQ *OLD-USE-NO-INHERITANCE-FLAG* *USE-NO-INHERITANCE-FLAG*)
(SETQ *USE-NO-INHERITANCE-FLAG* T)


(every Car has 
  (parts ((a Engine))))

(*MyCar has
  (instance-of (Car))
  (parts ((no-inheritance)))) 

(not (the parts of *MyCar))

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

(a-prototype Car)

((the Car) has
  (parts ((no-inheritance) (a Wheel))))  ; inheritance disabled anyway in 
				         ; prototype mode
((the Car) has
  (parts ((a Seat))))

(end-prototype)

((the number of (the parts of (a Car))) = 2)
(oneof (the parts of (a Car)) where (It isa Wheel))
(oneof (the parts of (a Car)) where (It isa Seat))

;;; Check (no-inheritance) also overrides subslots

(parts has
  (instance-of (Slot))
  (subslots (chassis-parts)))

(every Car has 
  (chassis-parts ((a Chassis))))

((the number of (the parts of (a Car))) = 2)

(SETQ *USE-NO-INHERITANCE-FLAG* *OLD-USE-NO-INHERITANCE-FLAG*)(print "nuzzo.km")

;;; Toy example of exploring alternative designs for Art Nuzzo (Motorola)
(reset-kb)

;;; Make values of these slots "project" from one situation to the next
(parts has (instance-of (Slot)) (fluent-status (*Inertial-Fluent)))

(size has (instance-of (Slot)) (fluent-status (*Inertial-Fluent)))

(new-situation)
(*MyCar has (instance-of (Car)))

  (new-situation)

  (*MyCar has (parts ((a Engine))))

  (the Engine parts of *MyCar)

  (next-situation)

  (_Engine3 has (size (100-hp)))

  (in-situation _Situation2)

  (next-situation)

  (_Engine3 has (size (200-hp)))

  (global-situation)
#|
So we have the situation tree:

			  -> Sit4
			/    Car with engine size 100
	Sit1 ->	Sit2	
	Car	Car with Engine
			\
			  -> Sit5
			     Car with engine size 200
|#		
;;; Explore it...

 (not (in-situation _Situation2
      (the size of (the Engine parts of *MyCar))))

  ((in-situation _Situation4
      (the size of (the Engine parts of *MyCar))) = 100-hp)

 ((in-situation _Situation5
      (the size of (the Engine parts of *MyCar))) = 200-hp)

(print "overrides.km")

;;; overrides.km
;;; Test inheritance-with-overrides facility (experimental)
;;; New: Note new behavior, as redundant instance-of Person assertion on Joe is removed
;;; at assertion time.

(reset-kb)

(description has 
  (instance-of (Slot))
  (cardinality (N-to-1))		; New 8/30/07
  (inherit-with-overrides (t)))

(every Animal has (description ("a animal")))

(Person has (superclasses (Animal)))
(every Person has (description ("a person")))

(Male has (superclasses (Person)))
(every Male has (description (("a male"))))

(Fred has
  (instance-of (Person Male))
  (description ("fred")))

(Joe has
  (instance-of (Person Male)))

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

((the description of Fred) = "fred")
((the description of (a Person)) = "a person")
((the description of (a Animal)) = "a animal")
((the description of Joe) = "a male")

(new-situation)

((the description of Fred) = "fred")
((the description of (a Person)) = "a person")
((the description of (a Animal)) = "a animal")
((the description of Joe) = "a male")


;;; ======================================================================
;;;			WITH MULTIPLE INHERITANCE
;;; ======================================================================

(reset-kb)

(description has 
  (instance-of (Slot))
  (inherit-with-overrides (t)))

(every Animal has (description ("a animal")))

#|
Wierd taxonomy, but ok:
     Fairly-Clever-Thing
	|
   Clever-Thing			Noisy-Thing
		\		/
Animal		Very-Clever-Thing
"a animal"	  /
	\	 /
	  Person
	//  |
(a Person)  Male
	   "a male"
	  //  \\ 
	Joe  Fred
	     "fred"
|#
(every Fairly-Clever-Thing has (description ("a fairly clever thing")))
(Clever-Thing has (superclasses (Fairly-Clever-Thing)))
(Very-Clever-Thing has (superclasses (Clever-Thing Noisy-Thing)))
(Person has (superclasses (Animal Very-Clever-Thing)))
	;;; NOTE no description slot now, to check multiple inheritance

(Male has (superclasses (Person)))
(every Male has (description (("a male"))))

(Fred has
  (instance-of (Person Male))
  (description ("fred")))

(Joe has
  (instance-of (Person Male)))

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

;((the description of Fred) = "fred")
;((the description of (a Person)) = "a person")
;((the description of (a Animal)) = "a animal")
;((the description of Joe) = "a male")
;REVISED, with new semantics
((the description of Fred) = (:set "fred" "a male"))
((the description of (a Person)) = (:set "a animal" "a fairly clever thing"))
((the description of (a Animal)) = "a animal")
((the description of Joe) = "a male")

(new-situation)

;((the description of Fred) = "fred")
;((the description of (a Person)) = "a person")
;((the description of (a Animal)) = "a animal")
;((the description of Joe) = "a male")
;REVISED, with new semantics
((the description of Fred) = (:set "fred" "a male"))
((the description of (a Person)) = (:set "a animal" "a fairly clever thing"))
((the description of (a Animal)) = "a animal")
((the description of Joe) = "a male")

#|
((the description of Fred) = "fred")
((the description of (a Person)) = (:set "a animal" "a fairly clever thing"))
((the description of (a Animal)) = "a animal")
;((the description of Joe) = (:set "a animal" "a male" "a fairly clever thing"))
((the description of Joe) = "a male")

(new-situation)

((the description of Fred) = "fred")
((the description of (a Person)) = (:set "a animal" "a fairly clever thing"))
((the description of (a Animal)) = "a animal")
;((the description of Joe) = (:set "a animal" "a male" "a fairly clever thing"))
((the description of Joe) = "a male")
|#

;;; ======================================================================


(reset-kb)

(solubility has
  (cardinality (N-to-1))
  (inherit-with-overrides (t)))

(value has
  (inherit-with-overrides (t)))

(every Gen-Solubility-Value has (value ((at-most 1 Thing))))

(Solubility-Value has (superclasses (Gen-Solubility-Value)))
;;; Just to really exercise overriding!
(every Solubility-Value has (value ((:pair *slightly-soluble Thing))))

(Silver-Bromide-Substance has (superclasses (Bromide-Substance)))

(every Bromide-Substance has
  (solubility ((a Solubility-Value with (value ((:pair *soluble Thing)))))))

(every Silver-Bromide-Substance has
  (solubility ((a Solubility-Value with (value ((:pair *insoluble Thing)))))))

(_New-Chemical has 
  (instance-of (Silver-Bromide-Substance)) 
  (solubility ((a Solubility-Value with (value ((:pair *soluble Thing)))))))

((the value of (the solubility of (a Silver-Bromide-Substance))) = (:pair *insoluble Thing))
((the value of (the solubility of _New-Chemical)) = (:pair *soluble Thing))
((the value of (the solubility of (a Silver-Bromide-Substance with (solubility ((a Solubility-Value)))))) = (:pair *insoluble Thing))





(print "panels.km")

;;; ======================================================================
;;;		KNOWLEDGE BASE:
;;; ======================================================================

(reset-kb)

;;; Reconstruction of Keith's SpecWare example in KM

;;; ---------- basic-physics.re ----------

(every Physobj has
  (weight (((the mass of Self) * 9.8)))
  (mass (((the volume of Self) * (the density of Self))))
  (density ((the density of (the material of Self)))))

;;; ---------- manufactured-part.re ----------
;; ignore Aluminum test for now.

(every Manufactured-part has
  (cost-of-raw-stock ((5 * (the raw-stock-volume of Self))))
  (cost-of-drilling-hole ((2 * (the volume of (the hole of Self))))))

;;; ---------- panels.re ----------
#|      /              / width
       +---length-----+
       |  o  o  o  o  | height
       +--------------+		|#

;; Panel arithmetic, assuming equi-sized holes and equal spacings

(Panel has (superclasses (Physobj)))

(every Panel has
  (horizontal-separation (
    (  ((the length of (the boundary of Self)) -
        ((the number-of-holes of Self) * (the diameter of (the hole of Self))))
     / ((the number-of-holes of Self) + 1 ))))
  (vertical-separation (
    ( ((the height of (the boundary of Self)) - 
			(the diameter of (the hole of Self)))
     / 2 )))
  (volume (((the volume of (the boundary of Self)) - 
    ((the number-of-holes of Self) * (the volume of (the hole of Self)))))))

;;; ---------- manufactured-panels.re ----------

;; some cost functions

(Manufactured-panel has (superclasses (Panel Manufactured-part)))

(every Manufactured-panel has
  (raw-stock-volume ((the volume of (the boundary of Self))))
  (manufacturing-cost (( (the cost-of-raw-stock of Self) +
			((the number-of-holes of Self) *
			 (the cost-of-drilling-hole of Self)))))
  (cost ((   (5 * (the weight of Self))
	   + (2 * (the manufacturing-cost of Self))))))

;;; ---------- layout-algorithm.re ----------

;;; A panel, with specific design decisions added in about what the best
;;; radius to use is GIVEN the height, length, width and # holes.
;;; Here the KB states to use the minimum radius.

(Kerstetter-panel has (superclasses (Manufactured-panel)))

(every Kerstetter-panel has
  (height ()) 			;; six defining attributes
  (length ())
  (width ())
  (minh ())
  (minl ())
  (number-of-holes ())  
  (hole ((a Cylinder with
	   (depth ((the width of Self)))
	   (radius ((the max of (:set 0		; radius must be >= 0
	     (the min of (:set
		(((the height of Self) / 2) - (the minh of Self))
		(((the length of Self) - (((the number-of-holes of Self) + 1) 
				* (the minl of Self)))
		 / ((the number-of-holes of Self) * 2) ))))))))))
  (boundary ((a Box with
		(length ((the length of Self)))
		(width ((the width of Self)))
		(height ((the height of Self)))))))

;;; ---------- an example to try... ----------

(Test-panel has (superclasses (Kerstetter-panel)))

(every Test-panel has
  (height (10)) 		;; six defining attributes
  (length (10))
  (width (10))
  (minh (1))
  (minl (1))
  (number-of-holes (4)))

(every Panel-optimization has
  (possible-numbers-of-holes (1 2 3 4 5 6 7 8 9 10))
  (possible-panels (
	(forall ((the possible-numbers-of-holes of Self))
	((a Kerstetter-panel with 
		(number-of-holes (It))
		(material ((the material of Self)))
		(height ((the height of Self)))
		(length ((the length of Self)))
		(width ((the width of Self)))
		(minh ((the minh of Self)))
		(minl ((the minl of Self))))))))
  (possible-costs ((the cost of (the possible-panels of Self))))
  (best-panel (
	(oneof ((the possible-panels of Self))
	 where ((the cost of It) = (the min of 
					(the possible-costs of Self)))))))

;;; ---------- materials ----------

(*Aluminum-7075 has 
  (instance-of (Material))
  (density (0.07)))

(*Steel-321 has
  (instance-of (Material))
  (density (0.72)))

;;; ---------- basic-geometry.re ----------

(every Box has
  (height ())
  (length ())
  (width ())
  (volume (((the height of Self) * (the width of Self) * (the length of Self)))))

(every Cylinder has
  (depth ())
  (radius ())
  (diameter (((the radius of Self) * 2)))
  (volume (((the depth of Self) * (the radius of Self) * (the radius of Self) * 3.14159))))

;;; ======================================================================
;;;			TEST QUERIES
;;; ======================================================================

 (a Kerstetter-panel with		;; directive to create an instance
	(height (10))
	(width (10))
	(length (10))
	(minh (1.5))
	(minl (1.5))
	(material (*Aluminum-7075))
	(number-of-holes (4)))

(the volume of (thelast Kerstetter-panel))

(the cost of (thelast Kerstetter-panel))

( (the radius of (the hole of (thelast Kerstetter-panel)))
 = 0.3125)

((the diameter of (the hole of (thelast Kerstetter-panel)))
 = 0.625)

((the raw-stock-volume of (thelast Kerstetter-panel)) = 1000)

(the manufacturing-cost of (thelast Kerstetter-panel))

(the density of *Aluminum-7075)

((the volume of (a Cylinder with (depth (2)) (radius (1))))
 > 6.28)			; answer = 6.28318

(the best-panel of (a Panel-optimization with 
	(height (10))
	(width (10))
	(length (10))
	(material (*Aluminum-7075))
	(minh (1.5))
	(minl (1.5))))

((the number-of-holes of (the best-panel of (thelast Panel-optimization)))
 = 6)

((the number-of-holes of (the best-panel of (a Panel-optimization with 
	(height (12))
	(width (7))
	(length (8))
	(minh (1.2))
	(material (*Aluminum-7075))
	(minl (1.3)))))
 = 6)

;;; Let's try the same, but made of (heavier) steel...
((the number-of-holes of (the best-panel of (a Panel-optimization with 
	(height (12))
	(width (7))
	(length (8))
	(minh (1.2))
	(minl (1.3)) 
	(material (*Steel-321)))))
 = 1)

((the radius of (the hole of (the best-panel of (thelast Panel-optimization)))) = 2.7)


		
(print "partitions.km")

;;; This in theory tests the constraint mechanism -- an error should
;;; be generated. But my tester won't currently test correct error detection.

(reset-kb)

 (every Action has (object ((a Tangible-Entity))))

 (Emit has (superclasses (Action)))
 (every Emit has
        (object ((constraint ((TheValue &? (a Fluid)) or 
			      (TheValue &? (a Particle)) or 
			      (TheValue &? (a EMWave)))))))

(a Partition with (members (Tangible-Entity Intangible-Entity)))
(a Partition with (members (Solid Liquid Gas)))
(a Partition with (members (Particle Artifact Biological-Entity)))
(a Partition with (members (Radiation Dream Action)))

#|
KM> (taxonomy)
Thing
   Intangible-Entity
      Action
         Emit
      Dream
      Radiation
         EMWave
   Tangible-Entity
      Gas
      Liquid
         Fluid
      Solid
         Artifact
         Biological-Entity
            Cell
         Particle
|#

(Emit has (superclasses (Action)))
(Solid has (superclasses (Tangible-Entity)))
(Liquid has (superclasses (Tangible-Entity)))
(Gas has (superclasses (Tangible-Entity)))
(Radiation has (superclasses (Intangible-Entity)))
(Particle has (superclasses (Solid)))
(Artifact has (superclasses (Solid)))
(Biological-Entity has (superclasses (Solid)))
(Fluid has (superclasses (Liquid)))
(Cell has (superclasses (Biological-Entity)))
(Radiation has (superclasses (Intangible-Entity)))
(Dream has (superclasses (Intangible-Entity)))
(EMWave has (superclasses (Radiation)))
(Action has (superclasses (Intangible-Entity)))

(the object of (a Emit))

#|
Thus

KM> (the object of (a Emit))
(_Tangible-Entity15)

;;; But you can't emit a Cell...
KM> (the object of (a Emit with (object ((a Cell)))))
ERROR! Constraint violation! Discarding value _Cell19 (conflicts with ...

KM> 
|#

;;; ======================================================================
;;; This caused failure in KM 1.4.4.0 due to missing a remove-duplicates when
;;; catching the all-classes of *A
#| 
	 /		             \
        E   --mutually-exclusive--    F
      /  \
      C   D
       \ /
	B
	|
	*A
|#
(reset-kb)
(*A has (instance-of (B)))
(B has (superclasses (C D)))
(C has (superclasses (E)))
(D has (superclasses (E)))
(a Partition with (members (E F)))
(not (*A &? (a F)))




(print "plan.km")

;;; File: plan.km
;;; Author: Peter Clark
;;; Purpose: Process specifications and executions using SADL.
;;; 	Toy blocks-world example.

(reset-kb)

(sub-steps has (fluent-status (*Non-Fluent)))
(event-to-do has (fluent-status (*Non-Fluent)))
(object has (fluent-status (*Non-Fluent)))
(next-step has (fluent-status (*Non-Fluent)))
(first-step has (fluent-status (*Non-Fluent)))

(parts has (fluent-status (*Inertial-Fluent)))
(on has (fluent-status (*Inertial-Fluent)))
(clear? has (fluent-status (*Inertial-Fluent)))

;;; This is infinitely recursive but I only execute the first few steps.
;;; Needs a terminating condition...
(every Unstack-A-Tower-Plan has
  (object ((a Tower)))
  (sub-steps (
    (a Step called "remove" with
      (event-to-do (				; NB a class, not instance
        (the-class Remove with			; "Remove the clear (i.e., top) block"
	  (object ((the Block with
		     (parts-of ((the Tower object of Self)))
		     (clear? (Yes))))))))
      (next-step (((the sub-steps of Self) called "remove"))))))
  (first-step (((the sub-steps of Self) called "remove"))))

;;; Domain-specific knowledge...
(every Remove has
  (object ((a Block)))
  (pcs-list ((:triple (the object of Self) clear? Yes)))
  (del-list ((:triple (the object of Self) on (the on of (the object of Self)))
	     (:triple (the object of Self) parts-of (the parts-of of (the object of Self)))
	     (:triple (the on of (the object of Self)) clear?  No)))
  (add-list ((:triple (the on of (the object of Self)) clear? Yes)
	     (:triple (the object of Self) on *Floor))))

(new-situation)

#| Define the initial situation:
   *BlockA
   *BlockB
   *BlockC
   *BlockD
 -------------- |#
(*MyTower has
  (instance-of (Tower))
  (parts (*BlockA *BlockB *BlockC)))

(*BlockA has
  (instance-of (Block))
  (on (*BlockB))
  (clear? (Yes)))

(*BlockB has
  (instance-of (Block))
  (on (*BlockC))
  (clear? (No)))

(*BlockC has
  (instance-of (Block))
  (on (*BlockD))
  (clear? (No)))

(*BlockD has
  (instance-of (Block))
  (on (*Floor))
  (clear? (No)))

(*MyPlan == (a Unstack-A-Tower-Plan with (object (*MyTower))))

;;; Find the first step...
(_FirstStep == (the first-step of *MyPlan))

;;; Find the first event to do at this step
(_Event1 == (an instance of (the event-to-do of 
		(the first-step of *MyPlan))))

;;; Check I'm indeed removing the top block...
((the object of _Event1) = *BlockA)

;;; Do it (remove the top block...)
(do-and-next _Event1)

#| New state:
   *BlockB
   *BlockC
   *BlockD   *BlockA
 ---------------------- |#

;;; Find the next step to do (which happens to be the same step
;;; as the first step...)
(_NextStep == (the next-step of _FirstStep))

;;; check this is so
(_NextStep = _FirstStep)	; NB: `=' tests equality, `==' asserts it

;;; Find the next event
(_Event2 == (an instance of (the event-to-do of _NextStep)))

;;; Check we're removing the (new) top block...
((the object of _Event2) = *BlockB)

;;; Take off the top block (now is block B)...
(do-and-next _Event2)

#| New state:
   *BlockC
   *BlockD   *BlockA   *BlockB
 -------------------------------- |#

;;; We could look at the next step...
(_NextNextStep == (the next-step of _NextStep))

;;; still should be the same step, of course....
(_NextNextStep = _FirstStep)

;;; Event to do at this step?
(_Event3 == (an instance of (the event-to-do of _NextNextStep)))

((the object of _Event3) = *BlockC)

;;; Take off the top block (now is block C)...
(do-and-next _Event3)

#| New state:
   *BlockD   *BlockA   *BlockB   *BlockC
 ----------------------------------------- |#

((the clear? of *BlockA) = Yes)
((the clear? of *BlockB) = Yes)
((the clear? of *BlockC) = Yes)
((the clear? of *BlockD) = Yes)
((the on of *BlockA) = *Floor)
((the on of *BlockB) = *Floor)
((the on of *BlockC) = *Floor)
((the on of *BlockD) = *Floor)



(print "proto.km")

;;; ======================================================================
;;;		EXISTENTIALS AND SITUATIONS
;;; ======================================================================

(reset-kb)

(a-prototype House)

((the House) has
  (capitol ((a Location) (<> *Horrible))))

(end-prototype)

(new-situation)

;;; ======================================================================
;;;	CHANGE: Now use prototype-scope to index prototypes, rather than prototype-of
;;; ======================================================================

(reset-kb)

(Metal-Nonmetal-Combination-Reaction has (superclasses (Combination-Reaction)))

(_Metal-Nonmetal-Combination-Reaction2302 has
	(instance-of (Metal-Nonmetal-Combination-Reaction))
	(prototype-of (Metal-Nonmetal-Combination-Reaction))
	(prototype-scope ((the-class Combination-Reaction with (raw-material ((a Metal) (a Non-Metal))))))
	(prototype-participants (_Metal-Nonmetal-Combination-Reaction2302)) 
	(age (23)))

;;; Check to see if prototype classification is triggered, even though prototype-of is 
;;; more specific than Combination-Reaction.
((the age of (a Combination-Reaction with (raw-material ((a Metal) (a Non-Metal))))) = 23)

(print "protolooping.km")

;;; File: protolooping.km
;;; Author: Peter Clark
;;; Date: Oct 1999
;;; looping problem with Prototypes - see hand-written note for diagnosis but
;;; not prognosis. The final query sends the system into an infinite loop.

;;; Fixed in KM1.4.0-beta32

#|
12.10.99

For (the parts of (the parts of (a Airplane)))
(the parts of (a Airplane))) creates _Wing9 (fine), cloned from _ProtoAirplane2.
but then (the parts of _Wing9) causes unification of (clone _ProtoWing0) with
the structure for _Wing9. This includes unifying facts (_Wing9 parts-of _Airplane8)
and ((clone _ProtoWing0) parts-of _Airplane21), causing unification of facts
(_Airplane8 [parts nil]) with (_Airplane21 parts (clone _ProtoWing0)). 

NOW: At this point we *don't* want lazy-unify to trigger a query (the parts of _Airplane8),
it will cause a second clone of _ProtoAirplane2 to be created and pulled in!

We need to be very careful about the looping caused by KM call -> lazy unification ->
KM call. 

The original reason we pull in inherited facts during unification is to check that
constraints aren't violated. But here that's not the issue, the unification is
eager and guaranteed to complete.

The FIX is to restrict pulling in inherited information ONLY if there are constraints to
check (either in the KB, or a single-valued slot which might violate a Partition constraint),
AND the unification is lazy (which excludes prototype unification, which is eager).
|#

(reset-kb)

(near has 
  (instance-of (Slot))
  (inverse (near)))

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

(a-prototype Airplane)

((the Airplane) has
  (parts ((a Wing with (side (*Left)))
	  (a Wing with (side (*Right)))
	  (a Tail))))

(end-prototype)

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

(a-prototype Wing)

((the Wing) has
  (parts-of ((a Airplane))))

((the Wing) has
  (parts ((a Flap) (the Tail parts of (the Airplane)))))

(end-prototype)

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

(the parts of (the parts of (a Airplane)))

(print "protolooping2.km")

;;; File: protolooping2.km
;;; This shows that we can't have cloned-from as a fluent without problems!

#|
With cloned-from as a non-inertial fluent, get:
KM>  (new-situation)

[_Situation1] KM>  (the object of (a MyT2))
(COMMENT: Cloned _Penetrate114   -> _MyT26
                                           to find (the object of _MyT22))
(COMMENT: Cloned _Penetrate114   -> _MyT213
                                           to find (the agent of _MyT26))
(COMMENT: Cloned _Penetrate114   -> _MyT218
                                           to find (the agent of _MyT213))
(COMMENT: Cloned _Penetrate114   -> _MyT223
                                           to find (the agent of _MyT218))
(COMMENT: Cloned _Penetrate114   -> _MyT228
                                           to find (the agent of _MyT223))
(COMMENT: Cloned _Penetrate114   -> _MyT233
                                           to find (the agent of _MyT228))
(COMMENT: Cloned _Penetrate114   -> _MyT238
                                           to find (the agent of _MyT233))
(COMMENT: Cloned _Penetrate114   -> _MyT243
                                           to find (the agent of _MyT238))
(COMMENT: Cloned _Penetrate114   -> _MyT248
                                           to find (the agent of _MyT243))
...




The problem is having cloned-from as a fluent. I get stuck in an infinite loop here,
I'm always asking for subevent in a local, but the cloning was done in global for some reason.


the agent of MyX [Sitn 4]
  -> clone ProtoX -> X and note the clone in *Global (why here?)
	(MyX & X)
 	  subevent of MyX & subevent of X
	   	             vvvv
		    _Breach1 & (a Breach with (agent ((the agent of X))))
							 vvvvvv
						      (the agent of X)	[Sitn 4]
							 X has only been noted as a clone in *Global,
							 so now KM loops:
								clone ProtoX -> X'	
								X & X' etc.


|#

(reset-kb)

(forall (:set agent object patient subevent)
	(It has (fluent-status (*Inertial-Fluent))))

(every Event has
  (subevent      ((<> Self) 
                  (must-be-a Event))))

(Action has (superclasses (Event)))

(Breach has (superclasses (Break)))

(every Breach has
       (agent ((must-be-a Tangible-Entity with
			  (agent-of ((a Create with
					(result ((the result of Self))))))))))

;; nothing extra to say about contextual info
(Penetrate has
  (superclasses        (Action)))

(every Penetrate has 
	(object ((a Thing)))
       (subevent 	((a Breach with
		     	    (agent  	((the agent of Self)))
		     	    (object 	((the object of Self)))
			    (next-event ((the Traverse subevent of Self))))
		  	 (a Traverse with
		     	    (agent ((the agent of Self)))
			    (path  ((the result of 
				         (the Breach subevent of Self))))))))


(MyT2 has (superclasses (Penetrate)))
(MyT2 now-has (prototypes (_Penetrate114)))
(_Penetrate114 has (prototype-of (MyT2)) (prototype-scope (MyT2))
 (prototype-participants (_Breach111 _Traverse112 _Tangible-Entity113 _Penetrate114 _Portal115)))
(_Penetrate114 has (instance-of (MyT2)) (path (_Portal115)) (agent (_Tangible-Entity113)) (subevent (_Breach111 _Traverse112))
 (object ((override (a Thing (@ Penetrate object)))))
 (object ((no-inheritance))))
(_Breach111 has (instance-of (Breach)))
(_Traverse112 has (instance-of (Traverse)))
(_Tangible-Entity113 has (instance-of (Tangible-Entity)))
(_Portal115 has (instance-of (Portal)))

(new-situation)

;;; Shouldn't create an infinite loop! Just exit quietly.
;(not (the object of (a MyT2)))

;;; Now let's test that the constraints are universally preserved...
(new-situation)

;(not (the object of (a MyT2)))(print "prototypes.km")

;;; Simple testing of the prototype mechanism...

(reset-kb)

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

(a-prototype Airplane)

((the Airplane) has
  (parts ((a Wing with (side (*Left)))
	  (a Wing with (side (*Right)))
	  (a Landing-Gear))))

(end-prototype)

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

(a-prototype Wing)

((the Wing) has
  (parts ((a Flap) (a Slat))))

(end-prototype)

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

(a-prototype Airplane with
  (agent-of ((a Descending))))		; definitional features of the prototype

;;; ----------
;;; NEW: 1.4.0-beta32 - insist all objects are locally mentioned:
((the Airplane) has 
   (parts ((a Wing) (a Wing) (a Landing-Gear))))

(forall (every Wing) 
   (It  has (parts ((a Flap) (a Slat)))))
;;; ----------

;;; "During descent, the slats and flaps are extended, and the landing gear is down."
(forall (the Slat parts of (the Wing parts of (the Airplane)))
	(It has (position (*Extended))))


(forall (the Flap parts of (the Wing parts of (the Airplane)))
	(It has (position (*Extended))))

((the Landing-Gear parts of (the Airplane)) has
  (position (*Down)))

(end-prototype)

;;; ----------
;;; DEMO
;;; ----------

#|
KM> (a Airplane)
(_Airplane293)

KM> (the parts of _Airplane293)
DEBUG: Built clone of (_ProtoAirplane274) to find valset(s) for (the parts of _Airplane293).
(_Wing295 _Wing296 _Landing-Gear297)

;;; Now add the fact that it's descending...
KM> (_Airplane293 has (agent-of ((a Descending))))
(_Airplane293)

KM> (the position of (the Landing-Gear parts of _Airplane293))
DEBUG: Built clone of (_ProtoAirplane281) to find valset(s) for (the parts of _Airplane293).
(*Down)

;;; Or alternatively:
KM> (a Descending with (agent ((a Airplane))))
(_Descending510)

KM> (the position of (the Landing-Gear parts of (the agent of _Descending510)))
DEBUG: Built clone of (_ProtoAirplane281) to find valset(s) for (the agent-of of _Airplane511).
DEBUG: Built clone of (_ProtoAirplane274) to find valset(s) for (the parts of _Airplane511).
(*Down)
|#

;;; test:

((the number of (the parts of (a Airplane))) = 3)

((the position of (the Landing-Gear parts of (the agent of 
	(a Descending with (agent ((a Airplane))))))) = *Down)

;;; and in situations

(new-situation)

((the number of (the parts of (a Airplane))) = 3)

((the position of (the Landing-Gear parts of (the agent of 
	(a Descending with (agent ((a Airplane))))))) = *Down)

;;; ======================================================================
;;;		Check that the expressions are fully evaluated:
;;; ======================================================================

(reset-kb)

(a-prototype vw)

((the vw) has
	  (parts ((a Engine with
		     (parts ((a Ignition-system with
			       (parts ((a Distributor with
				        (parts ((a Distributor-Cap))))
				       (a Spark-Plug))))))))))

((the Distributor-Cap) has (near ((the Spark-Plug))))

(end-prototype)

((the near of (the Distributor-Cap (parts * 5) of (a vw))) isa Spark-Plug)

(new-situation)

((the near of (the Distributor-Cap (parts * 5) of (a vw))) isa Spark-Plug)

;;; ---------- another check ----------

(reset-kb)

(a-prototype Car)

((the Car) has
  (parts ((exactly 1 Engine))))

(end-prototype)

(new-context)

; beta-23 doesn't coerce values
(not (the parts of (a Car))) 


;;; ======================================================================
;;;		THIS IS A HORRIBLE ONE!
;;; beta-25 hits a bug here, where loops interact with prototypes:
;;; ======================================================================

#|
KM> (the parts of *MyCar)
ERROR! Doing (the instance-of of (exactly 1 Engine)) 
	- the frame name `(exactly 1 Engine)' should be a symbol!

Reason for the bug:

(the parts of *MyCar)
 -> create clone of ProtoCar
  -> unify CloneCar with *MyCar
   -> do (the parts of CloneCar) unify with (the parts of *MyCar)?
    -> what are the parts of *MyCar 
	= looping
	-> vals so far, = a STRUCTURE
		((exactly 1 Engine)
		 (a Engine with (parts ((a Cylinder)))))
	but the constraint checker assumes vals are returned!!

FIX: Let's ensure that any local values found at loop detection *are*
evaluated and stored back. We cannot assume that they are already
evaluated. (Without constraints, we delayed the evaluation until later,
but with constraints we can no longer do this).
|#

(reset-kb)

(*MyCar has
  (instance-of (Car))
  (parts ((exactly 1 Engine)
	  (a Engine with (parts ((a Cylinder)))))))

(a-prototype Car)

((the Car) has (parts ((a Chassis))))

(end-prototype)

(the parts of *MyCar)

;;; ======================================================================
;;;		TEST CLONING IN SITUATIONS
;;; ======================================================================

(reset-kb)

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

(a-prototype Airplane)

((the Airplane) has
  (parts ((a Wing with (side (*Left)))
	  (a Wing with (side (*Right)))
	  (a Landing-Gear))))

(end-prototype)

(parts has 			; New 2/8/01
  (instance-of (Slot))
  (fluent-status (*Non-Fluent)))

(X == (a Airplane))

(new-situation)
(Y == (the Landing-Gear parts of X))
(next-situation)
(Y = (the Landing-Gear parts of X))
(global-situation)
(Y = (the Landing-Gear parts of X))
(new-situation)
(Y = (the Landing-Gear parts of X))

(global-situation) 
(Z == (a Airplane))
(new-situation)
(next-situation)
(W == (the Landing-Gear parts of Z))
(in-situation (the prev-situation of (curr-situation)))
(W = (the Landing-Gear parts of Z))

;;; ======================================================================
;;;	This is more a test of KM's unification mechanism, to ensure
;;;	sets with (instance-of ((<> Class))) constraints are correctly
;;;	unified, and also move with the prototype.
;;; ======================================================================

(reset-kb)

(a-prototype Invade)
((the Invade) has (subevents ((a Move with (instance-of ((<> Enter)))) (a Enter))))
(end-prototype)

(Enter has (superclasses (Move)))

(a-prototype SubInvade)
((the SubInvade) has (subevents ((a Enter))))
(end-prototype)

(SubInvade has (superclasses (Invade)))
(Enter has (superclasses (Move)))

((the number of (the Enter subevents of (a SubInvade))) = 1)

;;; ======================================================================
;;;	MULTIPLE PROTOTYPES IN SITUATIONS
;;; ======================================================================

;;; prototypes.lisp did a low-level add-val for cloned-from, but I forgot to add the *global-situation*
;;; qualifier. As a result, cloned-from was mistakenly asserted in a non-global situation - my low-level
;;; shortcut went below KM's radar. Now fixed 3/8/00

(reset-kb)

(a-prototype Car)
((the Car) has (parts ((a Engine))))
(end-prototype)

(a-prototype Car)
((the Car) has (parts ((a Engine))))
(end-prototype)

(new-situation)

;;; Shouldn't produce an infinite loop!!
(the parts of (a Car))

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

(reset-kb)

(a-prototype Car with (color (*Red)))

((the Car) has (parts ((a Engine))))

(end-prototype)

(print (the parts of (a Car with (color (*Red)))))

;;; ======================================================================

;;; Make sure "Self" is preserved, and not evaluated to _ProtoPerson3, with
;;; self-referential prototypes:
(a-prototype Person with (likes (Self)))

((the Person) has (is-of-type (Narcisistic)))

(end-prototype)

(*Fred has (instance-of (Person)) (likes (Self)))

((the is-of-type of *Fred) = Narcisistic)

;;; ======================================================================
;;; Make sure inheritance is also switched off during check-slotvals-constraints
;;; ======================================================================

#|
A km bug (inefficiency).
If we unify X and Y, and in the course of X we inherit and
assert some information which contributes to X in the process
(e.g. through check-slotvals-constraints) e.g. X-s->Z, then 
that information on X is lost because AFTER the unification we
assert a NEW X, including the unified data but not the extra
data whose side-effects were included. So we end up with
X-s-> nothing, but Z-invs->X in the KB. This isn't a 
drastic problem I think.

A second bug is inheritance shouldn't be invoked by
check-slotvals-constraints during unification within prototypes,
as illustrated below.

Both have been fixed in KM 1.4.5.17
|#

(reset-kb)

(every Car has (parts ((a Engine) (must-be-a Thing))))

(Big-Car has (superclasses (Car)))

(a-prototype Person)

((the Person) has (owns ((a Car))))

((the Car) == (a Car with (parts ((a Door)))))

;;; This should succed, but instead returns 1
((the number of (every Engine)) = 0)

(end-prototype)

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

#|
;;; Subsumes test: This shouldn't fail with a null path
;;; No!! We better make it fail!! 
(a-prototype Car)

(the Car with (path ((the age of *Pete))))

(end-prototype)

FROM MY NOTES:
(_Car23 is '(a Car with (color ((the favorite-color of (the owner of Self))))))
returns NIL, *even if* the owner of Self = NIL.

Reason is we want to stop this:

(every Nice-Car has-definition
  (instance-of (Car))
  (color ((the favorite-color of (the owner of Self)))))

(a Car)
CLASSIFY: _Car23 is a Nice-Car!

Similarly 
(every Square has-definition
  (instance-of (Rectangle))
  (length ((the height of Self)))
  (height ((the length of Self))))

(a Rectangle)
CLASSIFY: _Rectangle23 is a Square!

This slightly violates the semantics of the KB (strictly null attribute
values should be ignored), but we assume that the rule is there for a 
reason and must return at least one value. This is implemented in subsumes.lisp
in slotvals-subsume optimization: If there's an expression, it's expected to
return at least one value and if the subsumee has zero values, then subsumption
is assumed to *fail*.
|#

#|
 ======================================================================
From Noah Friedland. This checks that looping on &+? results in success,
not failure. Simply a typo' in the original code.
 ======================================================================
|#

(reset-kb)

(resulting-state has 
  (instance-of (Relation))
  (domain (Event))
  (range (State))
  (inverse (resulting-state-of))
  (fluent-status (*Inertial-Fluent))
  (cardinality (1-to-1)))

(disable-classification)

(Herbivore has (superclasses (Animal)))

(Herbivore now-has (prototypes (_Herbivore1097)))

(_Herbivore1097 has
  (prototype-of (Herbivore))
  (prototype-scope (Herbivore))
  (prototype-participants (_Herbivore1097 _Plant1098 _Place1099
                           _Blood1100 _Eat1101 _Time-Interval1102
                           _Spatial-Entity1103 _Place1104
                           _Spatial-Entity1105 _Spatial-Entity1106
                           _Be-Contained1107 _Tangible-Entity1108
                           _Ruin1109 _Time-Interval1110 _Be-Ruined1111
                           _Place1112)))

(_Herbivore1097 has
  (instance-of (Herbivore))
  (has-goal (_Eat1101))
  (has-part (_Blood1100))
  (location (_Place1099))
  (new-objects (_Blood1100 _Eat1101 _Plant1098)))

(_Plant1098 has (instance-of (Plant)))

(_Place1099 has (instance-of (Place)))

(_Blood1100 has (instance-of (Blood)))

(_Eat1101 has
  (instance-of (Eat))
  (causes (_Ruin1109))
  (agent (_Tangible-Entity1108))
  (object (_Plant1098))
  (base (_Tangible-Entity1108))
  (resulting-state (_Be-Contained1107))
  (path (_Spatial-Entity1106))
  (origin (_Spatial-Entity1105))
  (site (_Place1104))
  (destination (_Spatial-Entity1103))
  (time (_Time-Interval1102)))

(_Time-Interval1102 has (instance-of (Time-Interval)))

(_Spatial-Entity1103 has (instance-of (Spatial-Entity)))

(_Place1104 has (instance-of (Place)))

(_Spatial-Entity1105 has (instance-of (Spatial-Entity)))

(_Spatial-Entity1106 has (instance-of (Spatial-Entity)))

(_Be-Contained1107 has (instance-of (Be-Contained)))

(_Tangible-Entity1108 has (instance-of (Animal)))

(_Ruin1109 has
  (instance-of (Ruin))
  (object (_Plant1098))
  (resulting-state (_Be-Ruined1111))
  (site (_Place1112))
  (time (_Time-Interval1110)))

(_Time-Interval1110 has (instance-of (Time-Interval)))

(_Be-Ruined1111 has (instance-of (Be-Ruined)))

(_Place1112 has (instance-of (Place)))

(Carnivore has (superclasses (Animal)))

(Carnivore now-has (prototypes (_Carnivore964)))

(_Carnivore964 has
  (prototype-of (Carnivore))
  (prototype-scope (Carnivore))
  (prototype-participants (_Carnivore964 _Animal965 _Place966 _Blood967
                           _Eat968 _Time-Interval969 _Spatial-Entity970
                           _Place971 _Spatial-Entity972
                           _Spatial-Entity973 _Be-Contained974
                           _Tangible-Entity975 _Ruin976 _Blood977
                           _Time-Interval978 _Be-Ruined979 _Place980
                           _Place981)))

(_Carnivore964 has
  (instance-of (Carnivore))
  (has-goal (_Eat968))
  (has-part (_Blood967))
  (location (_Place966))
  (new-objects (_Blood967 _Eat968 _Animal965)))

(_Animal965 has (instance-of (Animal)) (has-part (_Blood977)))

(_Place966 has (instance-of (Place)))

(_Blood967 has (instance-of (Blood)))

(_Eat968 has
  (instance-of (Eat))
  (causes (_Ruin976))
  (agent (_Tangible-Entity975))
  (object (_Animal965))
  (base (_Tangible-Entity975))
  (resulting-state (_Be-Contained974))
  (path (_Spatial-Entity973))
  (origin (_Spatial-Entity972))
  (site (_Place971))
  (destination (_Spatial-Entity970))
  (time (_Time-Interval969)))

(_Time-Interval969 has (instance-of (Time-Interval)))

(_Spatial-Entity970 has (instance-of (Spatial-Entity)))

(_Place971 has (instance-of (Place)))

(_Spatial-Entity972 has (instance-of (Spatial-Entity)))

(_Spatial-Entity973 has (instance-of (Spatial-Entity)))

(_Be-Contained974 has (instance-of (Be-Contained)))

(_Tangible-Entity975 has (instance-of (Animal)))

(_Ruin976 has
  (instance-of (Ruin))
  (object (_Animal965))
  (resulting-state (_Be-Ruined979))
  (site (_Place980))
  (time (_Time-Interval978)))

(_Blood977 has (instance-of (Blood)) (location (_Place981)))

(_Time-Interval978 has (instance-of (Time-Interval)))

(_Be-Ruined979 has (instance-of (Be-Ruined)))

(_Place980 has (instance-of (Place)))

(_Place981 has (instance-of (Place)))

(enable-classification)

(Omnivore has (superclasses (Herbivore Carnivore)))

;;; Make sure the two goals unify!
((the number of (the has-goal of (a Omnivore))) = 1)

;;; ======================================================================
;;; Test for allowing multiple protoype-scopes, and for
;;; instance-of and prototype-of to differ
;;; ======================================================================

(reset-kb)

(MyClass has (superclasses (Entity)))

(_MyClass5051 has 
  (instance-of (MyClass))
  (prototype-of (Entity))
  (prototype-participants (_MyClass5051
                           _Animal5052))
  (prototype-participant-of (_MyClass5051))
  (prototype-scope (MyClass
                    (the-class Entity with (is-near ((a Animal))))))
  (is-near (_Animal5052 *Fred)))

(_Animal5052 has (instance-of (Animal)))

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

((the is-near of (a Entity with (is-near ((a Animal)))))
	includes *Fred)

((the is-near of (a MyClass))
	includes *Fred)

;;; Check we can switch this off...
(disable-classification)

(not ((the is-near of (a Entity with (is-near ((a Animal)))))
	includes *Fred))

(enable-classification)

((the is-near of (a Entity with (is-near ((a Animal)))))
	includes *Fred)

;;; ======================================================================

;;; Check cloning doesn't copy cloned-from links pointing WITHIN the current prototype
(reset-kb)

(_Person1 has
  (instance-of (Person))
  (prototype-of (Person))
  (prototype-scope (Person))
  (prototype-participants (_Person1 _Person2))
  (parent (_Person2)))

(_Person2 has
  (instance-of (Person))
  (clone-built-from (_Person1))	; <==
  (cloned-from (_Person1))) ; <==

(_X == (clone _Person1))

(not (the has-clones of _X))
(not (the has-built-clones of _X))



(print "prototypes2.km")

(reset-kb)

(connects has (fluent-status (*Inertial-Fluent)))

(every Disconnect has
  (subject ((a Thing)))
  (object ((a Thing)))
  (pcs-list ((:triple (the subject of Self) connects (the object of Self))))
  (del-list ((:triple (the subject of Self) connects (the object of Self)))))

(a-prototype Foo)

((the Foo) has (parts ((a Part1) (a Part2))))

((the Part1) has (connects ((the Part2))))

(end-prototype)

(new-situation)

(_X == (a Foo))

; (the connects of (the Part1 parts of _X))

(do-and-next (a Disconnect with (subject ((the Part1 parts of _X)))
				(object ((the Part2 parts of _X)))))

(not (the connects of (the Part1 parts of _X)))

#|
NOTE: _Part17 is allowed to have NO connects in _Situation9, as "inheritance" of
inertial fluent info from *Global to _Situation9 is blocked (as _Situation9 has a
preceding situation, and _Part17 is a clone).

[_Situation9] KM> (showme (the Part1 parts of _X))
(_Part17 has 
  (parts-of (_X))
  (instance-of (Part1))
  (connects (_Part28))
  (cloned-from (_ProtoPart12)))

(in-situation _Situation4
  (_Part17 has 
    (parts-of (_X))
    (subject-of (_Disconnect5))
    (connects (_Part28))))

(in-situation _Situation9
  (_Part17 has 
    (connects ((<> _Part28)))
    (parts-of (_X))))
|#




(print "prototypes3.km")

;;; Very clever test from Sunil to make sure prototypes unify along the cloned-from links

(reset-kb)

;;; Car

(Car has (superclasses (Thing)))
(_Car1 has
       (prototype-of (Car))
       (prototype-scope (Car))
       (prototype-participants (_Car1)))
(_Car1 has (instance-of (Car)))

;;; Person

(Person has (superclasses (Thing)))
(_Person2 has
	  (prototype-of (Person))
	  (prototype-scope (Person))
	  (prototype-participants (_Person2)))
(_Person2 has (instance-of (Person)))

;;; Drive

(Drive has (superclasses (Thing)))
(_Drive3 has
	 (prototype-of (Drive))
	 (prototype-scope (Drive))
	 (prototype-participants (_Drive3 _Car4 _Person5)))
(_Drive3 has
	 (instance-of (Drive))
	 (object (_Car4)))
(_Car4 has
       (instance-of (Car))
       (contains (_Person5)))
(_Person5 has
	  (instance-of (Person))
	  (plays (*driver)))

;;; Drive-With-Passenger

(Drive-With-Passenger has (superclasses (Drive)))
(_Drive-With-Passenger6 has
			(prototype-of (Drive-With-Passenger))
			(prototype-scope (Drive-With-Passenger))
			(prototype-participants (_Drive-With-Passenger6 _Car7 _Person8 _Person9)))
(_Drive-With-Passenger6 has
	 (instance-of (Drive-With-Passenger))
	 (object (_Car7)))
(_Car7 has
       (instance-of (Car))
       (contains (_Person9 _Person8)))
(_Person8 has
	  (instance-of (Person))
	  (cloned-from (_Person5)))
(_Person9 has
	  (instance-of (Person))
	  (plays (*passenger)))

;;; EOF
;;; TEST:

;((_Pers1 _Pers2) === ((the contains of (the object of (a Drive-With-Passenger)))))

#|
In previous implementations, the unification went bad and we had:
((the plays of _Pers1) == (:set *passenger *driver))
((the plays of _Pers2) == NIL)

In KM 2.0.43 we used the cloned-from tags to ensure unification prefers matching clones
from the same protoinstance together.
|#

;((the plays of _Pers1) == *passenger)
;((the plays of _Pers2) == *driver)
(print "prototypes4.km")

;;; Test non-tree-like definitions

(reset-kb)

(Square has (superclasses (Rectangle)))

(_Square1 has
  (instance-of (Square))
  (prototype-of (Rectangle))
  (prototype-scope (Square 
                    (the-class Rectangle with
			(length ((the width of Self)))
			(width ((the length of Self))))))
  (prototype-participants (_Square1))
  (prettiness (*pretty)))

((the prettiness of (a Rectangle with (width (10)) (length (10)))) = *pretty)
(not (the prettiness of (a Rectangle with (width (10)) (length (11)))))

;;; ======================================================================


#|
HERE we allow a special case of overriding for prototypes:
IF  we're unifying prototypes
AND the slot is inherit-with-overrides
AND the two values clash (either single-valuedp or constraint)
AND the neither values have Skolem instances in it
THEN the first's values (together) completely override the second's values
   [could be more sophisticated, but that's it for now]
|#

(reset-kb)
(age has (inherit-with-overrides (t)))
(every Vehicle has
  (age ((at-most 1 Thing))))
(a-prototype Vehicle)
((the Vehicle) has (parts ((a Seat with (color (*Blue))))) (age ((:pair 20 *year))))
(end-prototype)
(a-prototype Car)
((the Car) has (parts ((a Seat with (color (*Red))))) (age ((:pair 10 *year))))
(end-prototype)
(Car has (superclasses (Vehicle)))
(a Car)
((the age of (thelast Car)) = (:pair 10 *year))

(reset-kb)
(age has (cardinality (N-to-1)))
(age has (inherit-with-overrides (t)))
(a-prototype Vehicle)
((the Vehicle) has (parts ((a Seat with (color (*Blue))))) (age ((:pair 20 *year))))
(end-prototype)
(a-prototype Car)
((the Car) has (parts ((a Seat with (color (*Red))))) (age ((:pair 10 *year))))
(end-prototype)
(Car has (superclasses (Vehicle)))
(a Car)
((the age of (thelast Car)) = (:pair 10 *year))


#|
This is actually a constraint violation.
NOTE: If we have *new override *old, then we have to make sure we do a 
delete-val of age *old on one of the prototypes, or else we have *old pointing
back to the new prototype even though it's not a value on the new prototype.



(reset-kb)
(age has (inherit-with-overrides (t)))
(every Vehicle has
  (age ((at-most 1 Thing))))
(a-prototype Vehicle)
((the Vehicle) has (parts ((a Seat with (color (*Blue))))) (age (*old)))
(end-prototype)
(a-prototype Car)
((the Car) has (parts ((a Seat with (color (*Red))))) (age (*new)))
(end-prototype)
(Car has (superclasses (Vehicle)))
(a Car)
((the age of (thelast Car)) = *new)

(reset-kb)
(age has (cardinality (N-to-1)))
(age has (inherit-with-overrides (t)))
(a-prototype Vehicle)
((the Vehicle) has (parts ((a Seat with (color (*Blue))))) (age (*old)))
(end-prototype)
(a-prototype Car)
((the Car) has (parts ((a Seat with (color (*Red))))) (age (*new)))
(end-prototype)
(Car has (superclasses (Vehicle)))
(a Car)		; _Car5
((the age of (thelast Car)) = *new)	; *new overrides *old
(not (the age-of of *old))


CL-USER(8): (showme '#$*new)
(*new has 
  (age-of (_ProtoCar3
           _Car5)))			; ok

(|*new|)
CL-USER(9): (showme '#$*old)
(*old has 
  (age-of (_ProtoVehicle1
           _Car5)))		<====== PROBLEM!!!! need to delete this inverse (similar to deleting
					values when a constraint is violated).
(|*old|)

To avoid this we simply don't allow overrides when the values are kb-objects like this.
|#

;;; ignore  q26.km


;;; ignore  q26aux.km


;;; ignore  q35a.km


;;; ignore  q35aaux.km

(print "quoted-paths.km")

;;; File: quoted-paths.km
;;; Author: Peter Clark
;;; Date: March 1999
;;; Purpose: Experimentation with quoted paths.

#|
To use a quoted path, <slot> is replaced with (<slot> * [n]) in two of the KM
expressions (below), where n is the depth to search (default 3).

The two modified forms for quoted paths are:

	 (the <class> (<slot> * [n]) of <expr>)		; standard notation
	 (.... (<slot> * [n]) <class> ...)		; linear notation

For example:
	(the Flap (parts *) of *MyPlane)
	(*MyPlane (parts *) Flap)

KM will search up to three links of type <slot> (and its subslots), stopping as
   soon as at least one value of <class> found.
|#

#|
structural hierarchy

Airplane
  Fuselage
  Wing
    Flap
    Engine
  Wing
    Flap
    Engine
  Tail
|#

(reset-kb)

(every Airplane has
  (parts ((a Fuselage) 
	  (a Wing with (side (*Left)))
	  (a Wing with (side (*Right)))
	  (a Tail)))
  (housed-in ((a Hanger))))

(Hanger has (superclasses (Building)))

(every Hanger has
  (parts ((a Door))))

(every Wing has
  (parts ((a Flap)))
  (connects-to ((a Engine))))

(every Fuselage has
  (parts ((a Body-Skin with
		(contains ((a Door)))))))

(every Engine has
  (parts ((a Turbine))))

(every Tail has
  (parts ((a Horizontal-Stabilizer) 
	  (a Vertical-Stabilizer))))

(every Horizontal-Stabilizer has
  (parts ((a Flap))))	; actually it's called an Elevator, but Flap will do to make our point

;;; Now the instance...
(*MyPlane has (instance-of (Airplane)))

#| 
Slot hierarchy:
any-relation-to
  housed-in
  structurally-related-to
    parts
    contains
    connects-to   
|#

(contains has
  (instance-of (Slot))
  (superslots (structurally-related-to)))

(connects-to has
  (instance-of (Slot))
  (superslots (structurally-related-to)))

(parts has
  (instance-of (Slot))
  (superslots (structurally-related-to)))

(structurally-related-to has
  (instance-of (Slot))
  (superslots (any-relation-to)))

(housed-in has
  (instance-of (Slot))
  (superslots (any-relation-to)))

;;; ======================================================================
;;;		TEST QUERIES
;;; ======================================================================

(SETQ *LINEAR-PATHS* T)

((the number of (the parts of *MyPlane)) = 4)

((the number of (the Flap (parts *) of *MyPlane)) = 3)

((the number of (the Engine (structurally-related-to *) of *MyPlane)) = 2)

((the number of (the Door (structurally-related-to *) of *MyPlane)) = 1)

((the number of (the Door (any-relation-to *) of *MyPlane)) = 2)

((the number of (the Door (parts *) of 			
	(the Building (housed-in *) of *MyPlane))) = 1)

;;; ---------- linear notation:

((*MyPlane parts * number) = 4)
((*MyPlane (parts *) Flap number) = 3)
((*MyPlane (structurally-related-to *) Engine number) = 2)
((*MyPlane (structurally-related-to *) Door number) = 1)
((*MyPlane (any-relation-to *) Door number) = 2)
((*MyPlane (housed-in *) Building (parts *) Door number) = 1)

#|
KM> (reload-kb "quoted-paths.km")
Resetting KM...
Reading quoted-paths.km...
quoted-paths.km read!

	NON-LINEAR NOTATION				   LINEAR NOTATION

KM> (*MyPlane has (instance-of (Airplane)))

KM> (the parts of *MyPlane)				 ; (*MyPlane parts)
(_Fuselage14377 _Wing14378 _Wing14379 _Tail14380)

;;; Of course this fails, as Flap isn't a direct part...
KM> (the Flap parts of *MyPlane)			 ; (*MyPlane parts Flap)
NIL

;;; But it *is* an indirect part, which can be accessed using a quoted path.
;;; 2 flaps on the wing, one on the horizontal stablizer
KM> (the Flap (parts *) of *MyPlane)			 ; (*MyPlane (parts *) Flap)
(_Flap14392 _Flap14393 _Flap2344)

;;; Similarly, Engine isn't a direct part
KM> (the Engine (parts *) of *MyPlane)			 ; (*MyPlane (parts *) Engine)
NIL

;;; But it *is* an indirect part, which can be accessed using a quoted path
KM> (the Engine (structurally-related-to *) of *MyPlane) ; (*MyPlane (structurally-related-to *) Engine)
(_Engine14414 _Engine14416)

;;; Note: Correctly finds the door of the plane's body skin, not the door of the plane's hanger.
KM> (the Door (structurally-related-to *) of *MyPlane)   ; (*MyPlane (structurally-related-to *) Door)
(_Door14431)

KM> (showme _Door14431)
(_Door14431 has 
  (structurally-related-to-of (_Body-Skin14424))
  (contains-of (_Body-Skin14424))
  (instance-of (Door)))

;;; If we look along *any* relation, we find the door of the hanger too.
KM> (the Door (any-relation-to *) of *MyPlane)		 ; (*MyPlane (any-relation-to *) Door)
(_Door14431 _Door14442)

KM> (showme _Door14442)
(_Door14442 has 
  (any-relation-to-of (_Hanger14437))
  (structurally-related-to-of (_Hanger14437))
  (parts-of (_Hanger14437))
  (instance-of (Door)))

;;; An explicit query for the doors of the buildings which the plane is housed in (!)
KM> (the Door (parts *) of 				 ; (*MyPlane (housed-in *) Building (parts *) Door)
	(the Building (housed-in *) of *MyPlane))
(_Door14442)
|#

;;; ----------------------------------------
;;;	1.4.0-beta12 additions, allow classes to remain unspecified
;;; ----------------------------------------

((the number of ((a Airplane) (parts *))) = 10)

((the number of (the (parts *) of (a Airplane))) = 10)

(SETQ *LINEAR-PATHS* NIL)

(print "rabbit.km")
;;; Situation-specific instance-of information is no longer supported -- it
;;; just gets too complicated!! We can always put it back in when we've
;;; worked how to *un*change an item's class, by saying:
;;; KM> (setq *BUILT-IN-INERTIAL-FLUENT-SLOTS* '(instance-of instances))

#|
KM>  (new-situation)

[_Situation0] KM>  (*MyThing has (instance-of (Thing)))

[_Situation0] KM>  (do-and-next
   (a Create with 
     (created (*MyThing))
     (will-be-a (Rabbit))
     (add-list ((:triple (the created of Self) instance-of (the will-be-a of Self))))))
(COMMENT: Changing to situation _Situation2)

[_Situation2] KM>  (do-and-next
   (a Change with 
     (changed (*MyThing))
     (will-be-a (Dove))
     (del-list ((:triple (the changed of Self) instance-of (the instance-of of (the changed of Self)))))
     (add-list ((:triple (the changed of Self) instance-of (the will-be-a of Self))))))
(COMMENT: Changing to situation _Situation4)

[_Situation4] KM>  (do-and-next
  (a Destroy with 
     (destroyed (*MyThing))
     (del-list ((:triple (the destroyed of Self) instance-of (the instance-of of (the destroyed of Self)))))))
(COMMENT: Changing to situation _Situation6)

[_Situation6] KM> (forall (the instances of Situation)
                     (km-format t "In ~a, *MyThing was a ~a.~%" 
				It (in-situation It (the instance-of of *MyThing))))
In (_Situation0), *MyThing was a (Thing).
In (_Situation2), *MyThing was a (Rabbit).
In (_Situation4), *MyThing was a (Dove).
In (_Situation6), *MyThing was a (Thing).
|#

;;; ======================================================================

(reset-kb)

(instance-of-is-fluent)

(Action has (superclasses (Event)))

(Create has (superclasses (Action)))
(Change has (superclasses (Action)))
(Destroy has (superclasses (Action)))

(new-situation)

(*MyThing == (a Thing))

(do-and-next
 (a Create with
  (created (*MyThing))
  (will-be-a (Rabbit))
  (add-list ((:triple (the created of Self) instance-of (the will-be-a of Self))))))


(do-and-next
 (a Change with
  (changed (*MyThing))
  (will-be-a (Dove))
  (del-list ((:triple (the changed of Self) instance-of 
			(the instance-of of (the changed of Self)))))
  (add-list ((:triple (the changed of Self) instance-of (the will-be-a of Self))))))

(do-and-next
 (a Destroy with
  (destroyed (*MyThing))
  (del-list ((:triple (the destroyed of Self) instance-of
			(the instance-of of (the destroyed of Self)))))))

;;; Test!!
((the number of (allof (the all-instances of Situation) 
		 where (in-situation It (*MyThing isa Rabbit)))) = 1)
((the number of (allof (the all-instances of Situation) 
		 where (in-situation It (*MyThing isa Dove)))) = 1)
((the number of (allof (the all-instances of Situation) 
		 where (in-situation It (    (not (*MyThing isa Dove))
					 and (not (*MyThing isa Rabbit)))))) = 2)

; Output:
;(forall (the instances of Situation)
;                     (km-format t "In ~a, *MyThing was a ~a.~%" 
;				It (in-situation It (the instance-of of *MyThing))))

;;; Unset this again!
;(instance-of-is-nonfluent)

;;; ======================================================================

(reset-kb)

(instance-of-is-fluent)

(new-situation)

(X == (a Car with (instance-of ((<> Dog)))))

#|
An obscure bug (fixed): For non-first calls for classes within a 
situation, I forgot to filter out the constraints:
[_Situation2] KM> ((the classes of X) and (the classes of X))
(Car (<> Dog))		<- incorrect		
|#
#'(LAMBDA () 
    (= (LENGTH (KM0 '#$((the classes of X) and (the classes of X)))) 1))






(print "recursive-classification.km")

#|
This is an example where recursive classification is needed:
(a Woman) is created, and in the attempt to classify that,
(a Ball) is created. But as this second creation is done as part
of a classification task, then the second classification (Ball ->
Soccer-Ball) is *not* carried out.

To make this example work, then we simply change in classify in
frame-io.lisp
	 (setq *am-classifying* t)
to
	 (setq *am-classifying* nil)
which makes *am-classifying* permanently nil.

This is a difficult design decision; we're introducing some 
logical incompleteness here to simplify the proof trace and
improve inference speed.
|#

(reset-kb)

(*fred has 
   (spouse ((a Woman with 
               (hobby ((a Hobby with 
                          (played-with ((a Ball with 
					   (color (*white))))))))))))


(Soccer-ball has (superclasses (Ball)))
(every Soccer-ball has-definition
       (instance-of (Ball))
       (color (*white)))

(Active-Woman has (superclasses (Woman)))
(every Active-Woman has-definition
       (instance-of (Woman))
       (hobby ((a Hobby with 
		  (played-with ((a Soccer-ball)))))))
;		  (played-with (*soccer-ball))))))


(Soccer has (superclasses (Hobby)))
(every Soccer has-definition
       (instance-of (Hobby))
       (played-with ((a Soccer-ball))))
;      (played-with (*soccer-ball)))



(new-situation)
((the spouse of *fred) isa Active-Woman)
((the played-with of (the hobby of (the spouse of *fred)))  isa Soccer-ball)




;;; ignore  refman.km

(print "restaurant.km")

;;; TEST-SUITE ENTRY FOR WORKING NOTE 17
;;; http://www.cs.utexas.edu/users/clarkp/working_notes

;;; File: restaurant-classes.km
;;; Author: Peter Clark

;;; This file requires KM 1.4.0-beta33 or later 

(reset-kb)

;;; cotemporal-with isn't used in this KB, but we put it there anyway for completeness
(before has (instance-of (Slot)) (inverse (after)))
(cotemporal-with has (instance-of (Slot)) (inverse (cotemporal-with)))
(subevents has (instance-of (Slot)) (inverse (superevents)))

;;; [1] This ugly formatting statements simply prints out the before, cotemporal-with, and after 
;;; properties of for each subevent of the main event.
(every Event has
  (all-subevents ((the subevents of Self) 
                  (the all-subevents of (the subevents of Self))))
  (subevents ((the subevents of (the component-events of Self))))
  (description-of-all-subevents (
      (make-sentence
             (forall (the all-subevents of Self)                        ; [1]
                (:seq It "."
                      (if   (has-value (the before of It)) 
                       then (:seq It "is before" (the before of It) "."))
                      (if   (has-value (the cotemporal-with of It)) 
                       then (:seq It "is cotemporal with" (the cotemporal-with of It) "."))
                      (if   (has-value (the after of It)) 
                       then (:seq It "is after" (the after of It) "."))
                      (format nil "~%")))))))

(Paying has (superclasses (Event)))
(Sitting has (superclasses (Event)))
(Getting has (superclasses (Event)))
(Eating has (superclasses (Event)))

;;; ----------------------------------------
;;;             PURCHASING
;;; ----------------------------------------

(Purchasing has (superclasses (Event)))

(every Purchasing has
  (buyer ((a Agent)))
  (seller ((a Agent)))
  (item ((a Thing)))
  (money ((a Amount-Of-Money)))
  (subevents (                          ; NOTE no ordering assumed here
    (a Getting with
       (agent ((the seller of Self)))
       (patient ((the item of Self)))
       (recipient ((the buyer of Self))))
    (a Paying with
       (agent ((the buyer of Self)))
       (patient ((the money of Self)))
       (recipient ((the seller of Self)))))))

;;; ----------------------------------------
;;;             DINING
;;; ----------------------------------------

(Dining has (superclasses (Event)))

(every Dining has
   (agent ((a Person)))
   (patient ((a Edible-Thing)))
   (location ((a Place)))
   (subevents (                                 ; again, no ordering implied
     (a Sitting with
       (agent ((the agent of Self)))
       (location ((the location of Self)))
       (before ((the Eating subevents of Self))))
     (a Getting with
       (agent ((the agent of Self)))
       (patient ((the patient of Self)))
       (before ((the Eating subevents of Self))))
     (a Eating with
       (agent ((the agent of Self)))
       (patient ((the patient of Self)))
       (after ((the Sitting subevents of Self)
               (the Getting subevents of Self)))))))

;;; ----------------------------------------
;;;     THE COMPOSITION: RESTAURANT VISITING = PURCHASING + DINING
;;; ----------------------------------------

(Restaurant-Visiting has (superclasses (Event)))

;;; [1] This is a slightly awkward way of saying the two Gettings (in the Purchasing and Dining)
;;; are coreferential.
(every Restaurant-Visiting has
  (diner ((a Person)))
  (meal ((a Meal)))
  (restaurant ((a Restaurant)))
  (table ((a Table with 
            (location ((the restaurant of Self))))))
  (money ((a Amount-Of-Money)))
  (component-events (
    (a Purchasing with
      (buyer ((the diner of Self)))
      (seller ((the restaurant of Self)))
      (item ((the meal of Self)))
      (money ((the money of Self)))
      (subevents ((the Getting subevents of (the Dining component-events of Self))))) ; [1]
    (a Dining with
      (agent ((the diner of Self)))
      (patient ((the meal of Self)))
      (location ((the table of Self)))
      (subevents ((the Getting subevents of (the Purchasing component-events of Self))))))))    ; [1]

;;; ----------------------------------------
;;;     MCDONALDS-RESTAURANT-VISITING: Extra constraints on event ordering specified
;;; ----------------------------------------

(McDonalds-Restaurant-Visiting has (superclasses (Restaurant-Visiting)))

;;; We now define the McDonalds-Specific Connections between components:

;;; [1] the Paying is before the Getting.
;;; [2] the Getting is before the Sitting and the Eating.
(every McDonalds-Restaurant-Visiting has
   (component-events (
      (a Purchasing with 
        (subevents ((a Paying with 
                        (before ((the Getting subevents of              ; [1]
                                     (the Dining component-events of Self))))))))
      (a Dining with
        (subevents ((a Getting with
                        (before ((the Sitting subevents of              ; [2]
                                     (the Dining component-events of Self))
                                 (the Eating subevents of
                                     (the Dining component-events of Self)))))))))))

;;; ----------------------------------------
;;;     TRUDYS-RESTAURANT-VISITING: Extra constraints on event ordering specified
;;; ----------------------------------------

(Trudys-Restaurant-Visiting has (superclasses (Restaurant-Visiting)))

;;; [1] the Paying is after the Eating.
;;; [2] the Getting is after the Sitting.
(every Trudys-Restaurant-Visiting has
   (component-events (
      (a Purchasing with 
        (subevents ((a Paying with 
                        (after ((the Eating subevents of                ; [1]
                                     (the Dining component-events of Self)))))
                    (a Getting with
                        (after ((the Sitting subevents of               ; [2]
                                     (the Dining component-events of Self)))))))))))

;;; --- end ---

;;; ======================================================================
;;;			TEST (rather crude, doing text matching!)
;;; ======================================================================

;;; Add tests later
(the description-of-all-subevents of (a Restaurant-Visiting))
(the description-of-all-subevents of (a McDonalds-Restaurant-Visiting))
(the description-of-all-subevents of (a Trudys-Restaurant-Visiting))

;(trace)
;
;(forall (the all-subevents of (a Restaurant-Visiting))
;	(:seq It (the before of It) (the cotemporal-with of It) (the after of It)))
; to be added later...


#|
((the description-of-all-subevents of (a Restaurant-Visiting)) = 
"The getting. The getting is before the eating.
The paying.
The sitting. The sitting is before the eating.
The eating. The eating is after the sitting the getting. 
.")

;(print (the description-of-all-subevents of (a McDonalds-Restaurant-Visiting)))

;;; NOTE: An inference incompletenss below - "The getting is after the paying." is omited because
;;; this information is attached to Paying, not processed until after the Getting is processed.
((:set "The getting. The getting is before the eating the sitting.
The paying. The paying is before the getting.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the sitting the getting. 
."
"The getting. The getting is before the eating the sitting. The getting is after the paying.
The paying. The paying is before the getting.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the getting the sitting. 
."
"The getting. The getting is before the eating the sitting.
The paying. The paying is before the getting.
The eating. The eating is after the getting the sitting.
The sitting. The sitting is before the eating. The sitting is after the getting. 
."
"The paying. The paying is before the getting.
The getting. The getting is before the sitting the eating. The getting is after the paying.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the sitting the getting. 
."
)
includes (the description-of-all-subevents of (a McDonalds-Restaurant-Visiting)))

;(print (the description-of-all-subevents of (a Trudys-Restaurant-Visiting)))

((:set
"The eating. The eating is after the sitting the getting.
The sitting. The sitting is before the eating.
The getting. The getting is before the eating. The getting is after the sitting.
The paying. The paying is after the eating. 
."
"The getting. The getting is before the eating. The getting is after the sitting.
The paying. The paying is after the eating.
The sitting. The sitting is before the getting the eating.
The eating. The eating is before the paying. The eating is after the sitting the getting. 
."
"The paying. The paying is after the eating.
The getting. The getting is before the eating. The getting is after the sitting.
The sitting. The sitting is before the getting the eating.
The eating. The eating is before the paying. The eating is after the sitting the getting. 
."
"The paying. The paying is after the eating.
The getting. The getting is before the eating. The getting is after the sitting.
The sitting. The sitting is before the eating the getting.
The eating. The eating is before the paying. The eating is after the sitting the getting. 
."
) includes
(the description-of-all-subevents of (a Trudys-Restaurant-Visiting)))
|#

;;; ======================================================================

;;; File: restaurant-prototypes.km
;;; Author: Peter Clark

;;; This file requires KM 1.4.0-beta33 or later 

(reset-kb)

;;; cotemporal-with isn't used in this KB, but we put it there anyway for completeness
(before has (instance-of (Slot)) (inverse (after)))
(cotemporal-with has (instance-of (Slot)) (inverse (cotemporal-with)))
(subevents has (instance-of (Slot)) (inverse (superevents)))

;;; [1] This ugly formatting simply prints out the before, cotemporal-with, and after properties of
;;; for each subevent of the main event.
(every Event has
  (all-subevents ((the subevents of Self) 
                  (the all-subevents of (the subevents of Self))))
  (subevents ((the subevents of (the component-events of Self))))
  (description-of-all-subevents (
      (make-sentence
             (forall (the all-subevents of Self)                        ; [1]
                (:seq It "."
                      (if   (has-value (the before of It)) 
                       then (:seq It "is before" (the before of It) "."))
                      (if   (has-value (the cotemporal-with of It)) 
                       then (:seq It "is cotemporal with" (the cotemporal-with of It) "."))
                      (if   (has-value (the after of It)) 
                       then (:seq It "is after" (the after of It) "."))
                      (format nil "~%")))))))

(Paying has (superclasses (Event)))
(Sitting has (superclasses (Event)))
(Getting has (superclasses (Event)))
(Eating has (superclasses (Event)))

;;; ----------------------------------------
;;;             PURCHASING
;;; ----------------------------------------

(Purchasing has (superclasses (Event)))

(a-prototype Purchasing)

((the Purchasing) has
  (buyer ((a Agent)))
  (seller ((a Agent)))
  (item ((a Thing)))
  (money ((a Amount-Of-Money)))
  (subevents (                          ; NOTE no ordering assumed here
    (a Getting with
       (agent ((the seller of Self)))
       (patient ((the item of Self)))
       (recipient ((the buyer of Self))))
    (a Paying with
       (agent ((the buyer of Self)))
       (patient ((the money of Self)))
       (recipient ((the seller of Self)))))))

(end-prototype)

;;; ----------------------------------------
;;;             DINING
;;; ----------------------------------------

(Dining has (superclasses (Event)))

(a-prototype Dining)

((the Dining) has
   (agent ((a Person)))
   (patient ((a Edible-Thing)))
   (location ((a Place)))
   (subevents (                                 ; again, no ordering implied
     (a Sitting with
       (agent ((the agent of Self)))
       (location ((the location of Self))))
     (a Getting with
       (agent ((the agent of Self)))
       (patient ((the patient of Self))))
     (a Eating with
       (agent ((the agent of Self)))
       (patient ((the patient of Self)))))))

((the Sitting) has (before ((the Eating))))
((the Getting) has (before ((the Eating))))
;;; (but we don't know whether the sitting is before or after the getting)

(end-prototype)

;;; ----------------------------------------
;;;     THE COMPOSITION: RESTAURANT VISITING = PURCHASING + DINING
;;; ----------------------------------------

(Restaurant-Visiting has (superclasses (Event)))

(a-prototype Restaurant-Visiting)

((the Restaurant-Visiting) has
  (diner ((a Person)))
  (meal ((a Meal)))
  (restaurant ((a Restaurant)))
  (table ((a Table with 
            (location ((the restaurant of Self))))))
  (money ((a Amount-Of-Money))))

;;; Specify the components...

((the Restaurant-Visiting) has
  (component-events (
    (a Purchasing with
      (buyer ((the Person)))
      (seller ((the Restaurant)))
      (item ((the Meal)))
      (money ((the Amount-Of-Money))))
    (a Dining with
      (agent ((the Person)))
      (patient ((the Meal)))
      (location ((the Table)))))))

;;; Introduce these subevents (as I want to then refer to them)...
((the Purchasing) has (subevents ((a Getting))))
((the Dining) has (subevents ((a Getting))))

;;; ...and then state they are coreferential (== does unification)
((the Getting subevents of (the Purchasing)) ==  (the Getting subevents of (the Dining)))

(end-prototype)

;;; ----------------------------------------
;;;     MCDONALDS-RESTAURANT-VISITING: Extra constraints on event ordering specified
;;; ----------------------------------------

(McDonalds-Restaurant-Visiting has (superclasses (Restaurant-Visiting)))

(a-prototype McDonalds-Restaurant-Visiting)

;;; We now define the McDonalds-Specific Connections between components:
;;; (a) Explicitly create the to-be-referred-to objects...

((the McDonalds-Restaurant-Visiting) has
   (component-events ((a Purchasing with 
                        (subevents ((a Getting) (a Paying))))
                      (a Dining with
                        (subevents ((a Sitting) (a Eating)))))))

;;; ...then (b) state the connections of interest...
((the Paying) has (before ((the Getting))))
((the Getting) has (before ((the Sitting))))
((the Getting) has (before ((the Eating))))

(end-prototype)

;;; ----------------------------------------
;;;     TRUDYS-RESTAURANT-VISITING: Extra constraints on event ordering specified
;;; ----------------------------------------

(Trudys-Restaurant-Visiting has (superclasses (Restaurant-Visiting)))

(a-prototype Trudys-Restaurant-Visiting)

;;; We now define the Trudys-Specific Connections between components:
;;; (a) Explicitly create the to-be-referred-to objects...

((the Trudys-Restaurant-Visiting) has
   (component-events ((a Purchasing with 
                        (subevents ((a Getting) (a Paying))))
                      (a Dining with
                        (subevents ((a Sitting) (a Eating)))))))

;;; ...then (b) state the connections of interest...
((the Paying) has (after ((the Eating))))
((the Getting) has (after ((the Sitting))))

(end-prototype)

;;; ======================================================================
;;;			TEST (rather crude, doing text matching!)
;;; ======================================================================

;;; Add tests later
(the description-of-all-subevents of (a Restaurant-Visiting))
(the description-of-all-subevents of (a McDonalds-Restaurant-Visiting))
(the description-of-all-subevents of (a Trudys-Restaurant-Visiting))

#|
;(print (the description-of-all-subevents of (a Restaurant-Visiting)))

((:set "The getting. The getting is before the eating.
The paying.
The sitting. The sitting is before the eating.
The eating. The eating is after the getting the sitting. 
."
"The getting. The getting is before the eating.
The paying.
The eating. The eating is after the getting the sitting.
The sitting. The sitting is before the eating. 
."
"The getting. The getting is before the eating.
The paying.
The eating. The eating is after the sitting the getting.
The sitting. The sitting is before the eating. 
."
) includes (the description-of-all-subevents of (a Restaurant-Visiting)))


;(print (the description-of-all-subevents of (a McDonalds-Restaurant-Visiting)))

((:set  
"The getting. The getting is before the eating the sitting. The getting is after the paying.
The paying. The paying is before the getting.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the sitting the getting. 
."
"The getting. The getting is before the eating the sitting. The getting is after the paying.
The paying. The paying is before the getting.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the getting the sitting. 
."
"The getting. The getting is before the sitting the eating. The getting is after the paying.
The paying. The paying is before the getting.
The sitting. The sitting is before the eating. The sitting is after the getting.
The eating. The eating is after the getting the sitting. 
.")
	includes
 	(the description-of-all-subevents of (a McDonalds-Restaurant-Visiting)))


;(print (the description-of-all-subevents of (a Trudys-Restaurant-Visiting)))

((:set
"The getting. The getting is before the eating. The getting is after the sitting.
The paying. The paying is after the eating.
The sitting. The sitting is before the eating the getting.
The eating. The eating is before the paying. The eating is after the getting the sitting. 
."
"The getting. The getting is before the eating. The getting is after the sitting.
The paying. The paying is after the eating.
The sitting. The sitting is before the getting the eating.
The eating. The eating is before the paying. The eating is after the sitting the getting. 
."
) includes
(the description-of-all-subevents of (a Trudys-Restaurant-Visiting)))



|#(print "retain-expr.km")

(reset-kb)

(_Car1 has (parts ((retain-expr (a Engine with (size (*big)))))))

((the number of (the parts of _Car1)) = 1)

((the number of (the parts of _Car1)) = 1)

(_Car2 has (parts ((a Engine with (color (*red))))))

(_Car1 & _Car2)

((the number of (the parts of _Car1)) = 1)


(print "save.km")

;;; Check no bombs on load/save

(reset-kb)

(a Car)

(save-kb "tmp.km")

(load-kb "tmp.km")

(fastsave-kb "tmp.fkm")

(fastload-kb "tmp.fkm")

(faslsave-kb "tmp.fkm")

(load-newest-kb "tmp.fkm")
(load-newest-kb "tmp.km")



(print "sequences.km")

;;; ======================================================================
;;;		UNIFICATION OF STRUCTURED VALUES
;;; ======================================================================

; No - now :triples are *structures*
;((:triple 1 2 3) & (:triple 1 2 (a Number)))
;((:triple 1 2 3) &? (:triple 1 2 (a Number)))
;(not ((:triple 1 2 3) &? (:triple 1 2 (a Dog))))

((:args 1 2 3) & (:args 1 2 (a Number)))
((:seq 1 2 3) & (:seq  1 2 (a Number)))

;;; This is how we do it for set values.
(((:set 1 2 3)) && ((:set  1 2 (a Number))))
;;; ie. 
((1 2 3) && (1 2 (a Number)))
;;; also valid are...
((1 2 3) && ((a Number) 1 2 4))
(((:set 1 2 3)) && ((:set (a Number) 1 2)))
((1 2 3) && ((a Number) 1 2 4))
(((:set 1 2 3)) && ((:set (a Number)  1 2 4)))

;; Test unifiability

((:args 1 2 3) &? (:args 1 2 (a Number)))
((:seq 1 2 3) &? (:seq  1 2 (a Number)))


(not ((:args 1 2 3) &? (:args 1 2 (a Dog))))
(not ((:seq 1 2 3) &? (:seq  1 2 (a Dog))))

((theN 1 of (:seq 1 2 3)) = 1)
((theN 2 of (:seq 1 2 3)) = 2)
((theN 3 of (:seq 1 2 3)) = 3)
(not (theN 4 of (:seq 1 2 3)))
((theN 1 of (:set (:seq 1 2 3) (:seq ay bee sea))) = (:set 1 ay))
((theN 2 of (:set (:seq 1 2 3) (:seq ay bee sea))) = (:set 2 bee))
((theN 3 of (:set (:seq 1 2 3) (:seq ay bee sea))) = (:set 3 sea))

;;; ----------------------------------------
;;; 	Jo Lee spotted this one
;;; ----------------------------------------

((the number of (:set t t)) = 1)	; was 2 in 1.4.0-beta15

;;; ======================================================================

(reset-kb)

;;; Not 1!
((the number of (((:seq x y)) && ((:seq x z)))) = 2)

(not ((:seq x y) &? (:seq x z)))

((:seq x) &? (:seq x z))

(every Move has
    (text ((:seq "Move" (the patient of Self) "from" (the source of
	Self) "to" (the destination of Self) ((if ((the agent of Self)) then (:seq
	"by" (the agent of Self))))))))

(PassThroughSeparator has 
        (superclasses (Move)))

(every PassThroughSeparator has
	       (text ((:seq "through" (the theme of Self)))))

(X == (a PassThroughSeparator with
	(patient ((a Patient)))
	(source ((a Source)))
	(destination ((a Destination)))
	(agent ((a Agent)))
	(theme ((a Theme)))))

;;; Don't unify the two text things!
((the number of (the text of X)) = 2)

;;; append for appending sequences

(((:seq 1 2) append (:seq 3)) = (:seq 1 2 3))
(((:seq 1 2) append 3) = (:seq 1 2 3))
(((:seq 1 2) append NIL) = (:seq 1 2))

;;; ======================================================================

(reset-kb)

;;; For linear sequence:
(every Situation has
    (subsequent-situation-sequence (
      Self
      (the subsequent-situation-sequence of 
					(the1 next-situation of Self))))
    (subsequent-event-sequence (
      (the2 next-situation of Self)
      (the subsequent-event-sequence of 
				(the1 next-situation of Self)))))

(S0 has (instance-of (Situation)) (next-situation ((:args S1 A1))))
(S1 has (instance-of (Situation)) (next-situation ((:args S2 A2))))
(S2 has (instance-of (Situation)) (next-situation ((:args S3 A3))))
(S3 has (instance-of (Situation)))

;(print (the subsequent-situation-sequence of S0))
((the subsequent-situation-sequence of S0) = (:set S0 S1 S2 S3))
;(print (the subsequent-event-sequence of S0))
((the subsequent-event-sequence of S0) = (:set A1 A2 A3))

(reset-kb)

;;; with multiple branches...
(every Situation has
    (subsequent-situation-sequences (
      (if   (the1 next-situation of Self)
       then (forall (the1 next-situation of Self)
		    (forall2 (the subsequent-situation-sequences of It)
	   	             (Self append It2)))
       else Self))))

(S0 has (instance-of (Situation)) (next-situation (S1 S2)))
(S1 has (instance-of (Situation)) (next-situation (S3)))
(S3 has (instance-of (Situation)))
(S2 has (instance-of (Situation)) (next-situation (S4)))
(S4 has (instance-of (Situation)) (next-situation (S5)))
(S5 has (instance-of (Situation)))

;(print (the subsequent-situation-sequences of S0))
((the subsequent-situation-sequences of S0) = (:set (:seq S0 S1 S3) (:seq S0 S2 S4 S5)))

(reset-done)

;;; Reconstruct possible bug:

(S4 has (instance-of (Situation)) (next-situation (S5 S6)))
(S6 has (instance-of (Situation)) (next-situation (S7)))
(S7 has (instance-of (Situation)))

;(print (the subsequent-situation-sequences of S0))
((the subsequent-situation-sequences of S0) = 
  (:set (:seq S0 S1 S3) (:seq S0 S2 S4 S5) (:seq S0 S2 S4 S6 S7)))

;;; ======================================================================
;;;		(the append of <sequence-of-sequences>)
;;; ======================================================================

(reset-kb)

;;; Test
((the append of (:seq (:seq *e1 *e2 *e3) (:seq *e4 *e5))) = (:seq *e1 *e2 *e3 *e4 *e5))

(*S1 has
    (instance-of (Sequence))
    (the-sequence ((:seq *e1 *e2 *e3))))
(*S2 has
    (instance-of (Sequence))
    (subsequence ((:seq *S2a *S2b))))
(*S2a has
    (instance-of (Sequence))
    (the-sequence ((:seq *e4 *e5))))
(*S2b has
    (instance-of (Sequence))
    (the-sequence ((:seq *e5 *e6))))
(*S3 has
    (instance-of (Sequence))
    (subsequence ((:seq *S1 *S2))))

(every Sequence has
         (basic-unit (Entity))
         (the-sequence ((the append of (the the-sequence of (the subsequence of Self))))))

;;; test
((the the-sequence of *S3) = (:seq *e1 *e2 *e3 *e4 *e5 *e5 *e6))

;;; ======================================================================
;;; Computation of sequences from physical structures.
;;; Version 1: Use the KB. Version 2 (later) use calls to Lisp.

(reset-kb)

(*MyDNA has
  (instance-of (DNA-Strand))
  (parts ((a Nuc called "n1" with
 	     (made-of (*Adenine))
	       (connected-to-in-5p-dirn (((the parts of Self) called "n2"))))
	     (a Nuc called "n2" with
	       (made-of (*Adenine))
	       (connected-to-in-5p-dirn (((the parts of Self) called "n3"))))
	     (a Nuc called "n3" with
	       (made-of (*Thymine)))))
   (the-first-nuc (((the parts of *MyDNA) called "n1"))))

;; This says the sequence of a strand = the first nucleotide followed by the 
;; sequence of a "new" strand, namely the rest of the original DNA strand .
(every DNA-Strand has
  (base-sequence (
    (if (has-value ((the the-first-nuc of Self)))
     then
      (a Sequence with
        (the-sequence (((:seq (the made-of of 			      ; 1st
				   (the the-first-nuc of Self)))
                        append   
			(the the-sequence of 		   	      ; rest
			  (the base-sequence of 
			    (a DNA-Strand with
			      (the-first-nuc ((the connected-to-in-5p-dirn of
						  (the the-first-nuc of Self)))
	))))))))))))

((the the-sequence of (the base-sequence of *MyDNA)) = 
   (:seq *Adenine *Adenine *Thymine))

;;; ------------------------------ Version 2 - use Lisp:

(reset-kb)

(*MyDNA has
  (instance-of (DNA-Strand))
  (parts ((a Nuc called "n1" with
 	     (made-of (*Adenine))
	       (connected-to-in-5p-dirn (((the parts of Self) called "n2"))))
	     (a Nuc called "n2" with
	       (made-of (*Adenine))
	       (connected-to-in-5p-dirn (((the parts of Self) called "n3"))))
	     (a Nuc called "n3" with
	       (made-of (*Thymine)))))
   (the-first-nuc (((the parts of *MyDNA) called "n1"))))

(every DNA-Strand has
  (base-sequence (
    (if (has-value (the the-first-nuc of Self))
     then (a Sequence with
	    (the-sequence (
	      #'(LAMBDA ()
;	          (EXTRACT-SEQUENCE (KM-UNIQUE0 '(the the-first-nuc of #,Self))
	          (EXTRACT-SEQUENCE (KM-UNIQUE0 '(the the-first-nuc of Self))
				    'made-of 'connected-to-in-5p-dirn)))))))))

(EVAL
 '(DEFUN EXTRACT-SEQUENCE (START PROPERTY-LINK NEXT-LINK)
   (LET ( (SEQUENCE (EXTRACT-SEQUENCE0 START PROPERTY-LINK NEXT-LINK)) )
    (COND (SEQUENCE `((:seq ,@SEQUENCE)))))))		; MAKE A KM SEQUENCE

(EVAL
 '(DEFUN EXTRACT-SEQUENCE0 (START PROPERTY-LINK NEXT-LINK)
   (COND (START 
	  (CONS (KM-UNIQUE0 `(the ,PROPERTY-LINK of ,START) 
			   :FAIL-MODE 'FAIL)
	       (EXTRACT-SEQUENCE0 (KM-UNIQUE0 `(the ,NEXT-LINK of ,START)
					     :FAIL-MODE 'FAIL)
				  PROPERTY-LINK NEXT-LINK))))))

;;; Test: 
((the the-sequence of (the base-sequence of *MyDNA)) = 
	(:seq *Adenine *Adenine *Thymine))

;;; ======================================================================
;;;	Test seqs in add and delete list...
;;; ======================================================================

(reset-kb)

(the-seq has (instance-of (Slot)) (cardinality (N-to-1)))

(every Change-Seq has
  (sequence ((a Sequence)))
  (new-sequence ())
  (del-list ((:triple (the sequence of Self) the-sequence (the the-sequence of (the sequence of Self)))))
  (add-list ((:triple (the sequence of Self) the-sequence (the new-sequence of Self)))))

(new-situation)

(*S == (a Sequence with
	 (the-sequence ((:seq x y z)))))

(do-and-next (a Change-Seq with
	(sequence (*S))
	(new-sequence ((:seq 1 2 3)))))

((the the-sequence of *S) = (:seq 1 2 3))

;;; Check (<> (:seq 1 2 3)) works...
(*T has 
  (instance-of (Sequence))
  (sequence ((<> (:seq 1 2 3)))))

(not (*T &? (a Sequence with (sequence ((:seq 1 2 3))))))

;;; ======================================================================
;;;	Check partial unification doesn't happen
;;; ======================================================================

(reset-kb)

;;; Was 1 in KM 1.4.3.7
((the number of (((:seq _X 1)) && ((:seq _Y 2)))) = 2)

(_X /= _Y)

;;; ======================================================================
;;;		EMBEDDED SEQUENCES
;;; ======================================================================

(reset-kb)

((:seq 1 2) &? NIL)
(NIL &? (:seq 1 2))
((:seq 1 2) &? (:seq _X1 _Y1))
((:seq _X2 _Y2) &? (:seq 1 2))

((:seq 1 (:set 3 4)) &? (:seq _X _Y))

(((:seq 1 (:set 3 4)) & (:seq _X _Y)) =
	(:seq 1 (:set 3 4)))

(_X = 1)
(_Y = 3)

(((:seq 1 (:set 3 4)) & (:seq _X (:set 3 5 6))) =
	(:seq 1 (:set 3 4 6 5)))

(((:seq 1 (:set 3 4)) & (:seq _X (:set 3 5 6 6 _Z))) =
(:seq 1 (:set 3 4 5 6)))

( (((:seq 1 (:set 3 4 (:pair 4 5))) & (:seq _X (:set 3 5 6 6 (:pair 4 5)))))
 = (:seq 1 (:set 3 4 (:pair 4 5) 6 5)) )

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

     ((:bag (:set 1 2 2) 3)   = (:bag 3 (:set 1 2)))
(not ((:bag (:set 1 2 2) 3 3) = (:bag 3 (:set 1 2))))

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

(reset-kb)

((:bag 1 2) &? NIL)
(NIL &? (:bag 1 2))
((:bag 1 2) &? (:bag _X1 _Y1))
((:bag _X2 _Y2) &? (:bag 1 2))
((:bag 1 (:set 3 4)) &? (:bag _X _Y))

(((:bag 1 (:set 3 4)) & (:bag _X _Y)) =
	(:bag 1 (:set 3 4)))

(_X = 1)
(_Y = 3)

(((:bag 1 (:set 3 4)) & (:bag _X (:set 3 5 6))) =
	(:bag 1 (:set 3 4 6 5)))

(((:bag 1 (:set 3 4)) & (:bag _X (:set 3 5 6 6 _Z))) =
(:bag 1 (:set 3 4 5 6)))

( (((:bag 1 (:set 3 4 (:pair 4 5))) & (:bag _X (:set 3 5 6 6 (:pair 4 5)))))
 = (:bag 1 (:set 3 4 (:pair 4 5) 6 5)) )


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

;;; This should pass successfully

(reset-kb)
(every Temperature-Value has
 (value ((constraint (   (((the1 of TheValue) isa Number) and
		          ((the2 of TheValue) isa TempScale)  )
		      or (((the1 of TheValue) isa TempValue) and
		          ((the2 of TheValue) isa Thing)  ))))))

(*cold has (instance-of (TempValue)))
(*degC has (instance-of (TempScale)))

(the value of (a Temperature-Value with (value ((:pair 5 *degC)))))
(the value of (a Temperature-Value with (value ((:pair *cold Beer)))))

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

((the elements of (:seq (:set 1 2) (:set 3 4))) = (:set 1 2 3 4))

;;; ---------------------------------------- 
;;; check sets are flattened
;;; ---------------------------------------- 

( (the1 of (:set (:seq 1 2) (:seq 3 4))) = (:set 1 3) )
( (the1 of (:seq (:seq 1 2) (:seq 3 4))) = (:seq 1 2) )
( (the1 of (:seq (:set 1 2) (:set 3 4))) = (:set 1 2) )

;;; result = ((:set 1 2) (:set 5 6)) -> which evaluates to: (1 2 5 6)
( (the1 of (:set (:seq (:set 1 2) (:set 3 4)) (:seq (:set 5 6) (:set 7 8))))
  = (:set 1 2 5 6) )

;;; result = ((:set 1 2) (:seq 5 6))  -> which evaluates to: (1 2 (:seq 5 6))
( (the1 of (:set (:seq (:set 1 2) (:set 3 4)) (:seq (:seq 5 6) (:seq 7 8))))
      = (:set 1 2 (:seq 5 6)) )

( (the2 of (:set (:seq 1 2) (:seq 3 4))) = (:set 2 4) )
( (the2 of (:seq (:seq 1 2) (:seq 3 4))) = (:seq 3 4) )
( (the2 of (:seq (:set 1 2) (:set 3 4))) = (:set 3 4) )

( (the2 of (:set (:seq (:set 1 2) (:set 3 4)) (:seq (:set 5 6) (:set 7 8))))
  = (:set 3 4 7 8) )

;;; result = ((:set 1 2) (:seq 5 6))  -> which evaluates to: (1 2 (:seq 5 6))
( (the2 of (:set (:seq (:set 1 2) (:set 3 4)) (:seq (:seq 5 6) (:seq 7 8))))
      = (:set 3 4 (:seq 7 8)) )

;;; ======================================================================
;;;	Coercion
(_X1 == (:seq 1 2))		; assign
(_X1 = (:seq 1 2))		; test assignment was coerced previously so _X1 = 1

(_X2 == (:seq 1 (1 + 1)))
(_X2 = (:seq 1 2))

((:seq 1 2) == _X3)
((:seq 1 2) = _X3)

((:seq 1 (1 + 1)) == _X4)
((:seq 1 2) = _X3)

;;; This was failing previously, (the append of...) was being coerced to (:seq (the append of ...))
((:seq (:pair 1 H) (:pair 1 C) (:pair 3 O)) &
               (the append of
                (:seq (:seq (:pair 1 H))
                 (:seq (:pair 1 C) (:pair 3 O)))))

;;; This should succeed too
((the ss of (a Car with (ss ((:seq 1 2))))) & (the ss of (a Car with (ss ((:seq 1 (1 + 1) 3))))))

(((:seq 1 2) & (must-be-a Thing)) = (:seq 1 2))
(((must-be-a Thing) & (:seq 1 2)) = (:seq 1 2))

;;; pairs
(the classes of (:pair 1 2))

;;; Failed earlier
((:seq NIL (:set *a *b)) = (:seq NIL (:set *b *a)))

;;; ========================================

((:seq 1 2) & (a Sequence))
((:pair 1 2) & (a Sequence))
((:triple 1 2 3) & (a Sequence))
((a Sequence) & (a Pair))
((:pair 1 2) & (a Pair))
((:triple 1 2 3) & (a Triple))

((:seq 1 2) &? (a Sequence))
((:pair 1 2) &? (a Sequence))
((:triple 1 2 3) &? (a Sequence))
((a Sequence) &? (a Pair))
((:pair 1 2) &? (a Pair))
((:triple 1 2 3) &? (a Triple))

(not ((:seq 1 2) &? (a Cat)))
(not ((:pair 1 2) &? (a Cat)))
(not ((:triple 1 2 3) &? (a Cat)))
(not ((a Sequence) &? (a Cat)))
(not ((:pair 1 2) &? (a Triple)))
(not ((:pair 1 2) &? (a Cat)))
(not ((:triple 1 2 3) &? (a Cat)))

( (the number of (((a Cat) (a Sequence)) && ((:seq 1 2) (a Dog)))) = 3)

((the bag2seq of (:bag 1 2 1)) = (:seq 1 2 1))
((the seq2bag of (:seq 1 2 1)) = (:bag 1 2 1))

;;; ======================================================================
#|
The below failed in 2.0.51 and before. Evaluating t2 for 

   (_Test1 has
       (t2 ((forall-seq (:seq 1 2 3) where (not t) It))))
resulted in 
   (_Test1 has
       (t2 (:seq)))
rather than
   (_Test1 has
       (t2 ((:seq))))

The bug was because (remove-sources-from-vals _Test1 t2 ((:seq))) -> (:seq) rather than ((:seq))
The below checks for this.
|#

(_Y == (a Test with (t2 ((forall-seq (:seq 1 2 3) where (not t) It)))))
(_Z == (the t2 of _Y))
(_Z = (the t2 of _Y))

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

;;; Check a null sequence doesn't produce an error
(not (forall-seq nil where t t))
(not (forall-bag nil where t t))

;;; ======================================================================

;;; Below generated an error in KM 2.2.19
(a Person)
(not ((thelast Person) &? (:pair 1 2)))

(a Pair)
((thelast Pair) &? (:pair 1 2))

(a Thing)
((thelast Thing) &? (:pair 1 2))

;;; ======================================================================

(reset-kb)

(_Car1 has 
  (parts ((:seq foo _Engine1))))

(_Car2 has 
  (parts ((:seq foo _Dog1))))

(_Dog1 has (instance-of (Dog)))
(_Engine1 has (instance-of (Engine)))

(_Car1 &! _Car2)

#|
This resulted in
ERROR! [Will continue though] Yikes! I partly unified two sequences (:seq foo _Engine1) 
and (:seq foo _Dog1) but then found they couldn't be unified!
The reason was a simple bug in unify-structured-list-vals, that the unification *test* for
:classes-subsume t should have been &+? but was &+. Fixed in 2.2.31
|#




;;; ignore  single-valued.km

(print "single-valued2.km")

(reset-kb)

(base has (cardinality (N-to-1)))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has (base (((a Wheel) & (a Dog)))))
(Fred has