;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-

;;; Copyright 2007 by Robert St. Amant.

;;; To download the code for simple-POP and simple-GP, visit
;;; <http://www.csc.ncsu.edu/faculty/stamant/simple-pop/simple-pop.html>.

;;; This software is released under the license described by Peter
;;; Norvig: <http://www.norvig.com/license.html>.  If you find this
;;; software useful, please send email to <stamant@csc.ncsu.edu>.

;;; About simple-pddl-domains.lisp:

;;; This is a minimal implementation supporting the definition of
;;; domains and problems in PDDL form.  It is minimal in the sense
;;; that from a given domain or problem definition, only a few pieces
;;; of information are extracted and processed.  For domains, only
;;; :ACTION forms are handled; :requirements, :types, :constants, and
;;; :predicates are all ignored.  For problems, only :objects, :init,
;;; and :goal forms are handled.

;;; There is only the most cursory error testing in these macros and
;;; functions.

;;; One area to be careful in the use of this code is in :goal forms
;;; in problems as well as :precond and :effect forms in actions.
;;; Simple-POP and simple-GP assume that all of these forms are lists
;;; that represent implicit conjunctions.  For consistency with PDDL,
;;; such forms can be either single literals, such as X, or explicit
;;; conjunctions of the form (AND X Y. . .).  The function
;;; implicit-conjunction translates such forms into lists: in the
;;; examples above, (X) or (X Y).  No analysis or error checking is
;;; carried out.

;;; Aside from PDDL-related code, this file contains a couple of dozen
;;; problems to illustrate the results of planners.  Aggregate tests
;;; on these problems, with their results, can be found at the end of
;;; the file.

;;; ==============================
;;; Top-level macro

(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro define ((key name) &body forms)
  (case key
    (domain
     `(add-domain ',name ',(extract-action-forms forms)))
    (problem
     `(add-problem ',name ',forms)))))

;;; ==============================
;;; Domain processing

(defvar *domains* (make-hash-table))

(defun add-domain (name action-forms)
  (setf (gethash name *domains*) action-forms)
  name)

(defun domain-p (name)
  (gethash name *domains*))

(defun remove-domain (name)
  (remhash name *domains*)
  nil)

(defun domain-action-forms (name)
  (gethash name *domains*))

(defun extract-action-forms (list)
  (loop for (key . args) in list
     if (eq key :action)
     collect (list :name (first args)
		   :parameters (getf (rest args) :parameters)
		   :precond (make-implicit-conjunction (or (getf (rest args) :precond)
							   (getf (rest args) :precondition)))
		   :effect (make-implicit-conjunction (getf (rest args) :effect)))
     else do (format t "Ignoring ~S and arguments.~%" key)))

