(use-package 'plan-utils)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  This file contains a set of test problems.  Some of them work,
;;;  and others are intractable for snlp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun blocks-world-domain ()
  ;; purge old domain prior to defining a new domain
  (reset-domain)

  ;; Define step for putting a block on the table.  
  (defstep :action '(newtower ?x) 
    :precond '((on ?X ?Z) (clear ?X)) 
    :add '((on ?X Table) (clear ?Z)) :dele'((on ?X ?Z)) 
    :equals '((not (?X ?Z)) (not (?X Table)) (not (?Z Table))))

  ;; Define step for placing one block on another.
  (defstep :action '(puton ?X ?Y)
    :precond '((on ?X ?Z) (clear ?X) (clear ?Y))
    :add   '((on ?X ?Y) (clear ?Z))
    :dele  '((on ?X ?Z) (clear ?Y))
    :equals '((not (?X ?Y)) (not (?X ?Z)) (not (?Y ?Z))
	      (not (?X Table)) (not (?Y Table)))))

;;; <cl> (sussman-anomaly)
;;; 
;;; Initial  : ((ON C A) (ON A TABLE) (ON B TABLE) (CLEAR C) (CLEAR B))
;;; 
;;; Step 1   : (NEWTOWER C)      Created 2
;;; Step 2   : (PUTON B C)       Created 3
;;; Step 3   : (PUTON A B)       Created 1
;;; 
;;; Goal     : ((ON A B) (ON B C))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 5  ; Goals = 2 ) => Win  (3 steps)     CPU 983
;;;      Nodes (V = 28  ; Q = 30  ; C = 87  )             Branch 2.0714285
;;;      Working Unifies: 342                             Bindings added: 211
;;; 

