;;;; Rules about the blocks world.

(defun location-rules ()
  "Define rules for determining X and Y positions."
  (Add-Rule ((Ypos ?x ?pyx (DO (Transfer ?x ?y) ?s))
	     <- 
	     (<> ?x ?y) (Height ?x ?hx) (Ypos ?y ?pyy ?s) (= ?pyx (+ ?hx ?pyy))))
  (Add-Rule ((Ypos ?a ?ypos (DO (Transfer ?x ?y) ?s))  ;Frame axiom for Y-position.
	     <-
	     (<> ?a ?x) (Ypos ?a ?ypos ?s)))
  (Add-Rule ((Xpos ?x ?xpos (DO (Transfer ?x ?y) ?s))
	     <-
	     (Xpos ?y ?xpos ?s)))
  (Add-Rule ((Xpos ?a ?xpos (DO (Transfer ?x ?y) ?s))  ;Frame axiom for X-position.
	     <-
	     (<> ?a ?x) (Xpos ?a ?xpos ?s)))
  'location-rules-added)

(defun supports-stuff ()
  "Define rules about block support."
  (Add-Rule ((On? ?x ?y (DO (Transfer ?x ?y) ?s)) 
	     <- 
	     (Achievable-State? (DO (Transfer ?x ?y) ?s)) ))

  (Add-Rule ((Clear? ?x (DO (Transfer ?x ?y) ?s))  ; After moving, still clear.
	     <-
	     (Achievable-State? (DO (Transfer ?x ?y) ?s)) ))

  (Add-Rule ((Clear? ?z (DO (Transfer ?x ?y) ?s))  ; After moving, block underneath is clear.
	     <-
	     (On? ?x ?z ?s) (Block? ?z) (<> ?z ?y) ))
  
  (Add-Rule ((On? ?a ?b (DO (Transfer ?x ?y) ?s))  ; FRAME AXIOM for ON
	     <-
	     (On? ?a ?b ?s) (<> ?a ?x) ))
  
  (Add-Rule ((Clear? ?a (DO (Transfer ?x ?y) ?s))  ; FRAME AXIOM for CLEAR
	     <-
	     (Clear? ?a ?s) (<> ?a ?x) (<> ?a ?y) ))

  'supports-stuff-added)

(defun build-misc-blocks-world-rules ()
  "Define some blocks world rules."
  (Add-Rule ((Free-Space? ?x ?s) <= (Clear? ?x ?s) (Flat-Top? ?x)))
  (Add-Rule ((Liftable? ?x ?s)   <= (Clear? ?x ?s) (Block? ?x)))
  (Add-Rule ((Flat-Top? ?x)      <= (Box? ?x)))
  (Add-Rule ((Flat-Top? ?x)      <= (Table? ?x)))
  (Add-Rule ((Block? ?x)         <= (Box? ?x)))
  (Add-Rule ((Block? ?x)         <= (Pyramid? ?x)))
  (Add-Rule ((Weight ?x ?prod)   <= (Box? ?x) (Height ?x ?h) (Width ?x ?w) (= ?prod (* ?h ?w))))
  (Add-Rule ((Weight ?x ?prod)   <= (Pyramid? ?x) (Height ?x ?h) (Width ?x ?w) (= ?intermed (* ?h ?w)) (= ?prod (* .5 ?intermed))))
  'misc-rules-added)

(defun bag-rules ()
  "Define rules about bags."
  (Add-Axiom (Add-To-Bag ?x ?bag (?x . ?bag)))
  (Add-Rule ((Add-To-Bag ?x (?y . ?bag1) (?y . ?bag2)) <= (Add-To-Bag ?x ?bag1 ?bag2)))
  (Add-Axiom (Remove-From-Bag ?x (?x . ?bag) ?bag))
  (Add-Rule ((Remove-From-Bag ?x (?y . ?bag1) (?y . ?bag2)) <= (Remove-From-Bag ?x ?bag1 ?bag2)))
     ;;; Membership rules.
  (Add-Axiom  (Member? ?x (?x . ?bag)))
  (Add-Rule ((Member? ?x (?y . ?bag)) <= (Member? ?x ?bag)))
  (Add-Axiom (Not-Member? ?x () ))
  (Add-Rule ((Not-Member? ?x (?y . ?bag)) <= (<> ?x ?y) (Not-Member? ?x ?bag)))
  
    ;;; Cardinality rules.
  (Add-Axiom (Size () 0))
  (Add-Rule ((Size (?x . ?y) ?n) <= (Size ?y ?m) (= ?n (+ ?m 1))))
  'bag-rules-added)

(defun build-transfer-rules ()
  "Define rules for block transfer."
  (clear-database)
  (clear-rulebase)
  (supports-stuff)
  (location-rules)
  ;(bag-rules)
  (setf *situation-dependent-predicates* '(Clear? On? Achievable-State? Liftable? Free-Space? Cleared? Tower? Xpos Ypos))
  (build-misc-blocks-world-rules)
  (Add-Axiom (Achievable-State? s0))
  (Add-Rule ((Achievable-State? (DO (Transfer ?x ?y) ?s))
	     <-
	     (Liftable? ?x ?s) (Free-Space? ?y ?s) (<> ?x ?y) (Achievable-State? ?s) ))
  (Add-Rule ((Tower? ?top-obj ?ymin ?ymax ?xmin ?xmax ?s)
	     <-
	     (Clear? ?top-obj ?s) 
	     (Xpos ?top-obj ?xp ?s) (>= ?xp ?xmin) (<= ?xp ?xmax) (Ypos ?top-obj ?yp ?s) (>= ?yp ?ymin) (<= ?yp ?ymax)
	     (Achievable-State? ?s) ))
  (Add-Rule ((Cleared? ?obj ?s)  ;The concept being taught must not be a zero-cost rule (to insure proper statistics gathering). 
	     <- 
	     (Clear? ?obj ?s)
             (Achievable-State? ?s) ))
  'transfer-rules-defined)

(build-transfer-rules)