(defun make-implicit-conjunction (form)
  (cond ((null form) nil)
	((and (listp form) (eq (first form) 'AND))
	 (rest form))
	(t (list form))))

(defun make-explicit-conjunction (form)
  `(and ,@form))

;;; ==============================
;;; Environments

#+PAIP
(defparameter *environment-class* 'basic-environment)
#+PAIP
(defparameter *run-limit* 500)

#+PAIP
(defclass basic-environment ()
  ((domain :accessor domain :initarg :domain)
   (actions :accessor actions :initarg :actions)
   (current-state :accessor current-state :initarg :state :initform nil)
   (time-step :accessor time-step :initarg :time-step :initform 0)
   (script :accessor script :initarg :script :initform nil)))

#+PAIP
(defun make-environment (&rest rest)
  (apply #'make-instance *environment-class* rest))

#+PAIP
(defmethod run ((environment basic-environment) function 
		&key (limit *run-limit*) (limit-function nil) (start-time 0))
  (assert (or limit limit-function))	; Prevent an infinite loop
  (with-slots (time-step) environment
    (loop for time from start-time do
	 (when (and limit (>= time limit))
	   (return))
	 (when (and limit-function (funcall limit-function))
	   (return))
	 (setf time-step time)
	 (execute-script environment)
	 (funcall function))))

#+PAIP
(defmethod act ((environment basic-environment) (action symbol))
  (act environment (list action)))

#+PAIP
(defmethod act ((environment basic-environment) (action t))
  (with-slots (domain current-state) environment
    (destructuring-bind (name . arguments) action
      (let* ((action-template (find name (domain-action-forms domain)
				    :key #'(lambda (template) (getf template :name))))
	     (parameters (getf action-template :parameters))
	     (precond (getf action-template :precond))
	     (effect (getf action-template :effect))
	     (bindings (unify arguments parameters)))
	(unless (every #'(lambda (literal)
			   (cond ((negated-literal-p literal)
				  (not (find literal current-state :test #'literals-negate-p)))
				 (t (member literal current-state :test #'literals-eql))))
		       (subst-bindings bindings precond))
	  (error "Action ~A not executable in current state ~A" action))
	(setf current-state
	      (merge-states current-state 
			    (subst-bindings bindings effect)))))))

#+PAIP
(defun merge-states (current-state changes)
  ;; Assume state has only positive literals
  (multiple-value-bind (to-delete to-add)
      (bipartition-if #'negated-literal-p changes)
    (remove-duplicates
     (append (remove-if #'(lambda (n)
			    (some #'(lambda (s)
				      (literals-negate-p n s))
				  to-delete))
			current-state)
	     to-add)
     :test #'literals-eql)))

;;; Trivial scripting

#+PAIP
(defmethod execute-script ((environment basic-environment))
  (with-slots (script) environment
    (when script
      (let ((element (first script)))
	(when (funcall element environment)
	  (pop script))))))

;;; ==============================
;;; Problem processing

(defclass PDDL-problem ()
  ((objects :accessor PDDL-problem-objects :initarg :objects :initform nil)
   (init :accessor PDDL-problem-init :initarg :init)
   (goal :accessor PDDL-problem-goal :initarg :goal)))

(defvar *problems* (make-hash-table))

(defun add-problem (name alist)
  (let ((domain (second (assoc :domain alist)))
	(goal (make-implicit-conjunction (second (assoc :goal alist))))
	(objects (rest (assoc :objects alist)))
	(init (rest (assoc :init alist))))
    (assert (domain-p domain)) 
    (let ((problem (make-instance 'PDDL-problem :objects objects :init init :goal goal))
	  (problem-entry (assoc domain (gethash name *problems*))))
      (if problem-entry
	  (setf (cdr problem-entry) problem)
	  (push (cons domain problem) (gethash name *problems*)))
      problem)))

(defun PDDL-problem (name domain-name)
  (cdr (assoc domain-name (gethash name *problems*))))

;;; ==============================
;;; PAIP problem conversion

;;; We perform a simplistic conversion of GPS operators to simple-POP
;;; and simple-GP actions, by negating all the literals in the delete
;;; list of an operator and adding them to the effect of an action.
;; This leads to some ugliness.  For example, from *banana-ops*, we
;;; have

;;; (op 'eat-bananas
;;;     :preconds '(has-bananas)
;;;     :add-list '(empty-handed not-hungry)
;;;     :del-list '(has-bananas hungry))

;;; which will produce an action with the effect

;;; (EMPTY-HANDED NOT-HUNGRY (NOT HAS-BANANAS) (NOT HUNGRY)).

;;; This may mean more work in the planning process, but it doesn't
;;; break anything.

#+PAIP
(defun simple-convert-op (op)
  "Translate a GPS op into a simple-POP action.  Analogous to convert-op,
  but nondestructive."
  (flet ((negate (literal)
           `(not ,literal))
         (unconvert-op (op)
           (setf (op-add-list op)
                 (remove-if #'(lambda (p)
                                (and (consp p) (eq (first p) 'EXECUTING)))
                            (op-add-list op)))
           op))
    (let ((op1 (unconvert-op (copy-op op)))) 
      `(:name    ,(op-action op1)
	:precond ,(op-preconds op1)
	:effect  ,(append (op-add-list op1)
			  (mapcar #'negate (op-del-list op1)))))))

#+PAIP
(defun make-PAIP-domain (name operators)
  (add-domain name (mapcar #'simple-convert-op operators)))

;;; ==============================
;;; PAIP domains and problems, from gps.lisp and gps1.lisp.

;;; To test these domains and problems, evaluate one of the
;;; defparameter forms below, and then evaluate one of the
;;; conditionalized calls to PLAN below.  Not all of the planners will
;;; work with all of the problems.  Specifically:

;;; * The propositional-POP-planner will not work for any of the
;;;   domains containing first-order actions, starting with
;;;   getting-dressed-1 below.  The GP-planner creates sets of
;;;   propositional actions for each first-order action and works for
;;;   all domains and problems in this file.

;;; * Some of the problems are too large for the POP planners.

;;; See the end of this file for aggregate tests for the planners on
;;; the problems to which each can be applied.

;;; ------------------------------
;;; Going to school [PAIP, p. 118]

#+PAIP
(make-PAIP-domain 'school *school-ops*)

#+PAIP
(define (problem at-home)
    (:domain school)
  (:init son-at-home car-works)
  (:goal son-at-home))

#+PAIP
(define (problem at-school)
    (:domain school)
  (:init son-at-home car-works)
  (:goal son-at-school))

#+PAIP
(define (problem at-school-2)
    (:domain school)
  (:init son-at-home car-needs-battery have-money have-phone-book)
  (:goal son-at-school))

;;; Here's what simple-POP, for example, generates:

;;; #<Plan: Start, Give-Shop-Money, Look-Up-Number, Telephone-Shop,
;;;  Tell-Shop-Problem, Shop-Installs-Battery, Drive-Son-To-School,
;;;  Finish>

;;; This isn't quite right--you shouldn't be able to give-shop-money
;;; until after, say, tell-shop-problem.  (We assume the shop makes
;;; house calls.)  This is actually a minor bug in *school-ops*.
;;; Let's revise:

#+PAIP
(make-PAIP-domain 'school
		  (substitute (make-op :action 'give-shop-money
				       ;; :preconds '(have-money) ; formerly
				       :preconds '(have-money shop-knows-problem) ; ***
				       :add-list '(shop-has-money)
				       :del-list '(have-money))
			      'give-shop-money
			      *school-ops*
			      :key #'op-action))

;;; Better now:

;;; #<Plan: Start, Look-Up-Number, Telephone-Shop, Tell-Shop-Problem,
;;;  Give-Shop-Money, Shop-Installs-Battery, Drive-Son-To-School,
;;;  Finish>

;;; ------------------------------
;;; Monkey and bananas [PAIP, p. 133]

#+PAIP
(make-PAIP-domain 'bananas *banana-ops*)

#+PAIP
(define (problem bananas)
    (:domain bananas)
  (:init at-door on-floor has-ball hungry chair-at-door)
  (:goal not-hungry))

;;; ------------------------------
;;; Mazes [PAIP, p. 134]

#+PAIP
(make-PAIP-domain 'maze *maze-ops*)

;;; The POP planners do not find a solution in a "reasonable" amount of time.

#+PAIP
(define (problem start-to-finish)
    (:domain maze)
  (:init (at 1))
  (:goal (at 25)))

;;; This works for the POP planners.

#+PAIP
(define (problem start-to-8)
    (:domain maze)
  (:init (at 1))
  (:goal (at 8)))

;;; ------------------------------
;;; Blocks world [PAIP, p. 137]

#+PAIP
(make-PAIP-domain 'three-blocks (make-block-ops '(a b c)))

#+PAIP
(define (problem stack-two)
    (:domain three-blocks)
  (:objects a b)
  (:init (a on table) (b on table) (space on a) (space on b) (space on table))
  (:goal (and (a on b) (b on table))))

;;; Order of conjuncts [PAIP, p. 138-9]

#+PAIP
(define (problem order-1)
    (:domain three-blocks)
  (:init (a on b) (b on table) (space on a) (space on table))
  (:goal (b on a)))

#+PAIP
(define (problem stack-three-1)
    (:domain three-blocks)
  (:init (a on b) (b on c) (c on table) (space on a) (space on table))
  (:goal (and (b on a) (c on b))))

#+PAIP
(define (problem stack-three-2)
    (:domain three-blocks)
  (:init (a on b) (b on c) (c on table) (space on a) (space on table))
  (:goal (and (c on b) (b on a))))

;;; Shorter solutions [PAIP, p. 140-1]

#+PAIP
(define (problem stack-three-3)
    (:domain three-blocks)
  (:init (c on a) (a on table) (b on table)
	 (space on c) (space on b) (space on table))
  (:goal (and (c on table) (a on b))))

#+PAIP
(define (problem stack-three-4)
    (:domain three-blocks)
  (:init (a on b) (b on c) (c on table) (space on a) (space on table))
  (:goal (and (b on a) (c on b))))

#+PAIP
(define (problem stack-three-5)
    (:domain three-blocks)
  (:init (a on b) (b on c) (c on table) (space on a) (space on table))
  (:goal (and (c on b) (b on a))))

;;; The dreaded Sussman anomaly [PAIP, p. 142]

#+PAIP
(define (problem sussman)
    (:domain three-blocks)
  (:init (c on a) (a on table) (b on table) (space on c)
	 (space on b) (space on table))
  (:goal (and (a on b) (b on c))))

;;; ==============================
;;; Propositional planning domains and problems

;;; ------------------------------
;;; Getting dressed [AIMA, p. 388]

(define (domain socks-and-shoes)
  (:action Right-Shoe :precond Right-Sock-On :effect Right-Shoe-On)
  (:action Right-Sock :precond nil :effect Right-Sock-On)
  (:action Left-Shoe :precond Left-Sock-On :effect Left-Shoe-On)
  (:action Left-Sock :precond nil :effect Left-Sock-On))

(define (problem put-on-shoes)
    (:domain socks-and-shoes)
  (:init)
  (:goal (and Right-Shoe-On Left-Shoe-On)))

;;; ------------------------------
;;; Changing a flat tire [AIMA, p. 391]

(define (domain flat-tire)
  (:action (remove spare trunk) 
	   :precond (at spare trunk)
	   :effect (and (not (at spare trunk)) (at spare ground))) 
  (:action (remove flat axle) 
	   :precond (at flat axle)
	   :effect (and (not (at flat axle)) (at flat ground)))
  (:action (puton spare axle)
	   :precond (and (at spare ground) (not (at flat axle)))
	   :effect (and (not (at spare ground)) (at spare axle)))
  (:action leaveovernight 
	   :effect (and (not (at spare ground)) (not (at spare axle)) (not (at spare trunk))
			(not (at flat ground)) (not (at flat axle)))))

(define (problem fix-flat)
    (:domain flat-tire)
  (:init (at flat axle) (at spare trunk))
  (:goal (at spare axle)))

;;; An alternative implementation

(define (domain alternative-flat-tire)
  (:action remove-spare-trunk
	   :precond spare-in-trunk
	   :effect (and (not spare-in-trunk) spare-on-ground))
  (:action remove-flat-from-axle
	   :precond flat-at-axle
	   :effect (and (not flat-at-axle) flat-on-ground))
  (:action puton-spare-axle
	   :precond (and spare-on-ground (not flat-at-axle))
	   :effect (and (not spare-on-ground) spare-at-axle))
  (:action leave-overnight
	   :precond ()
	   :effect (and (not spare-on-ground) (not spare-at-axle) (not spare-in-trunk) (not flat-on-ground) (not flat-at-axle))))

(define (problem alternative-fix-flat)
    (:domain alternative-flat-tire)
  (:init flat-at-axle spare-in-trunk (not spare-at-axle) (not flat-on-ground) (not spare-on-ground))
  (:goal spare-at-axle))

;;; ------------------------------
;;; The "have cake and eat cake too" problem [AIMA, p. 391]

(define (domain cake)
  (:action eat-cake :precond have-cake :effect (and (not have-cake) eaten-cake))
  (:action bake-cake :precond (not have-cake) :effect have-cake))

(define (problem have-and-eat)
    (:domain cake)
  (:init have-cake (not eaten-cake)) 
  (:goal (and have-cake eaten-cake)))

;;; ------------------------------
;;; Dan Weld's dinner date problem

;;; Weld, D. S. (1999). Recent Advances in AI Planning, AI Magazine
;;; 20(2):93-123.

(define (domain dinner)
  (:action cook
	   :precond clean-hands
	   :effect dinner)
  (:action wrap
	   :precond quiet
	   :effect present)
  (:action carry
	   :precond nil
	   :effect (and (not garbage) (not clean-hands)))
  (:action dolly
	   :precond nil
	   :effect (and (not garbage) (not quiet))))

;;; Note: the propositional-POP-planner, POP-planner, and GP-planner
;;; all produce different solutions to this problem.  

;;; POP-planner: #<Plan: Cook, Carry, Wrap>  -- the solution Dan describes.
;;; GP-planner: #<Plan: [Cook, Wrap], [Dolly]>.
;;; propositional-POP-planner: #<Plan: Wrap, Dolly, Cook>.

;;; All are consistent with the domain description, though in real
;;; life we'd probably think the latter two plans were not as good.

(define (problem dinner-date)
    (:domain dinner)
  (:init garbage clean-hands quiet) 
  (:goal (and dinner present (not garbage))))

;;; ==============================
;;; First-order planning domains and problems

;;; A simple two-step plan.

(define (domain getting-dressed-1)
    (:action pick-up
	     :parameters (?x)
	     :precond (see ?x)
	     :effect (in-hand ?x))
  (:action put-on
	   :parameters (?a)
	   :precond (in-hand ?a)
	   :effect (and (wearing ?a) dressed)))

(define (problem get-dressed-1)
    (:domain getting-dressed-1)
  (:objects shoes other-shoes)
  (:init (see shoes) (see other-shoes))
  (:goal dressed))

;;; A plan with an inequality constraint.

(define (domain getting-dressed-2)
    (:action pick-up
	     :parameters (?x)
	     :precond (see ?x)
	     :effect (in-hand ?x))
  (:action put-on
	   :parameters (?a)
	   :precond (and (in-hand ?a) (neq ?a those-shoes))
	   :effect (and (wearing ?a) dressed)))

(define (problem get-dressed-2) 
    (:domain getting-dressed-2)
  (:objects shoes other-shoes)
  (:init (see those-shoes) (see other-shoes))
  (:goal dressed))

;;; ------------------------------
;;; Blocks World [AIMA p. 383]

(define (domain blocksworld)
    (:action Move
	     :parameters (?b ?x ?y)
	     :precond (and (On ?b ?x) (Clear ?b) (Clear ?y) (Block ?b)
			   (neq ?b ?x) (neq ?b ?y) (neq ?x ?y))
	     :effect (and (On ?b ?y) (Clear ?x) (not (On ?b ?x)) (not (Clear ?y))))
  (:action MoveToTable
	   :parameters (?b ?x)
	   :precond (and (On ?b ?x) (Clear ?b) (Block ?b) (neq ?b ?x))
	   :effect (and (On ?b Table) (Clear ?x) (not (On ?b ?x)))))

(define (problem simple-stack)
    (:domain blocksworld)
  (:objects A B C Table)
  (:init (Block A) (Block B) (Block C)
	 (On A Table) (On B Table) (On C Table)
	 (Clear A) (Clear B) (Clear C))
  (:goal (and (On A B) (On B C))))

;;; Blocks World, the Sussman anomaly

(define (problem sussman)
    (:domain blocksworld)
  (:objects A B C Table)
  (:init (Block A) (Block B) (Block C)
	 (On A Table) (On C A) (On B Table)
	 (Clear B) (Clear C) (Clear Table))
  (:goal (and (On A B) (On B C))))

;;; ------------------------------
;;; Alternative Blocks World [AIMA p. 445]
;;; Slight difference: no free variables allowed in simple-POP.

(define (domain one-action-blocksworld)
    (:action Move ; Move ?x from ?z to ?y
	     :parameters (?x ?z ?y)
	     :precond (and (Clear ?x) (Clear ?y) (On ?x ?z)
			   #+test (neq ?x ?y) #+test (neq ?y ?z) #+test (neq ?x ?z))
	     :effect (and (On ?x ?y) (Clear ?z) (not (On ?x ?z)) (not (Clear ?y)))))

(define (problem no-goals)
    (:domain one-action-blocksworld)
  (:objects A B C D E F G)
  (:init (On B E) (On C F) (On D G)
	 (Clear A) (Clear B) (Clear C) (Clear D))
  (:goal nil))

(define (problem one-goal)
    (:domain one-action-blocksworld)
  (:objects A B C D E F G)
  (:init (On B E) (On C F) (On D G)
	 (Clear A) (Clear B) (Clear C) (Clear D))
  (:goal (On D B)))

(define (problem two-goals)
    (:domain one-action-blocksworld)
  (:objects A B C D E F G)
  (:init (On B E) (On C F) (On D G)
	 (Clear A) (Clear B) (Clear C) (Clear D))
  (:goal (and (On C D) (On D B))))

;;; ==============================
;;; Yet more Blocks World

;;; This is a hack, but for what it's worth: Go to the Web site
;;; <http://users.rsise.anu.edu.au/~jks/cgi-bin/bwstates/bwcgi>.
;;; Generate a set of small problems (e.g., four blocks).  Save the
;;; text of the generated page in a file in the directory below, named
;;; *blocksworld-problems-directory*, which you may need to change on
;;; your platform (the default is PAIP-specific).  There's a sample
;;; file, "blocksworld.text", that accompanies the Lisp planner files
;;; to show how it works.  You can then run the planners on the
;;; generated blocksworld problems.  Even four blocks may be too many
;;; for the POP planners, and simple-GP may take a while.

#+testing
(dolist (problem (read-bw-file "blocksworld.text"))
  (format t "Problem ~A in domain ~A.~%Solution: ~A.~2%"
	  problem
	  'blocksworld
	  (plan (make-instance 'gp-planner) problem :domain 'blocksworld)))

(defparameter *blocksworld-problems-directory*
  #+PAIP *paip-directory*
  #-PAIP (truename *load-pathname*))

(defvar *whitespace-chars*
  '(#\  #\Newline #\Tab #\Page #\Null #\Newline))

(defun read-bw-file (file-name &optional (directory *blocksworld-problems-directory*))
  (let ((problems nil))
    (flet ((empty-string-p (string)
	     (string= (string-trim *whitespace-chars* string) "")))
      (with-open-file (input (merge-pathnames file-name (pathname directory)))
	(loop for line = (read-line input nil nil)
	   until (null line)
	   do (let ((trimmed-line (string-trim *whitespace-chars* line)))
		(cond ((empty-string-p trimmed-line))
		      ((string= trimmed-line "Problem:")
		       (push (translate-bw-problem (read-data-items input #'empty-string-p 3))
			     problems)))))))
    problems))

(defun read-data-items (input &optional stop-when n-items-per-line n-lines)
  (let ((eof (gensym)))
    (loop for line-count from 0
       for line = (read-line input nil nil)
       until (or (null line)
		 (and n-lines (>= line-count n-lines))
		 (and stop-when (funcall stop-when line)))
       ;; Make sure there's something readable in the line
       when (read-from-string line nil nil)
       collect (let ((item nil)
		     (position 0))
		 (loop for count from 1
		    ;; do at least one iteration
		    do (multiple-value-setq (item position)
			 (read-from-string line nil eof :start position))
		    until (or (eq item eof)
			      (and n-items-per-line (> count n-items-per-line)))
		    collect item into items
		    finally (return (if n-items-per-line
					(map-into (make-list n-items-per-line)
						  #'identity items)
					items)))))))

(defun translate-bw-problem (data &optional (name (gentemp "BW-")))
  (assert (equal (pop data) '(BLOCK INITIAL GOAL)))
  (let* ((objects (mapcar #'first data))
	 (initial (mapcar #'second data))
	 (goal (mapcar #'third data)))
    (eval `(define (problem ,name)
	     (:domain blocksworld)
	     (:objects ,@objects Table)
	     (:init ,@(mapcar #'(lambda (object)
				  `(Block ,object))
			      objects)
		    ,@(mapcar #'(lambda (object initial)
				  `(On ,object ,initial))
			      objects initial)
		    ,@(loop for object in objects
			 unless (find object initial)
			 collect `(clear ,object)))
	     (:goal (and ,@(mapcar #'(lambda (object goal)
				       `(On ,object ,goal))
				   objects goal)))))
    name))