(defun sussman-anomaly ()
  (blocks-world-domain)
  (snlp:plan '((on C A) (on A Table) (on B Table) (clear C) (clear B))
	     '((on A B) (on B C))
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; traveling domain

(defun road-operators ()
  (reset-domain)
  (defstep :action '(drive ?vehicle ?location1 ?location2)
    :precond '((at ?vehicle ?location1) (road ?location1 ?location2))
    :dele '((at ?vehicle ?location1))
    :add '((at ?vehicle ?location2)))
  (defstep :action '(cross ?vehicle ?location1 ?location2)
    :precond '((at ?vehicle ?location1) (bridge ?location1 ?location2))
    :dele '((at ?vehicle ?location1))
    :add '((at ?vehicle ?location2))))

(defvar *roads* nil)

(defun add-road (a b)
  (push `(road ,a ,b) *roads*)
  (push `(road ,b ,a) *roads*))

(defun add-bridge (a b)
  (push `(bridge ,a ,b) *roads*)
  (push `(bridge ,b ,a) *roads*))

(defun road-map () *roads*)

(defun find-path (starting-location goal)
  (snlp:plan `(,@(road-map) ,@starting-location)
	     goal
             :rank-fun #'snlp::rank3))

;;; 
;;; <cl> (road-test)
;;; cpu time (non-gc) 417 msec user, 17 msec system
;;; cpu time (gc)     0 msec user, 0 msec system
;;; cpu time (total)  417 msec user, 17 msec system
;;; real time  426 msec
;;; 
;;; 
;;; 
;;; Initial  : ((ROAD G D) (ROAD D G) (BRIDGE D A) (BRIDGE A D) (AT JACK A) (AT MARK A))
;;; 
;;; Step 1   : (CROSS MARK A D)   Created 4
;;; Step 2   : (CROSS JACK A D)   Created 2
;;; Step 3   : (DRIVE MARK D G)   Created 3
;;; Step 4   : (DRIVE JACK D G)   Created 1
;;; 
;;; Goal     : ((AT JACK G) (AT MARK G))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 6  ; Goals = 2 ) => Win  (4 steps)     CPU 383
;;;      Nodes (V = 22  ; Q = 8   ; C = 53  )             Branch 1.3636364
;;;      Working Unifies: 210                             Bindings added: 48
;;; 


(defun road-test ()
  (road-operators)
  (setf *roads* nil)
  (add-bridge 'a 'd)
  (add-road 'd 'g)
  (time (find-path '((at jack a) (at mark a))
                   '((at jack g) (at mark g)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tower of hanoi

(defun init (numdisks)
  (let* ((disks (subseq '(d1 d2 d3 d4 d5 d6 d7 d8 d9) 0 numdisks))
         (sizes (nconc (mapcar #'(lambda (d) `(smaller ,d p1)) disks)
                       (mapcar #'(lambda (d) `(smaller ,d p2)) disks)
                       (mapcar #'(lambda (d) `(smaller ,d p3)) disks)
                       (mapcon
                        #'(lambda (d)
                            (mapcar #'(lambda (d2)
                                        `(smaller ,(car d) ,d2))
                                    (cdr d)))
                        disks)))
         (initial (append '((clear p1)(clear p2)(clear d1))
                          (maplist
                           #'(lambda (d)
                               (if (cdr d)
                                   `(on ,(car d) ,(cadr d))
                                   `(on ,(car d) p3)))
                           disks))))
    (nconc sizes initial)))

(defun goal (numdisks)
  (let* ((disks (subseq '(d1 d2 d3 d4 d5 d6 d7 d8 d9) 0 numdisks)))
    (maplist #'(lambda (d)
                  (if (cdr d)
                      `(on ,(car d) ,(cadr d))
                      `(on ,(car d) p1)))
              disks)))

;;; 
;;; <cl> (hanoi 2)
;;; 
;;; Initial  : ((SMALLER D1 P1) (SMALLER D2 P1) (SMALLER D1 P2) (SMALLER D2 P2) (SMALLER D1 P3) (SMALLER D2 P3) (SMALLER D1 D2) (CLEAR P1) (CLEAR P2) (CLEAR D1) ...)
;;; 
;;; Step 1   : (MOVE-DISK D1 D2 P2)   Created 2
;;; Step 2   : (MOVE-DISK D2 P3 P1)   Created 3
;;; Step 3   : (MOVE-DISK D1 P2 D2)   Created 1
;;; 
;;; Goal     : ((ON D1 D2) (ON D2 P1))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 12 ; Goals = 2 ) => Win  (3 steps)     CPU 733
;;;      Nodes (V = 45  ; Q = 25  ; C = 115 )             Branch 1.5555556
;;;      Working Unifies: 470                             Bindings added: 145
;;; 

(defun hanoi (n)
  (reset-domain)
  (defstep :action '(move-disk ?disk ?below-disk ?new-below-disk)
    :precond '((on ?disk ?below-disk)
               (clear ?disk)
               (clear ?new-below-disk)
               (smaller ?disk ?new-below-disk)  ;handles pegs!
               )
    :add '((clear ?below-disk)
           (on ?disk ?new-below-disk))
    :dele '((on ?disk ?below-disk)
            (clear ?new-below-disk))
    :equals '((not (?new-below-disk ?below-disk))
              (not (?new-below-disk ?disk))
              (not (?below-disk ?disk))
              ))
  (snlp:plan (init n) (goal n)
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Sched world

(defun sched-world-init (time i-state &aux (ret nil))
  (setf ret i-state)
  (dotimes (i time)
    (dolist (machine '(polisher roller lathe grinder punch drill-press
                       spray-painter immersion-painter))
      (push `(idle ,machine ,i) ret)))
  (dolist (size '(.1 .2 .3))
    (push `(has-bit ,size) ret))
  (dolist (color '(red black))
    (push `(have-paint-for-immersion ,color) ret)
    (push `(sprayable ,color) ret))
  (dotimes (i time)
    (dotimes (j i)
      (push `(later ,i ,j) ret)))
  ret)

(defun sched-world-domain ()
  ;; purge old domain prior to defining a new domain
  (reset-domain)

  (defstep :action                     '(POLISH ?x ?t)
    :precond '((temperature ?x cold)
               (last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle polisher ?t)
               (surface-condition ?x ?oldsurf))
    :add '((surface-condition ?x polished)
           (last-scheduled ?x ?t)
           (scheduled ?x polisher ?t))
    :dele '((surface-condition ?x ?oldsurf)
            (idle polisher ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(ROLL ?x ?t)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle roller ?t)
               (shape ?x ?oldshape)
               (temperature ?x ?oldtemp)
               (surface-condition ?x ?oldsurf)
               (painted ?x oldpaint)
               (has-hole ?x ?oldwidth ?old-orient))
    :add '((temperature ?x hot)
           (shape ?x cylindrical)
           (last-scheduled ?x ?t)
           (scheduled ?x roller ?t))
    :dele '((shape ?x ?oldshape)
            (temperature ?x ?oldtemp)
            (surface-condition ?x ?oldsurf)
            (painted ?x oldpaint)
            (has-hole ?x ?oldwidth ?old-orient)
            (idle roller ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(LATHE ?x ?t)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle lathe ?t)
               (surface-condition ?x ?oldsurf)
               (painted ?x ?oldpaint)
               (shape ?x ?oldshape))
    :add '((surface-condition ?x rough)
           (shape ?x cylindrical)
           (painted ?x nil)
           (last-scheduled ?x ?t)
           (scheduled ?x lathe ?t))
    :dele '((shape ?x ?oldshape)
            (surface-condition ?x ?oldsurf)
            (painted ?x ?oldpaint)
            (idle lathe ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(GRIND ?x ?t)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle grinder ?t)
               (surface-condition ?x ?oldsurf)
               (painted ?x ?oldpaint))
    :add '((surface-condition ?x smooth)
           (painted ?x nil)
           (last-scheduled ?x ?t)
           (scheduled ?x grinder ?t))
    :dele '((surface-condition ?x ?oldsurf)
            (painted ?x ?oldpaint)
            (idle grinder ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(PUNCH ?x ?t ?width ?orient)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle punch ?t)
               (temperature ?x cold)
               (surface-condition ?x ?oldsurf))
    :add '((has-hole ?x ?width ?orient)
           (surface-condition ?x rough)
           (last-scheduled ?x ?t)
           (scheduled ?x punch ?t))
    :dele '((surface-condition ?x ?oldsurf)
            (idle grinder ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(DRILL-PRESS ?x ?t ?width ?orient)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle drill-press ?t)
               (temperature ?x cold)
               (have-bit ?width))
    :add '((has-hole ?x ?width ?orient)
           (last-scheduled ?x ?t)
           (scheduled ?x drill-press ?t))
    :dele '((idle drill-press ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(SPRAY-PAINT ?x ?t ?paint)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle spray-painter ?t)
               (temperature ?x cold)
               (sprayable ?paint)
               (surface-condition ?x ?oldsurf))
    :add '((painted ?x ?paint)
           (last-scheduled ?x ?t)
           (scheduled ?x spray-painter ?t))
    :dele '((surface-condition ?x ?oldsurf)
            (idle spray-painter ?t)
            (last-scheduled ?x ?prev)))
  (defstep :action                     '(IMMERSION-PAINT ?x ?t ?paint)
    :precond '((last-scheduled ?x ?prev)
               (later ?t ?prev)
               (idle immersion-painter ?t)
               (have-paint-for-immersion ?paint))
    :add '((painted ?x ?paint)
           (last-scheduled ?x ?t)
           (scheduled ?x immersion-painter ?t))
    :dele '((idle immersion-painter ?t)
            (last-scheduled ?x ?prev))))

