;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Due to a problem I have with macros in MIT Scheme, I have to
;;; put them temporally in every domain definition file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (def-defined-predicate name parameters formula)
  `(insert-symbol-info
    ',name 'PREDICATE ,(length parameters) 'DEFINED
    (list ',parameters ',formula)))

(define-macro (def-computed-fn name parameters . body)
  `(begin
     (define (,name ,@parameters) ,@body)
     (define-computed-function ',name ,name ,(length parameters))))

(define-macro (def-computed-predicate name parameters . body)
  `(begin
     (define (,name ,@parameters) ,@body)
     (define-computed-predicate ',name ,name ,(length parameters))))

(define-macro (def-generator name parameters . body)
  `(begin
     (define (,name ,@parameters) ,@body)
     (define-computed-generator ',name ,name ,(length parameters))))

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

(clear-world-symbols)                   ;Remove old domain symbols
(clear-ops)                             ;Remove old operators

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 1. Define the described symbols.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-described-symbols
  '((object     predicate 1)
    (container  predicate 1)
    (nut        predicate 1)
    (wheel      predicate 1)
    (hub        predicate 1)
    (annoyed    predicate 0)
    (open       predicate 1)
    (closed     predicate 1)
    (unlocked   predicate 1)
    (in         predicate 2)
    (have       predicate 1)
    (tight      predicate 2)
    (on-ground  predicate 1)
    (off-ground predicate 1)
    (intact     predicate 1)
    (on         predicate 2)
    (inflated   predicate 1)
    (flat       predicate 1)
    (unfastened predicate 1)
    (free       predicate 1)
    (loose      predicate 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2. The defined predicates.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-defined-predicate on-correct (?w ?h)        ;;wheel is on correct hub
  (and (goal (on ?w ?h)) (on ?w ?h)))

(def-defined-predicate  should-be-on (?w ?h)     ;;wheel should be on hub.
  (and (goal (on ?w ?h)) (not (on ?w ?h))))

(def-defined-predicate should-be-removed (?w ?h) ;;wheel should be removed.
  (and (on ?w ?h) 
       (or (goal (have ?w)) (goal (free ?h))
	   (exists (?w2) (goal (on ?w2 ?h)) (not (= ?w ?w2)))
	   (exists (?y) (goal (in ?w ?y))))))

(def-defined-predicate need (?x)                 ;;Need item ?x.
  (or (goal (have ?x))
      (and (= ?x wrench) (need-wrench))
      (and (= ?x jack)   (need-jack))
      (and (= ?x pump)   (need-pump)) 
      (and (nut ?x)      (need-nut ?x))
      (and (wheel ?x)    (need-wheel ?x))))

(def-defined-predicate need-wrench ()
  (exists (?w) (wheel ?w) (need-wrench-for-wheel ?w)))

(def-defined-predicate need-jack ()
  (or (exists (?w) (wheel ?w) (need-jack-for-wheel ?w))
      (exists (?h) (hub ?h)   (need-jack-for-hub ?h))))

(def-defined-predicate need-pump ()
  (exists (?w) (wheel ?w)
          (and (flat ?w) (goal (inflated ?w)))))

(def-defined-predicate need-nut (?n)
  (exists (?w) (wheel ?w) (need-nut-for-wheel ?n ?w)))

(def-defined-predicate need-wrench-for-wheel (?w)
  (or
   (and (goal (unfastened ?w)) (not (unfastened ?w)))
   (exists (?h) (hub ?h) (and (should-be-removed ?w ?h) (not (unfastened ?w))))
   (exists (?n) (nut ?n)
           (or (and (goal (tight ?n ?w)) (not (tight ?n ?w)))
               (and (goal (loose ?n ?w)) (not (loose ?n ?w)))))))

(def-defined-predicate need-jack-for-wheel (?w)
  (or (and (goal (off-ground ?w)) (not (off-ground ?w)))
      (and (goal (on-ground ?w)) (not (on-ground ?w)))
      (and (goal (unfastened ?w)) (not (unfastened ?w))
	   (not (off-ground ?w)))
      (exists (?h) (hub ?h)
              (or (and (should-be-removed ?w ?h) (on-ground ?w))
                  (and (should-be-removed ?w ?h)
                       (exists (?n) (nut ?n) (tight ?n ?w))
                       (not (on-ground ?w)))
                  (and (goal (on ?w ?h)) (not (on ?w ?h)) (on-ground ?h))
                  (and (on ?w ?h) (need-jack-for-hub ?h))))
      (exists (?n) (goal (tight ?n ?w)) 
              (and (not (tight ?n ?w)) (off-ground ?w)))))

(def-defined-predicate need-jack-for-hub (?h)
  (or (and (goal (on-ground ?h)) (off-ground ?h))
      (and (goal (off-ground ?h)) (on-ground ?h))))

(def-defined-predicate need-nut-for-wheel (?n ?w)
  (or (and (goal (unfastened ?w)) (or (tight ?n ?w) (loose ?n ?w)))
      (and (goal (tight ?n ?w)) (unfastened ?w))
      (and (goal (loose ?n ?w)) (unfastened ?w))
      (exists (?h) (hub ?h) 
              (or (and (should-be-removed ?w ?h)
                       (or (tight ?n ?w) (loose ?n ?w)))
                  (and (should-be-on ?w ?h)
                       (or (goal (tight ?n ?w)) (goal (loose ?n ?w))))))))

(def-defined-predicate need-wheel (?w)
  (exists (?h) (hub ?h) (or (should-be-removed ?w ?h) (should-be-on ?w ?h))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define trivialf '(always (true)))
(define dynamicf '(always (true)))

;; Detect trivial inconsistencies in goal
(set! trivialf
    '(forall (?w) (wheel ?w) 
      (not (or
            (and (goal (off-ground ?w)) (exists (?y) (goal (in ?w ?y))))
            (exists (?n) (nut ?n)
             (or (and (goal (tight ?n ?w)) (goal (loose ?n ?w)))
                 (and (goal (tight ?n ?w)) (goal (unfastened ?w)))
                 (and (goal (loose ?n ?w)) (goal (unfastened ?w)))))
            (exists (?h) (goal (on ?w ?h)) 
             (or (exists (?y) (goal (in ?w ?y)))
                 (and (goal (off-ground ?h)) (goal (on-ground ?w)))
                 (and (goal (on-ground ?h))  (goal (off-ground ?w)))))))))

;; Detect dynamic dead-ends
(set! dynamicf 
    '(always 
      (and
       ;;
       ;; 1.
       ;;
       (forall (?x) (object ?x) 
        (and
         ;; only fetch relevant objects
         (implies (and (not (have ?x)) (not (need ?x)))
                  (next (not (have ?x))))
         ;; put objects in containers only if required and not needed.
         (forall
          (?y) (container ?y)
          (implies
           (and (not (in ?x ?y))
                (or (not (goal (in ?x ?y))) (need ?x)))
           (next (not (in ?x ?y)))))))
       ;;
       ;; 2. Wheels
       ;;
       (forall (?w) (wheel ?w)
        (and
         ;; keep wheels flat unless they should be inflated
         (implies (and (flat ?w) (not (goal (inflated ?w))))
                  (next (flat ?w)))
         ;; use jack only if required
         (implies (and (on-ground ?w) (not (need-jack-for-wheel ?w)))
                  (next (on-ground ?w)))
         ;;
         (forall (?h) (hub ?h) 
          (and 
           ;; Keep correctly placed wheels on their current hubs
           (implies (on-correct ?w ?h) (next (on ?w ?h)))
           ;; Don't undo removal steps.
           (implies
            (and (should-be-removed ?w ?h) (off-ground ?w) (unfastened ?w))
            (next (not (or (loose ?w) (on-ground ?w)))))
           ;; Don't put wheel on hub unless required
           (implies (and (not (goal (on ?w ?h))) (not (on ?w ?h)))
                    (next (not (on ?w ?h))))
           ;; keep hub off-ground until its wheel is on it and the nut
           ;; is tight
           (implies (and (should-be-on ?w ?h) (off-ground ?w) (free ?h))
                    (next (off-ground ?h)))))
         ;;
         (forall (?n) (nut ?n)
          (and 
           ;; use wrench only if required
           (implies (not (need-wrench-for-wheel ?w))
                    (and
                     (implies (tight ?n ?w)   (next (tight ?n ?w)))
                     (implies (loose ?n ?w)   (next (loose ?n ?w)))
                     (implies (unfastened ?w) (next (not (loose ?n ?w))))))
           ;; order actions for putting wheels on.
           (implies (and (unfastened ?w) (off-ground ?w) (goal (tight ?n ?w))
                         (have ?n))
                    (next (off-ground ?w)))
           ;; order actions for removing badly placed wheels
           (implies (exists (?h) (hub ?h) (should-be-removed ?w ?h))
            (and
             (implies (and (on-ground ?w) (tight ?n ?w))
                      (next (not (off-ground ?w))))
             (implies (and (on-ground ?w) (loose ?n ?w))
                      (next (not (tight ?n ?w))))
             (implies (and (off-ground ?w) (loose ?n ?w))
                      (next (not (on-ground ?w))))))))))
       ;;
       ;; 3. open only relevant containers
       ;; 
       (forall (?y) (closed ?y) 
	 (implies
          (and (not (goal (open ?y)))
               (not (exists (?x) (goal (in ?x ?y)) (not (in ?x ?y))))
               (not (exists (?x) (in ?x ?y) (need ?x))))
          (next (closed ?y))))
       ;;
       ;; 4. keep containers open alap
       ;;
       (forall (?y) (open ?y) 	
        (implies (or (not (goal (closed ?y)))
                     (exists (?x) (goal (in ?x ?y)) (not (in ?x ?y)))
                     (exists (?x) (in ?x ?y) (need ?x)))
         (next (open ?y)))))))

(set-tl-control `(and ,trivialf ,dynamicf))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 4. Operators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(add-strips-op 
 :name '(cuss)
 :pre  '((annoyed))
 :add '((relieved))
 :del '((annoyed)))
  
(add-strips-op 
 :name '(open ?x)
 :pre  '((unlocked ?x) (closed ?x))
 :add '((open ?x))
 :del '((closed ?x)))
  
(add-strips-op 
 :name '(close ?x)
 :pre  '((open ?x))
 :add '((closed ?x))
 :del '((open ?x)))
  
(add-strips-op	; fetching x from y
 :name '(fetch ?x ?y)	
 :pre  '((in ?x ?y) (open ?y))
 :add '((have ?x))
 :del '((in ?x ?y)))
  
(add-strips-op 
 :name '(loosen ?nut ?wheel) 
 :pre  '((have wrench) (tight ?nut ?wheel) 
	 (on-ground ?wheel))
 :add '((loose ?nut ?wheel))
 :del '((tight ?nut ?wheel)))
  
(add-strips-op 
 :name '(jack-up ?wheel ?hub)
 :pre  '((have jack) (on-ground ?wheel) 
	 (on-ground ?hub) (on ?wheel ?hub))
 :add '((off-ground ?wheel) (off-ground ?hub))
 :del '((on-ground ?wheel) (on-ground ?hub) 
	(have jack)))
  
;;Note this should be conditional (ADL); either we must have the wheel,
;;or it must be on the ground. Anyway, it cannot be in the boot !!!
(add-strips-op 
 :name '(inflate ?wheel)
 :pre  '((have pump) (flat ?wheel) (intact ?wheel))
 :add '((inflated ?wheel))
 :del '((flat ?wheel)))
  
(add-strips-op 
 :name '(undo ?nut ?wheel)
 :pre  '((off-ground ?wheel) (have wrench) 
	 (loose ?nut ?wheel))
 :add '((have ?nut) (unfastened ?wheel))
 :del '((loose ?nut ?wheel)))
  
(add-strips-op 
 :name '(remove-wheel ?wheel ?hub) 
 :pre  '((off-ground ?wheel) (off-ground ?hub) 
	 (on ?wheel ?hub) (unfastened ?wheel))
 :add '((have ?wheel) (free ?hub))
 :del '((off-ground ?wheel) (on ?wheel ?hub) 
	(unfastened ?wheel)))
  
(add-strips-op 
 :name '(put-on-wheel ?wheel ?hub)
 :pre  '((have ?wheel) (wheel ?wheel) (free ?hub) (off-ground ?hub))
 :add '((off-ground ?wheel) (on ?wheel ?hub) 
	(unfastened ?wheel))
 :del '((have ?wheel) (free ?hub)))
  
(add-strips-op 
 :name '(do-up ?nut ?wheel) 
 :pre '((have wrench) (off-ground ?wheel) (have ?nut) (nut ?nut)
	(unfastened ?wheel)) 
 :add '((loose ?nut ?wheel)) 
 :del '((have ?nut) (unfastened ?wheel)))

(add-strips-op 
 :name '(jack-down ?wheel ?hub)
 :pre  '((off-ground ?wheel) (off-ground ?hub) 
	 (on ?wheel ?hub))
 :add '((on-ground ?wheel) (on-ground ?hub) (have jack))
 :del '((off-ground ?wheel) (off-ground ?hub)))
  
(add-strips-op 
 :name '(tighten ?nut ?wheel)
 :pre  '((have wrench) (loose ?nut ?wheel) 
	 (on-ground ?wheel))
 :add '((tight ?nut ?wheel))
 :del '((loose ?nut ?wheel)))
  
(add-strips-op 
 :name '(put-away ?x ?y)
 :pre  '((have ?x) (open ?y))
 :add '((in ?x ?y))
 :del '((have ?x)))

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