;;; ------------------------------
;;; Air cargo transportation [AIMA p. 380]

(define (domain cargo)
    (:action Load
	     :parameters (?c ?p ?a)
	     :precond (and (At ?c ?a) (At ?p ?a) (Cargo ?c) (Plane ?p) (Airport ?a))
	     :effect (and (not (At ?c ?a)) (In ?c ?p)))
  (:action Unload
	   :parameters (?c ?p ?a)
	   :precond (and (In ?c ?p) (At ?p ?a) (Cargo ?c) (Plane ?p) (Airport ?a))
	   :effect (and (At ?c ?a) (not (In ?c ?p))))
  (:action Fly
	   :parameters (?p ?from ?to) 
	   :precond (and (At ?p ?from) (Plane ?p) (Airport ?from) (Airport ?to))
	   :effect (and (not (At ?p ?from)) (At ?p ?to))))

;;; Air cargo transportation [AIMA p. 380], simplified for a one-way
;;; trip with a single plane and one piece of cargo.

(define (problem deliver-no-return)
    (:domain cargo)
  (:objects C1 SFO P1 JFK)
  (:init (At C1 SFO) (At P1 SFO)
	 (Cargo C1) (Plane P1)
	 (Airport JFK) (Airport SFO))
  (:goal (At C1 JFK)))