;;; 
;;; <cl> (sched-test1)
;;; 
;;; Initial  : ((LATER 4 3) (LATER 4 2) (LATER 4 1) (LATER 4 0) (LATER 3 2) (LATER 3 1) (LATER 3 0) (LATER 2 1) (LATER 2 0) (LATER 1 0) ...)
;;; 
;;; Step 1   : (POLISH OBJ-B 1)   Created 2
;;; Step 2   : (LATHE OBJ-A 1)   Created 1
;;; 
;;; Goal     : ((SHAPE OBJ-A CYLINDRICAL) (SURFACE-CONDITION OBJ-B POLISHED))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 69 ; Goals = 2 ) => Win  (2 steps)     CPU 2583
;;;      Nodes (V = 30  ; Q = 109 ; C = 170 )             Branch 4.633333
;;;      Working Unifies: 1177                            Bindings added: 235
;;; 

(defun sched-test1 ()
  (sched-world-domain)
  (snlp:plan (sched-world-init 5 '((shape obj-A oblong)
				   (temperature obj-A cold)
				   (surface-condition obj-A rough)
				   (painted obj-A none)
				   (has-hole obj-A 0 nil)
				   (last-scheduled obj-A 0)

				   (shape obj-B cylindrical)
				   (temperature obj-B cold)
				   (surface-condition obj-B smooth)
				   (painted obj-B red)
				   (has-hole obj-B 0 nil)
				   (last-scheduled obj-B 0)))
	     '((shape Obj-A cylindrical)
	       (surface-condition Obj-B polished))
             :rank-fun #'snlp::rank3))

;;; 
;;; <cl> (sched-test2)
;;; 
;;; Initial  : ((LATER 4 3) (LATER 4 2) (LATER 4 1) (LATER 4 0) (LATER 3 2) (LATER 3 1) (LATER 3 0) (LATER 2 1) (LATER 2 0) (LATER 1 0) ...)
;;; 
;;; Step 1   : (IMMERSION-PAINT OBJ-A 0 BLACK)   Created 4
;;; Step 2   : (IMMERSION-PAINT OBJ-A 1 BLACK)   Created 3
;;; Step 3   : (IMMERSION-PAINT OBJ-A 2 RED)   Created 2
;;; Step 4   : (LATHE OBJ-A 3)   Created 1
;;; 
;;; Goal     : ((SHAPE OBJ-A CYLINDRICAL) (SURFACE-CONDITION OBJ-A SMOOTH) (SURFACE-CONDITION OBJ-B POLISHED))
;;; Unsafe   : NIL
;;; Open     : (((LATER 0 ?PREV4) 4) ((LAST-SCHEDULED OBJ-A ?PREV4) 4) ((SURFACE-CONDITION OBJ-A SMOOTH) GOAL) ((SURFACE-CONDITION OBJ-B POLISHED) GOAL))
;;; 
;;; 
;;; POCL (Init = 75 ; Goals = 3 ) => Lose (4 steps)     CPU 24850
;;;      Nodes (V = 397 ; Q = 404 ; C = 1199)             Branch 2.0176322
;;;      Working Unifies: 10084                           Bindings added: 1112
;;; 

