;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                       ;;;
;;; scheduleworld.cl
;;; The code to set up the (PRODIGY) schedule world.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Setup Symbols.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

(def-described-symbols
    '((object              predicate 1)
      (busy                predicate 1)
      (scheduled           predicate 1)
      (current-time        predicate 1)
      (temperature         predicate 2)
      (surface-condition   predicate 2)
      (shape               predicate 2)
      (painted             predicate 2)
      (has-hole            predicate 3)
      (has-bit             predicate 2)
      (can-orient          predicate 2)
      (has-paint           predicate 2)
      (polish              predicate 1)
      (roll                predicate 1)
      (lathe               predicate 1)
      (grind               predicate 1)
      (punch               predicate 3)
      (drill-press         predicate 4)
      (spray-paint         predicate 2)
      (immersion-paint     predicate 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 2. The lisp predicates and functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-lisp-fns '(+))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 3. The temporal control formula.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 
(set-tl-control
 ;;
 ;; a. Check for unachievable goal conditions, and bad initial state.
 ;;
 '(forall
   (?x) (object ?x)
   (and
    (implies (exists  (?colour) (painted ?x ?colour))
     (exists! (?colour) (painted ?x ?colour)))
    
    (implies (exists (?colour) (goal (painted ?x ?colour)))
     (and (exists! (?colour) (goal (painted ?x ?colour)))
      (forall  (?colour) (goal (painted ?x ?colour))
               (or (has-paint spray-painter ?colour)
                   (has-paint immersion-painter ?colour)
                   (always (painted ?x ?colour))))))
    
    (implies (exists (?temp) (temperature ?x ?temp))
     (exists! (?temp) (temperature ?x ?temp)))
    
    (implies (exists (?temp) (goal (temperature ?x ?temp)))
     (and (exists! (?temp) (goal (temperature ?x ?temp)))
      (forall (?temp) (goal (temperature ?x ?temp))
              (or (= ?temp hot)
                  (always (temperature ?x ?temp))))))
    
    (implies (exists (?surface) (surface-condition ?x ?surface))
     (exists! (?surface) (surface-condition ?x ?surface)))
    
    (implies (exists (?surface) (goal (surface-condition ?x ?surface)))
     (and (exists! (?surface) (goal (surface-condition ?x ?surface)))
      (forall (?surface) (goal (surface-condition ?x ?surface))
              (or (= ?surface polished)
                  (= ?surface rough)
                  (= ?surface smooth)
                  (always (surface-condition ?x ?surface))))))
    
    (implies (exists (?shape) (shape ?x ?shape))
     (exists! (?shape) (shape ?x ?shape)))
    
    (implies (exists (?shape) (goal (shape ?x ?shape)))
     (and (exists! (?shape) (goal (shape ?x ?shape)))
      (forall (?shape) (goal (shape ?x ?shape))
              (or (= ?shape cylindrical)
                  (always (shape ?x ?shape))))))
    
    (forall (?width ?orient) (goal (has-hole ?x ?width ?orient))
     (or
      (and (has-bit punch ?width) (can-orient punch ?orient))
      (and (has-bit drill-press ?width) (can-orient drill-press ?orient))
      (always (has-hole ?x ?width ?orient))))
    
    ;;
    ;; b. Never schedule an operation twice. This is not necessary in
    ;;    the schedule world.
    ;;

    (always (implies (and (polish ?x) (next (not (polish ?x))))
             (next (always (not (polish ?x))))))

    (always (implies (and (roll ?x) (next (not (roll ?x))))
             (next (always (not (roll ?x))))))

    (always (implies (and (lathe ?x) (next (not (lathe ?x))))
             (next (always (not (lathe ?x))))))

    (always (implies (and (grind ?x) (next (not (grind ?x))))
             (next (always (not (grind ?x))))))

    (forall (?width) (has-bit punch ?width)
     (forall (?orient) (can-orient punch ?orient)
      (always (implies
               (and (punch ?x ?width ?orient)
                    (next (not (punch ?x ?width ?orient))))
               (next (always (not (punch ?x ?width ?orient))))))))

    (forall (?width) (has-bit drill-press ?width)
     (forall (?orient) (can-orient drill-press ?orient)
      (always (implies
               (and (drill-press ?x ?width ?orient)
                    (next (not (drill-press ?x ?width ?orient))))
               (next (always (not (drill-press ?x ?width ?orient))))))))

    (forall (?colour) (has-paint spray-painter ?colour)
     (always (implies (and (spray-paint ?x ?colour)
                           (next (not (spray-paint ?x ?colour))))
                      (next (always (not (spray-paint ?x ?colour)))))))

    (forall (?colour) (has-paint immersion-painter ?colour)
     (always (implies (and (immersion-paint ?x ?colour)
                           (next (not (immersion-paint ?x ?colour))))
                      (next (always (not (immersion-paint ?x ?colour)))))))

    ;;
    ;; C. Don't schedule operations that don't achieve goals. If the operation
    ;; does achieve a goal then allow it to be scheduled, but not if the
    ;; condition it is to achieve already holds.
    ;;

    (if-then-else
     (goal (surface-condition ?x polished))
     (always (implies (and (surface-condition ?x polished)
                           (not (polish ?x)))
                      (next (not (polish ?x)))))
     (always (not (polish ?x))))
    
    (implies (and (goal (temperature ?x hot)) (goal (shape ?x cylindrical)))
     (always (implies (and (shape ?x cylindrical) (temperature ?x hot)
                           (not (roll ?x)))
                      (next (not (roll ?x))))))

    (implies (and (goal (temperature ?x hot) (not (goal (shape ?x cylindrical)))))
     (always (implies (and (temperature ?x hot)
                           (not (roll ?x)))
                      (next (not (roll ?x))))))

    (implies (and (not (goal (temperature ?x hot))) (goal (shape ?x cylindrical)))
     (always (implies (and (shape ?x cylindrical)
                           (not (roll ?x)))
                      (next (not (roll ?x))))))

    (implies (and (not (goal (temperature ?x hot))) (not (goal (shape ?x cylindrical))))
     (always (not (roll ?x))))


    (implies (and (goal (surface-condition ?x rough)) (goal (shape ?x cylindrical)))
     (always (implies (and (surface-condition ?x rough) (temperature ?x hot)
                           (not (lathe ?x)))
                      (next (not (lathe ?x))))))

    (implies
     (and (goal (surface-condition ?x rough)) (not (goal (shape ?x cylindrical))))
     (always (implies (and (surface-condition ?x rough)
                           (not (lathe ?x)))
                      (next (not (lathe ?x))))))

    (implies
     (and (not (goal (surface-condition ?x rough))) (goal (shape ?x cylindrical)))
     (always (implies (and (shape ?x cylindrical)
                           (not (lathe ?x)))
                      (next (not (lathe ?x))))))

    (implies
     (and (not (goal (surface-condition ?x rough))) (not (goal (shape ?x cylindrical))))
     (always (not (lathe ?x))))

    (if-then-else
     (goal (surface-condition ?x smooth))
     (always (implies (and (surface-condition ?x smooth)
                           (not (grind ?x)))
                      (next (not (grind ?x)))))
     (always (not (grind ?x))))
    
    (forall (?width) (has-bit punch ?width)
     (forall (?orient) (can-orient punch ?orient)
      (and
       (implies
        (and (goal (surface-condition ?x rough)) (goal (has-hole ?x ?width ?orient)))
        (always (implies
                 (and (surface-condition ?x rough) (has-hole ?x ?width ?orient)
                      (not (punch ?x ?width ?orient)))
                 (next (not (punch ?x ?width ?orient))))))
       (implies
        (and (goal (surface-condition ?x rough))
             (not (goal (has-hole ?x ?width ?orient))))
        (always (implies
                 (and (surface-condition ?x rough)
                      (not (punch ?x ?width ?orient)))
                 (next (not (punch ?x ?width ?orient))))))
       (implies
        (and (not (goal (surface-condition ?x rough)))
             (goal (has-hole ?x ?width ?orient)))
        (always (implies
                 (and (has-hole ?x ?width ?orient)
                      (not (punch ?x ?width ?orient)))
                 (next (not (punch ?x ?width ?orient))))))
       (implies
        (and (not (goal (surface-condition ?x rough)))
             (not (goal (has-hole ?x ?width ?orient))))
        (always (not (punch ?x ?width ?orient)))))))

    (forall (?width) (has-bit drill-press ?width)
     (forall (?orient) (can-orient drill-press ?orient)
      (if-then-else
       (goal (has-hole ?x ?width ?orient))
       (always (implies
                (and (has-hole ?x ?width ?orient)
                     (not (drill-press ?x ?width ?orient)))
                (next (not (drill-press ?x ?width ?orient)))))
       (always (not (drill-press ?x ?width ?orient))))))

    (forall (?colour) (has-paint spray-painter ?colour)
     (if-then-else
      (goal (painted ?x ?colour))
      (always (implies (and (painted ?x ?colour)
                            (not (spray-paint ?x ?colour)))
                       (next (not (spray-paint ?x ?colour)))))
      (always (not (spray-paint ?x ?colour)))))

    (forall (?colour) (has-paint immersion-painter ?colour)
     (if-then-else
      (goal (painted ?x ?colour))
      (always (implies (and (painted ?x ?colour)
                            (not (immersion-paint ?x ?colour)))
                       (next (not (immersion-paint ?x ?colour)))))
      (always (not (immersion-paint ?x ?colour)))))
    
    ;;
    ;; D. Preserve all goal achievements. An achievement is signaled by a
    ;;    transition from false to true. A rule for temperature is not
    ;;    necessary, as only "hot" can be achieved and it can never be destroyed.
    ;;
    
    (forall (?colour) (goal (painted ?x ?colour))
     (always
      (implies (and (not (painted ?x ?colour))
                    (next (painted ?x ?colour)))
               (next (always (painted ?x ?colour))))))

    (forall (?surface) (goal (surface-condition ?x ?surface))
     (always
      (implies (and (not (surface-condition ?x ?surface))
                    (next (surface-condition ?x ?surface)))
               (next (always (surface-condition ?x ?surface))))))


    (forall (?shape) (goal (shape ?x ?shape))
     (always
      (implies (and (not (shape ?x ?shape))
                    (next (shape ?x ?shape)))
               (next (always (shape ?x ?shape))))))


    (forall (?width ?orient) (goal (has-hole ?x ?width ?orient))
     (always
      (implies (and (not (has-hole ?x ?width ?orient))
                    (next (has-hole ?x ?width ?orient)))
               (next (always (has-hole ?x ?width ?orient))))))

    ;;
    ;; E. Finally, some ordering constraints on achievements.
    ;; 1. Rolling destroys a number of things that can never be
    ;;    achieved again after rolling. Prohibit roll if one of these things is
    ;;    a goal.
    ;; 2. Schedule shaping prior to surface condition and painting.
    ;; 
    ;; 3. NEW. If the object is hot, and the goal is to make the
    ;;    surface rough, then do not paint it until we obtain the
    ;;    rough surface. (Only the lathe will do it, and that destroys
    ;;    the paint).

    (implies
     (or (goal (surface-condition ?x polished))
      (exists (?width ?orient) (goal (has-hole ?x ?width ?orient)))
      (exists (?colour) (goal (painted ?x ?colour))
              (and (has-paint spray-painter ?colour)
                   (not (has-paint immersion-painter ?colour)))))
     (always (not (roll ?x))))
    
    (implies (goal (shape ?x cylindrical))
     (until
      (and (not (polish ?x)) (not (grind ?x))
           (not (exists (?colour) (spray-paint ?x ?colour)))
           (not (exists (?colour) (immersion-paint ?x ?colour))))
      (shape ?x cylindrical)))
    
    (implies (and (not (temperature ?x cold))
              (goal (surface-condition ?x rough)))
     (until
      (and (not (exists (?colour) (spray-paint ?x ?colour)))
           (not (exists (?colour) (immersion-paint ?x ?colour))))
      (surface-condition ?x rough)))

    ;;We can also get a hot temperature dynamically:

    (always
     (implies
      (and (temperature ?x cold) (next (not (temperature ?x cold))))
      (next
       (implies (goal (surface-condition ?x rough))
                (until
                 (and (not (exists (?colour) (spray-paint ?x ?colour)))
                      (not (exists (?colour) (immersion-paint ?x ?colour))))
                 (surface-condition ?x rough))))))
   
    (implies (goal (surface-condition ?x smooth))
     (until
      (and (not (exists (?colour) (spray-paint ?x ?colour)))
           (not (exists (?colour) (immersion-paint ?x ?colour))))
      (surface-condition ?x smooth)))
    
    (forall (?width ?orient) (goal (has-hole ?x ?width ?orient))
     (implies 
      (and (has-bit punch ?width) (can-orient punch ?orient)
           (or (not (has-bit drill-press ?width))
               (not (can-orient drill-press ?orient))))
      (until
       (and (not (grind ?x)) (not (polish ?x)))
       (has-hole ?x ?width ?orient))))
    
    (forall (?colour) (goal (painted ?x ?colour))
     (implies
      (and (has-paint spray-painter ?colour)
           (not (has-paint immersion-painter ?colour)))
      (until
       (and (not (grind ?x)) (not (polish ?x)))
       (painted ?x ?colour)))))))

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

(add-adl-op
 :name '(POLISH ?x ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x) (?tcur) (current-time ?tcur))
               :form     '(and (not (busy polisher)) (not (scheduled ?x))
			       (temperature ?x cold)))
 :add (adl-add
       (adl-cond :lit '(busy polisher))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(polish ?x))
       (adl-cond :lit '(surface-condition ?x polished)))
 :del (adl-del
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit '(surface-condition ?x ?oldsurface)))
 :priority 1)

(add-adl-op
 :name '(ROLL ?x ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x) (?tcur) (current-time ?tcur))
               :form     '(and (not (busy roller)) (not (scheduled ?x))))
 :add (adl-add
       (adl-cond :lit '(busy roller))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(roll ?x))
       (adl-cond :lit '(temperature ?x hot))
       (adl-cond :lit '(shape ?x cylindrical)))
 :del (adl-del
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit      '(surface-condition ?x ?oldsurface))
       (adl-cond :var-gens '((?oldpaint)
                             (painted ?x ?oldpaint))
                 :lit      '(painted ?x ?oldpaint))
       (adl-cond :var-gens '((?oldwidth ?oldorient)
                             (has-hole ?x ?oldwidth ?oldorient))
                 :lit      '(has-hole ?x ?oldwidth ?oldorient))
       (adl-cond :var-gens '((?oldshape)
                             (shape ?x ?oldshape))
                 :lit      '(shape ?x ?oldshape))
       (adl-cond :var-gens '((?oldtemp)
                             (temperature ?x ?oldtemp))
                 :lit      '(temperature ?x ?oldtemp)))
 :priority 1)

(add-adl-op
 :name '(LATHE ?x ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x) (?tcur) (current-time ?tcur))
               :form     '(and (not (busy lathe)) (not (scheduled ?x))))
 :add (adl-add
       (adl-cond :lit '(busy lathe))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(lathe ?x))
       (adl-cond :lit '(surface-condition ?x rough))
       (adl-cond :lit '(shape ?x cylindrical)))
 :del (adl-del
       (adl-cond :var-gens '((?oldshape)
                             (shape ?x ?oldshape))
                 :lit      '(shape ?x ?oldshape))
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit      '(surface-condition ?x ?oldsurface))
       (adl-cond :var-gens '((?oldpaint)
                             (painted ?x ?oldpaint))
                 :lit      '(painted ?x ?oldpaint)))
 :priority 1)

(add-adl-op
 :name '(GRIND ?x ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x) (?tcur) (current-time ?tcur))
               :form     '(and (not (busy grinder)) (not (scheduled ?x))))
 :add  (adl-add
        (adl-cond :lit '(busy grinder))
        (adl-cond :lit '(scheduled ?x))
        (adl-cond :lit '(grind ?x))
        (adl-cond :lit '(surface-condition ?x smooth)))
 :del (adl-del
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit      '(surface-condition ?x ?oldsurface))
       (adl-cond :var-gens '((?oldpaint)
                             (painted ?x ?oldpaint))
                 :lit      '(painted ?x ?oldpaint)))
 :priority 1)

(add-adl-op
 :name '(PUNCH ?x ?width ?orient ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x)
                           (?tcur) (current-time ?tcur)
                           (?width) (has-bit punch ?width)
                           (?orient) (can-orient punch ?orient))
               :form      '(and (not (busy punch)) (not (scheduled ?x))
                            (temperature ?x cold)))
 :add (adl-add
       (adl-cond :lit '(busy punch))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(punch ?x ?width ?orient))
       (adl-cond :lit '(has-hole ?x ?width ?orient))
       (adl-cond :lit '(surface-condition ?x rough)))
 :del (adl-del
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit      '(surface-condition ?x ?oldsurface)))
 :priority 1)

(add-adl-op
 :name '(DRILL-PRESS ?x ?width ?orient ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x)
                           (?tcur) (current-time ?tcur)
                           (?width) (has-bit drill-press ?width)
                           (?orient) (can-orient drill-press ?orient))
               :form     '(and (not (busy drill-press))
                           (not (scheduled ?x)) (temperature ?x cold)))
 :add (adl-add
       (adl-cond :lit '(busy drill-press))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(drill-press ?x ?width ?orient))
       (adl-cond :lit '(has-hole ?x ?width ?orient)))
 :priority 1)

(add-adl-op
 :name '(SPRAY-PAINT ?x ?colour ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x)
                           (?tcur) (current-time ?tcur)
                           (?colour) (has-paint spray-painter ?colour))
               :form     '(and (not (busy spray-paint))
			       (not (scheduled ?x)) (temperature ?x cold)))
 :add (adl-add
       (adl-cond :lit '(busy spray-paint))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(spray-paint ?x ?colour))
       (adl-cond :lit '(painted ?x ?colour)))
 :del (adl-del
       (adl-cond :var-gens '((?oldsurface)
                             (surface-condition ?x ?oldsurface))
                 :lit      '(surface-condition ?x ?oldsurface))
       (adl-cond :var-gens '((?oldpaint)
                             (painted ?x ?oldpaint))
                 :lit      '(painted ?x ?oldpaint)))
 :priority 1)

(add-adl-op
 :name '(IMMERSION-PAINT ?x ?colour ?tcur)
 :pre (adl-pre :var-gens '((?x) (object ?x)
                           (?tcur) (current-time ?tcur)
                           (?colour) (has-paint immersion-painter ?colour))
               :form     '(and (not (busy immersion-paint))
			       (not (scheduled ?x))))
 :add (adl-add
       (adl-cond :lit '(busy immersion-paint))
       (adl-cond :lit '(scheduled ?x))
       (adl-cond :lit '(immersion-paint ?x ?colour))
       (adl-cond :lit '(painted ?x ?colour)))
 :del (adl-del
       (adl-cond :var-gens '((?oldpaint)
                             (painted ?x ?oldpaint))
                 :lit      '(painted ?x ?oldpaint)))
 :priority 1)

(add-adl-op
 :name '(time-step ?tcur)
  :pre  (adl-pre :var-gens '((?tcur) (current-time ?tcur))
                :form     '(exists (?x) (scheduled ?x)))
 :add  (adl-add (adl-cond :lit      '(current-time (+ 1 ?tcur))))
 :del  (adl-del (adl-cond :var-gens '((?x) (scheduled ?x))
                          :lit      '(scheduled ?x))
                (adl-cond :var-gens '((?m) (busy ?m))
                          :lit      '(busy ?m))
                (adl-cond :var-gens '((?x) (polish ?x))
                          :lit      '(polish ?x))
                (adl-cond :var-gens '((?x) (roll ?x))
                          :lit      '(roll ?x))
                (adl-cond :var-gens '((?x) (lathe ?x))
                          :lit      '(lathe ?x))
                (adl-cond :var-gens '((?x) (grind ?x))
                          :lit      '(grind ?x))
                (adl-cond :var-gens '((?x ?width ?orient) (punch ?x ?width ?orient))
                          :lit      '(punch ?x ?width ?orient))
                (adl-cond :var-gens '((?x ?width ?orient)
                                      (drill-press ?x ?width ?orient))
                          :lit      '(drill-press ?x ?width ?orient))
                (adl-cond :var-gens '((?x ?colour) (spray-paint ?x ?colour))
                          :lit      '(spray-paint ?x ?colour))
                (adl-cond :var-gens '((?x ?colour) (immersion-paint ?x ?colour))
                          :lit      '(immersion-paint ?x ?colour))
                (adl-cond :lit      '(current-time ?tcur)))
 :priority 0)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 5. Pretty print the world state. Not implemented yet.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set-print-world-fn 
 (lambda (world/action . args)
   (let ((stream #t))
     (if (not (null? args)) (set! stream (car args)))
     (format stream "~%~S"
	     (remove-if (lambda (lit)
			  (let ((op (get-operator lit)))
			    (or (eq? op 'has-paint)
				(eq? op 'can-orient)
				(eq? op 'has-bit)
				(eq? op 'object))))
			(list-world (world/action-world world/action)))))))