;;; Air cargo transportation [AIMA p. 380], simplified for a round
;;; trip with a single plane and one piece of cargo, the plane
;;; returning empty.  Takes some time but finishes.

(define (problem deliver-and-return)
    (:domain cargo)
  (:objects C1 SFO P1 JFK)
  (:init (At C1 SFO) (At P1 SFO)
	 (Cargo C1) (Plane P1)
	 (Airport JFK) (Airport SFO))
  (:goal (and (At C1 JFK) (At P1 SFO))))

(define (problem one-full-one-empty)
    (:domain cargo)
  (:objects C1 SFO P1 P2 JFK)
  (:init (At C1 SFO) (At P1 SFO) (At P2 JFK)
	 (Cargo C1) (Plane P1) (Plane P2)
	 (Airport JFK) (Airport SFO))
  (:goal (and (At C1 JFK) (At P2 SFO) #+test (At P1 SFO))))


;;; Air cargo transportation [AIMA p. 380], as given.

(define (problem back-and-forth)
    (:domain cargo)
  (:objects C1 C2 SFO P1 P2 JFK)
  (:init (At C1 SFO) (At C2 JFK) (At P1 SFO) (At P2 JFK)
	 (Cargo C1) (Cargo C2) (Plane P1) (Plane P2)
	 (Airport JFK) (Airport SFO))
  (:goal (and (At C1 JFK) (At C2 SFO))))

;;; ==============================
;;; Aggregate tests

(defparameter *propositional-problems-and-domains*
  '(#+PAIP (at-home school)
    #+PAIP (at-school school)
    #+PAIP (at-school-2 school)
    #+PAIP (bananas bananas)
    #+PAIP (start-to-8 maze)
    #+PAIP (start-to-finish maze)
    #+PAIP (stack-two three-blocks)
    #+PAIP (order-1 three-blocks)
    #+PAIP (stack-three-1 three-blocks)
    #+PAIP (stack-three-2 three-blocks)
    #+PAIP (stack-three-3 three-blocks)
    #+PAIP (stack-three-4 three-blocks)
    #+PAIP (stack-three-5 three-blocks)
    #+PAIP (sussman three-blocks)
    (put-on-shoes socks-and-shoes)
    (fix-flat flat-tire)
    (alternative-fix-flat alternative-flat-tire)
    (have-and-eat cake)
    (dinner-date dinner)))

(defparameter *first-order-problems-and-domains*
  '((get-dressed-1 getting-dressed-1)
    (get-dressed-2 getting-dressed-2)
    (simple-stack blocksworld)
    (sussman blocksworld)
    (deliver-no-return cargo)
    (deliver-and-return cargo)
    (back-and-forth cargo)))

(defun run-planner-tests (planner problems-and-domains &rest rest &key (exclude-problems nil) &allow-other-keys)
  (loop for (problem domain) in (remove-if #'(lambda (problem-and-domain)
					       (member (first problem-and-domain)
						       exclude-problems))
					   problems-and-domains)
     do (format t "Problem ~A in domain ~A.~%Solution: ~A.~2%"
		problem
		domain
		(apply #'plan planner problem :domain domain rest))))

#+testing
(run-planner-tests (make-instance 'propositional-POP-planner)
		   *propositional-problems-and-domains*
		   :exclude-problems '(start-to-finish))

#+testing
(run-planner-tests (make-instance 'POP-planner)
		   (append *propositional-problems-and-domains*
			   *first-order-problems-and-domains*)
		   :exclude-problems '(start-to-finish back-and-forth))

#+testing
(run-planner-tests (make-instance 'GP-planner)
		   (append *propositional-problems-and-domains*
			   *first-order-problems-and-domains*))

;;; ==============================
;;; EOF