(defun sched-test2 ()
  (sched-world-domain)
  (snlp:plan (sched-world-init 5 '((shape obj-A rectangular)
				   (temperature obj-A cold)
				   (surface-condition obj-A rough)
				   (painted obj-A blue)
				   (has-hole obj-A .2 front)
				   (last-scheduled obj-A 0)

				   (shape obj-B flat)
				   (temperature obj-B cold)
				   (surface-condition obj-B polished)
				   (painted obj-B nil)
				   (has-hole obj-B 0 nil)
				   (last-scheduled obj-B 0)

				   (shape obj-C oblong)
				   (temperature obj-C cold)
				   (surface-condition obj-C rough)
				   (painted obj-C nil)
				   (has-hole obj-C 0 nil)
				   (last-scheduled obj-C 0)))
	      '((shape Obj-A cylindrical)
		(surface-condition Obj-A smooth)
		(surface-condition Obj-B polished))
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ferry domain

(defun ferry-domain ()
  (reset-domain)
  (defstep :action '(board ?x)
    :precond '((at ?x ?y)(at-ferry ?y)(empty-ferry))
    :add '((on ?x ferry))
    :dele '((at ?x ?y) (empty-ferry)))
  (defstep :action '(sail-b)
    :precond '((at-ferry a))
    :add '((at-ferry b))
    :dele '((at-ferry a)))
  (defstep :action '(sail-a)
    :precond '((at-ferry b))
    :add '((at-ferry a))
    :dele '((at-ferry b)))
;  (defstep :action '(sail ?y ?x)    ; gives snlp problems!
;    :precond '((at-ferry ?x))
;    :add '((at-ferry ?y))
;    :dele '((at-ferry ?x))
;    :equals '((not (?x ?y))))
  (defstep :action '(debark ?x)
    :precond '((on ?x ferry) (at-ferry ?y))
    :add '((at ?x ?y) (empty-ferry))
    :dele '((on ?x ferry))))

;;; 
;;; <cl> (test-ferry)
;;; 
;;; Initial  : ((AT C1 A) (AT C2 A) (AT-FERRY A) (EMPTY-FERRY))
;;; 
;;; Step 1   : (BOARD C1)        Created 3
;;; Step 2   : (SAIL-B)          Created 2
;;; Step 3   : (DEBARK C1)       Created 1
;;; Step 4   : (SAIL-A)          Created 6
;;; Step 5   : (BOARD C2)        Created 7
;;; Step 6   : (SAIL-B)          Created 5
;;; Step 7   : (DEBARK C2)       Created 4
;;; 
;;; Goal     : ((AT C1 B) (AT C2 B))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 4  ; Goals = 2 ) => Win  (7 steps)     CPU 2384
;;;      Nodes (V = 190 ; Q = 83  ; C = 461 )             Branch 1.4368421
;;;      Working Unifies: 1345                            Bindings added: 160
;;; 

(defun test-ferry ()
  (ferry-domain)
  (snlp:plan '((at c1 a)(at c2 a)(at-ferry a)
	       (empty-ferry))
	     '((at c1 b)(at c2 b))
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; molgen domain

(defun molgen-domain ()
  (reset-domain)
  
  ;; steps for building DNA molecules from mRNA
  (defstep :action '(reverse-transcribe ?x)
    :precond '((mRNA ?x))
    :add '((cDNA ?x) (connected-cDNA-mRNA ?x))
    :dele nil)
  (defstep :action '(separate ?x)    
    :precond '((cDNA ?x)(connected-cDNA-mRNA ?x))
    :add '((single-strand ?x))
    :dele '((connected-cDNA-mRNA ?x)))
  (defstep :action '(polymerize ?x)  
    :precond '((cDNA ?x)(single-strand ?x))
    :add '((hair-pin ?x))
    :dele '((single-strand ?x)))
  (defstep :action '(digest ?x)  
    :precond '((cDNA ?x)(hair-pin ?x))
    :add '((double-strand ?x))
    :dele '((hair-pin ?x)))
  
  ;; steps for splicing DNA molecules
  (defstep :action '(ligate LINKER ?y) ; prep a "strand" for end cleaving
    :precond '((cDNA ?y) (double-strand ?y))
    :add '((cleavable ?y))
    :dele nil)
  (defstep :action '(ligate ?x ?y)     ; splice 2 cleaved molecules
    :precond '((cleaved ?x)
               (cleaved ?y))
    :add '((contains ?x ?y)(cleavable ?y))
    :dele '((cleaved ?x) (cleaved ?y))
    :equals '((not (?x ?y))))
  (defstep :action '(cleave ?x)        ; cleave a "loop" molecule
    :precond '((cleavable ?x))
    :add '((cleaved ?x))
    :dele '((cleavable ?x)))
  
  ;; Step for inserting a molecule into an organism
  (defstep :action '(transform ?x ?y)
    :precond '((accepts ?x ?y) ; Is molecule accepted?
               (bacterium ?y)  ; must be a bacterium
               (cleavable ?x)) ; molecule must be whole
    :add '((contains ?x ?y))
    :dele '((cleavable ?x))    ; cannot cleave ?x when in cell
    :equals '((not (?x ?y))))
  
  ;; purify a culture with an antibiotic
  (defstep :action '(screen ?x ?z)
    :precond '((contains ?y ?x)
               (resists ?z ?y))
    :add '((pure ?x))
    :dele nil
    :equals '((not (?x ?y))(not (?y ?z))(not (?x ?z)))))

;;; 
;;; <cl> (molgen-test)
;;; 
;;; Initial  : ((MRNA INSULIN-GENE) (CLEAVABLE E-COLI-EXOSOME) (CLEAVABLE JUNK-EXOSOME) (ACCEPTS JUNK-EXOSOME JUNK) (ACCEPTS E-COLI-EXOSOME E-COLI) (BACTERIUM E-COLI) (BACTERIUM JUNK) (RESISTS ANTIBIOTIC-1 E-COLI-EXOSOME))
;;; 
;;; Step 1   : (CLEAVE E-COLI-EXOSOME)   Created 2
;;; Step 2   : (REVERSE-TRANSCRIBE INSULIN-GENE)   Created 8
;;; Step 3   : (SEPARATE INSULIN-GENE)   Created 7
;;; Step 4   : (POLYMERIZE INSULIN-GENE)   Created 6
;;; Step 5   : (DIGEST INSULIN-GENE)   Created 5
;;; Step 6   : (LIGATE LINKER INSULIN-GENE)   Created 4
;;; Step 7   : (CLEAVE INSULIN-GENE)   Created 3
;;; Step 8   : (LIGATE INSULIN-GENE E-COLI-EXOSOME)   Created 1
;;; Step 9   : (TRANSFORM E-COLI-EXOSOME E-COLI)   Created 9
;;; Step 10  : (SCREEN E-COLI ANTIBIOTIC-1)   Created 10
;;; 
;;; Goal     : ((CONTAINS INSULIN-GENE ?X) (CONTAINS ?X ?Y) (BACTERIUM ?Y) (PURE ?Y))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 8  ; Goals = 4 ) => Win  (10 steps)     CPU 8850
;;;      Nodes (V = 282 ; Q = 109 ; C = 668 )             Branch 1.3865248
;;;      Working Unifies: 1336                            Bindings added: 376
;;; 

(defun molgen-test () 
  (molgen-domain) 
  (snlp:plan '((mRNA insulin-gene)
	       (cleavable e-coli-exosome) 
	       (cleavable junk-exosome) 
	       (accepts junk-exosome junk) 
	       (accepts e-coli-exosome e-coli) 
	       (bacterium e-coli)
	       (bacterium junk) 
	       (resists antibiotic-1 e-coli-exosome))
	     '((contains insulin-gene ?x)
	       (contains ?x ?y)
	       (bacterium ?y)
	       (pure ?y))
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; robot domain (from Hank Wan [hsw@cs.cmu.edu])
(defun robot-domain ()
  (reset-domain)

  (defstep
   :action '(pickup ?x)
   :precond '((at ?x ?loc) (at robot ?loc) (empty-handed))
   :add '((grasping robot ?x))
   :dele '((empty-handed))
   :equals '((not (?x robot))))
  
  (defstep
   :action '(drop ?x)
   :precond '((grasping robot ?x))
   :add '((empty-handed))
   :dele '((grasping robot ?x))
   :equals '((not (?x robot))))

  (defstep
   :action '(empty-handed-move ?from ?to)
   :precond '((connected ?from ?to) (at robot ?from) (empty-handed))
   :add '((at robot ?to))
   :dele '((at robot ?from)))

  (defstep
   :action '(loaded-move ?from ?to)
   :precond '((connected ?from ?to) (at robot ?from) (grasping robot ?x))
   :add '((at ?x ?to)
	  (at robot ?to))
   :dele '((at robot ?from)
	   (at ?x ?from))
   :equals '((not (?x robot)))))

;;; 
;;; <cl> (r-test1)
;;; 
;;; Initial  : ((CONNECTED RM1 RM2) (CONNECTED RM2 RM1) (AT BOX1 RM2) (AT BOX2 RM2) (EMPTY-HANDED) (AT ROBOT RM1))
;;; 
;;; Step 1   : (EMPTY-HANDED-MOVE ?FROM7 ?FROM6)   Created 7
;;; Step 2   : (EMPTY-HANDED-MOVE ?FROM6 ?FROM5)   Created 6
;;; Step 3   : (EMPTY-HANDED-MOVE ?FROM5 ?FROM4)   Created 5
;;; Step 4   : (EMPTY-HANDED-MOVE RM1 RM2)   Created 3
;;; Step 5   : (PICKUP BOX1)     Created 2
;;; Step 6   : (LOADED-MOVE ?FROM4 ?FROM1)   Created 4
;;; Step 7   : (LOADED-MOVE ?FROM1 RM1)   Created 1
;;; 
;;; Goal     : ((AT BOX1 RM1) (AT BOX2 RM1))
;;; Unsafe   : NIL
;;; Open     : (((AT ROBOT ?FROM7) 7) ((CONNECTED ?FROM7 ?FROM6) 7) ((CONNECTED ?FROM6 ?FROM5) 6) ((CONNECTED ?FROM5 ?FROM4) 5) ((CONNECTED ?FROM4 ?FROM1) 4) ((CONNECTED ?FROM1 RM1) 1) ((AT BOX2 RM1) GOAL))
;;; 
;;; 
;;; POCL (Init = 6  ; Goals = 2 ) => Lose (7 steps)     CPU 8984
;;;      Nodes (V = 667 ; Q = 134 ; C = 1269)             Branch 1.2008996
;;;      Working Unifies: 3782                            Bindings added: 541
;;; 

(defun r-test1 ()
  (robot-domain)
  (snlp:plan '((connected rm1 rm2)
	       (connected rm2 rm1)
	       (at box1 rm2) (at box2 rm2)
	       (empty-handed) (at robot rm1))
	     '((at box1 rm1) (at box2 rm1))
             :rank-fun #'snlp::rank3))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Monkey domain (from prodigy)

(defun monkey-domain ()
  (reset-domain)
  
  ;; movement and clinbing
  (defstep :action '(GO-TO ?x)
    :precond '((on-floor)(at monkey ?y))
    :add '((at monkey ?x))
    :dele '((at monkey ?y)))
  (defstep :action '(CLIMB)
    :precond '((at box ?x)
	       (at monkey ?x))
    :add '((onbox ?x))
    :dele '((on-floor)))
  (defstep :action '(PUSH-BOX ?y ?x)
    :precond '((at box ?y)
	       (at monkey ?y)
	       (on-floor))
    :add '((at monkey ?x)
	   (at box ?x))
    :dele '((at box ?y)
	    (at monkey ?y)))

  ;; getting bananas
  (defstep :action '(GET-KNIFE)
    :precond '((at knife ?y)
	       (at monkey ?y))
    :add '((hasknife))
    :dele '((at knife ?y)))
  (defstep :action '(GRAB-BANANAS)
    :precond '((hasknife)
	       (at bananas ?y)
	       (onbox ?y))
    :add '((hasbananas)))
  
  ;; getting water
  (defstep :action '(PICKGLASS ?y)
    :precond '((at glass ?y)
	       (at monkey ?y))
    :add '((hasglass))
    :dele '((at glass ?y)))
  (defstep :action '(GETWATER ?y)
    :precond '((hasglass)
	       (at waterfountain ?y)
	       (at monkey ?y)
	       (onbox ?y))
    :add '((haswater))))

;;; 
;;; <cl> (monkey-test1)
;;; 
;;; Initial  : ((AT MONKEY P1) (ON-FLOOR) (AT BOX P2) (AT BANANAS P3) (AT KNIFE P4))
;;; 
;;; Step 1   : (GO-TO P4)        Created 5
;;; Step 2   : (GET-KNIFE)       Created 6
;;; Step 3   : (GO-TO P2)        Created 4
;;; Step 4   : (PUSH-BOX P2 P3)   Created 3
;;; Step 5   : (CLIMB)           Created 2
;;; Step 6   : (GRAB-BANANAS)    Created 1
;;; 
;;; Goal     : ((HASBANANAS))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 5  ; Goals = 1 ) => Win  (6 steps)     CPU 1450
;;;      Nodes (V = 73  ; Q = 23  ; C = 165 )             Branch 1.3150685
;;;      Working Unifies: 877                             Bindings added: 60
;;; 

(defun monkey-test1 ()			; just getting bananas
  (monkey-domain)
  (snlp:plan '((at monkey p1)
	       (on-floor)
	       (at box p2)
	       (at bananas p3)
	       (at knife p4))
	     '((hasbananas))
             :rank-fun #'snlp::rank3))

;;; 
;;; <cl> (monkey-test2)
;;; 
;;; Initial  : ((AT MONKEY P1) (ON-FLOOR) (AT BOX P2) (AT BANANAS P3) (AT KNIFE P4) (AT WATERFOUNTAIN P3) (AT GLASS P6))
;;; 
;;; Step 1   : (GO-TO P2)        Created 6
;;; Step 2   : (PUSH-BOX P2 P4)   Created 5
;;; Step 3   : (GET-KNIFE)       Created 7
;;; Step 4   : (PUSH-BOX P4 P6)   Created 4
;;; Step 5   : (PICKGLASS P6)    Created 9
;;; Step 6   : (PUSH-BOX P6 P3)   Created 3
;;; Step 7   : (CLIMB)           Created 2
;;; Step 8   : (GETWATER P3)     Created 8
;;; Step 9   : (GRAB-BANANAS)    Created 1
;;; 
;;; Goal     : ((HASBANANAS) (HASWATER))
;;; Complete!
;;; 
;;; 
;;; POCL (Init = 7  ; Goals = 2 ) => Win  (9 steps)     CPU 12667
;;;      Nodes (V = 580 ; Q = 154 ; C = 1241)             Branch 1.2655172
;;;      Working Unifies: 10719                           Bindings added: 374
;;; 
 
(defun monkey-test2 ()			; bananas and water
  (monkey-domain)
  (snlp:plan '((at monkey p1)
	       (on-floor)
	       (at box p2)
	       (at bananas p3)
	       (at knife p4)
	       (at waterfountain p3)
	       (at glass p6))
	     '((hasbananas)
	       (haswater))
             :rank-fun #'snlp::rank3))

;;; 
;;; <cl> (monkey-test3)
;;; 
;;; Initial  : ((AT MONKEY P1) (ON-FLOOR) (AT BOX P2) (AT BANANAS P3) (AT KNIFE P4) (AT WATERFOUNTAIN P5) (AT GLASS P6))
;;; 
;;; Step 1   : (PUSH-BOX ?Y7 ?Y6)   Created 7
;;; Step 2   : (GO-TO ?Y5)       Created 6
;;; Step 3   : (PUSH-BOX ?Y5 ?X3)   Created 5
;;; Step 4   : (GO-TO ?Y3)       Created 4
;;; Step 5   : (GO-TO ?X3)       Created 3
;;; Step 6   : (CLIMB)           Created 2
;;; Step 7   : (GRAB-BANANAS)    Created 1
;;; 
;;; Goal     : ((HASBANANAS) (HASWATER))
;;; Unsafe   : NIL
;;; Open     : (((ON-FLOOR) 7) ((AT MONKEY ?Y7) 7) ((AT BOX ?Y7) 7) ((ON-FLOOR) 6) ((AT BOX ?Y5) 5) ((AT BANANAS ?X3) 1) ((HASKNIFE) 1) ((HASWATER) GOAL))
;;; 
;;; 
;;; POCL (Init = 7  ; Goals = 2 ) => Lose (7 steps)     CPU 12550
;;;      Nodes (V = 642 ; Q = 159 ; C = 1341)             Branch 1.2476635
;;;      Working Unifies: 9019                            Bindings added: 385
;;; 

(defun monkey-test3 ()			; bananas and water (cannot be solved)
  (monkey-domain)
  (snlp:plan '((at monkey p1)
	       (on-floor)
	       (at box p2)
	       (at bananas p3)
	       (at knife p4)
	       (at waterfountain p5)
	       (at glass p6))
	     '((hasbananas)
	       (haswater))
             :rank-fun #'snlp::rank3))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; flat-tire domain (from Stuart Russell)

(defun init-flat-tire ()
  (reset-domain)

  (defstep :action '(cuss)
    :precond  '((annoyed))
    :add '((relieved))
    :dele '((annoyed))
    :equals '())
  
  (defstep :action '(open ?x)
    :precond  '((unlocked ?x) (closed ?x))
    :add '((open ?x))
    :dele '((closed ?x))
    :equals '())
  
  (defstep :action '(close ?x)
    :precond  '((open ?x))
    :add '((closed ?x))
    :dele '((open ?x))
    :equals '())
  
  (defstep :action '(fetch ?x ?y)	; fetching x from y
    :precond  '((in ?x ?y) (open ?y))
    :add '((have ?x))
    :dele '((in ?x ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(loosen ?x ?y)	; loosening x on y
    :precond  '((have wrench) (tight ?x ?y) (on-ground ?y))
    :add '((loose ?x ?y))
    :dele '((tight ?x ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(jack-up ?x ?y)	; jacking up wheel x on hub y
    :precond  '((have jack) (on-ground ?x) (on-ground ?y) (on ?x ?y))
    :add '((off-ground ?x) (off-ground ?y))
    :dele '((on-ground ?x) (on-ground ?y) (have jack))
    :equals '())
  
  (defstep :action '(inflate ?x)
    :precond  '((have pump) (flat ?x) (intact ?x))
    :add '((inflated ?x))
    :dele '((flat ?x))
    :equals '())
  
  (defstep :action '(undo ?x ?y)
    :precond  '((off-ground ?y) (have wrench) (loose ?x ?y))
    :add '((have ?x) (unfastened ?y))
    :dele '((on ?x ?y) (loose ?x ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(remove-wheel ?x ?y) ; removing wheel from hub
    :precond  '((off-ground ?x) (off-ground ?y) (on ?x ?y) (unfastened ?x))
    :add '((have ?x) (free ?y))
    :dele '((off-ground ?x) (on ?x ?y) (unfastened ?x))
    :equals '((not (?x ?y))))
  
  (defstep :action '(put-on-wheel ?x ?y)
    :precond  '((have ?x) (free ?y) (off-ground ?y))
    :add '((off-ground ?x) (on ?x ?y) (unfastened ?x))
    :dele '((have ?x) (free ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(do-up ?x ?y) 
    :precond '((have wrench) (off-ground ?y) (have ?x)) 
    :add '((loose ?x ?y)) 
    :dele '((have ?x))
    :equals '((not (?x ?y))))

  ;; jacking down wheel x on hub y (dependency would be better)
  (defstep :action '(jack-down ?x ?y)
    :precond  '((off-ground ?x) (off-ground ?y) (have jack) (on ?x ?y))
    :add '((on-ground ?x) (on-ground ?y) (have jack))
    :dele '((off-ground ?x) (off-ground ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(tighten ?x ?y)
    :precond  '((have wrench) (loose ?x ?y) (on-ground ?y))
    :add '((tight ?x ?y))
    :dele '((loose ?x ?y))
    :equals '((not (?x ?y)) ))
  
  (defstep :action '(put-away ?x ?y)
    :precond  '((have ?x) (open ?y))
    :add '((in ?x ?y))
    :dele '((have ?x))
    :equals '()))

(defun fixit ()
  (init-flat-tire)
  (snlp:plan  '((closed boot) (unlocked boot) (in jack boot) (in pump boot)
		(in wheel2 boot) (intact wheel2) (in wrench boot) (flat wheel2)
		(flat wheel1) (on wheel1 hub) (on-ground wheel1)
		(on-ground hub) (tight nuts wheel1))
	      '((closed boot) (in jack boot) (in pump boot) (in wheel1 boot)
		(in wrench boot) (inflated wheel2) (on wheel2 hub) 
		(tight nuts wheel2))
              :search-fun #'call-ie
	      :rank-fun #'snlp::rank))

(defun fix1 ()
  (init-flat-tire)
  (snlp:plan  '((closed boot) (unlocked boot) (in jack boot) (in pump boot)
		(in wheel2 boot) (intact wheel2) (in wrench boot) (flat wheel2)
		(flat wheel1) (on wheel1 hub) (on-ground wheel1)
		(on-ground hub) (tight nuts wheel1))
	      '((have jack) (have pump) (have wheel2)
		(have wrench))
              :search-fun #'call-ie
	      :rank-fun #'snlp::rank))

(defun fix2 ()
  (init-flat-tire)
  (snlp:plan  '((open boot)(intact wheel2)(have jack) (have pump) (have wheel2)
		(have wrench) (flat wheel2) (flat wheel1) (on wheel1 hub)
		(on-ground wheel1) (on-ground hub) (tight nuts wheel1))
	      '((inflated wheel2) (off-ground wheel1) (off-ground hub)
		(loose nuts wheel1))
              :search-fun #'call-ie
	      :rank-fun #'snlp::rank))

(defun fix3 ()
  (init-flat-tire)
  (snlp:plan  '((intact wheel2) (have jack) (have pump) (have wheel2)
		(have wrench) (flat wheel1) (on wheel1 hub) (inflated wheel2)
		(off-ground wheel1) (off-ground hub) (loose nuts wheel1))
	      '((on wheel2 hub) 
		(tight nuts wheel2) (on-ground wheel2) (on-ground hub))
              :search-fun #'call-ie
	      :rank-fun #'snlp::rank))

(defun fix4 ()
  (init-flat-tire)
  (snlp:plan '((intact wheel2) (have jack) (have pump) (have wheel2)
	       (have wrench) (open boot)
	       (flat wheel1)  (inflated wheel2) 
	       (on wheel2 hub) 
	       (tight nuts wheel2) (on-ground wheel2) (on-ground hub))
	     '((in jack boot) (in pump boot) (in wheel1 boot)
	       (in wrench boot) (inflated wheel2) (on wheel2 hub) 
	       (tight nuts wheel2))
	     :search-fun #'call-ie
	     :rank-fun #'snlp::rank))

(defun fix5 ()
  (init-flat-tire)
  (snlp:plan '((open boot) (in jack boot) (in pump boot) (in wheel1 boot)
	       (in wrench boot) (inflated wheel2) (on wheel2 hub) 
	       (tight nuts wheel2))
	     '((closed boot) (in jack boot) (in pump boot) (in wheel1 boot)
	       (in wrench boot) (inflated wheel2) (on wheel2 hub) 
	       (tight nuts wheel2))
	     :search-fun #'call-ie
	     :rank-fun #'snlp::rank))