;;; -*- 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-data-structures.lisp:

;;; simple-POP is designed to be extensible, e.g., from partial-order
;;; planning with propositions to planning with variable bindings.
;;; Toward this end, new classes are provided for extended
;;; functionality, with an abstraction layer to hide the differences.
;;; For example, while the function make-action must be redefined to
;;; allow for a new class that supports variable bindings, the new
;;; version of make-action simply instantiates an object of class
;;; *action-class*, which can be either propositional-action or
;;; first-order-action.  Steps and plans are handled similarly.

;;; A few data structures for simple-GP are included at the end of
;;; this file, but there's relatively little overlap with simple-POP.
;;; Other simple-GP-relevant internal data structures, for
;;; representing levels and planning graphs, can be found in
;;; simple-gp.lisp.  The simple-GP definitions in this file are mainly
;;; for consistency with the other planners.

;;; ==============================

(defvar *plan-class* :unbound
  "The class of plans created and manipulated during planning.")

(defun make-plan (&rest args)
  (apply #'make-instance *plan-class* args))

(defvar *action-class* :unbound
  "The class of actions created and manipulated during planning.")

(defun make-action (&rest args)
  (apply #'make-instance *action-class* args))

(defvar *step-class* :unbound
  "The class of steps created and manipulated during partial-order planning.")

(defun make-step (action)
  (make-instance *step-class* :action action))

;;; ==============================
;;; Objects with identifiers

(defvar *id-counter* 0)

(defclass numbered-object ()
  ((id :reader id)))

(defmethod initialize-instance :after ((the-instance numbered-object) &key)
  (with-slots (id) the-instance
    (setf id (incf *id-counter*))))

;;; ==============================
;;; Uniform testing of objects

;;; Currently unused
(defclass plan-object ()
  ())

#+testing
(defmethod slot-value-by-key ((object plan-object) key)
  (funcall (getf (accessor-keys object) key) object))

#+testing
(defmethod matching-object-p ((object plan-object) accessor-key value &rest rest)
  (when (plan-objects-eql object (slot-value-by-key object accessor-key) value)
    (or (null rest)
	(apply #'matching-object-p object rest))))

#+testing
(defmethod matching-object-test ((object plan-object) &rest rest)
  #'(lambda (&rest args)
      (apply #'matching-object-p args)))

#+testing
(defmethod plan-objects-eql ((object plan-object) x y)
  (eql x y))

;;; ==============================
;;; Propositional partial-order planning

;;; The following are data structures and utilities for propositional
;;; partial-order planning.  The prefix "propositional-" indicates
;;; that an action or step includes only propositional literals.

;;; Actions

(defclass propositional-action (plan-object)
  ((name :accessor action-name :initarg :name)
   (precond :accessor action-precond :initarg :precond :initform nil)
   (effect :accessor action-effect :initarg :effect :initform nil)))

(defmethod print-object ((action propositional-action) stream)
  (format stream "#<Action: ~A>" (action-print-name action)))

(defmethod action-print-name ((action propositional-action))
  (let ((name (action-name action)))
    (if (atom name)
	(format nil  "~:(~A~)" name)
	(format nil  "~:(~A~)~@[~A~]" (first name)
		(if (consp (first (rest name)))
		    (first (rest name))
		    (rest name))))))

;;; Steps

(defclass propositional-step (numbered-object plan-object)
  ((action :accessor step-action :initarg :action)))

(defmethod step-print-name ((step propositional-step))
  (let ((name (step-name step)))
    (if (atom name)
	(format nil  "~:(~A~)" name)
	(format nil  "~:(~A~)~@[~A~]" (first name) (rest name)))))

(defmethod print-object ((step propositional-step) stream)
  (format stream "#<Step: ~A>" (step-print-name step)))

(defmethod step-name (step)
  (action-name (step-action step)))

(defmethod step-effect ((step propositional-step))
  (action-effect (step-action step)))

(defmethod step-precond ((step propositional-step))
  (action-precond (step-action step)))

;;; Ordering constraints

(defclass ordering (plan-object)
  ((before :accessor ordering-before :initarg :before)
   (after :accessor ordering-after :initarg :after)))

(defmethod print-object ((ordering ordering) stream)
  (with-slots (before after) ordering
    (format stream "#<~A -> ~A>" before after)))

(defun order (before after)
  (make-instance 'ordering :before before :after after))

;;; This overrides an earlier comparison based on equal.
(defun order-eql (ordering-1 ordering-2)
  (and (eql (ordering-before ordering-1) (ordering-before ordering-2))
       (eql (ordering-after ordering-1) (ordering-after ordering-2))))

;;; Causal links

(defvar *link-class* 'link)

(defclass link (plan-object)
  ((from :accessor link-from :initarg :from)
   (to :accessor link-to :initarg :to)
   (literal :accessor link-literal :initarg :literal)))

(defmethod print-object ((link link) stream)
  (with-slots (from to literal) link
    (format stream "#<~A =>[~A] ~A>" 
            (step-print-name from) literal (step-print-name to))))

(defun link (from to literal)
  (make-instance *link-class* :from from :to to :literal literal))

;;; Open preconditions

(defclass open-precond (plan-object)
  ((literal :accessor open-literal :initarg :literal)
   (step :accessor open-step :initarg :step)))

(defmethod print-object ((open-precond open-precond) stream)
  (with-slots (literal step) open-precond
    (format stream "#<Open ~A in ~A>" literal (step-print-name step))))

(defun make-open  (literal step)
  (make-instance 'open-precond :literal literal :step step))

;;; Threats

(defclass threat (plan-object)
  ((step :accessor threat-step :initarg :step)
   (link :accessor threat-link :initarg :link)))

(defmethod threat (step link)
  (make-instance 'threat :step step :link link))

;;; Plans

(defclass propositional-pop-plan (numbered-object plan-object)
  ((start :accessor plan-start :initarg :start :initform nil)
   (finish :accessor plan-finish :initarg :finish :initform nil)
   (steps :accessor plan-steps :initarg :steps :initform nil)
   (ordering :accessor plan-ordering :initarg :ordering :initform nil)
   (links :accessor plan-links :initarg :links :initform nil)
   (open :accessor plan-open :initarg :open :initform nil)))

;;; Plans print out with steps linearized, but are still
;;; partial-order, of course.
(defmethod print-object ((plan propositional-pop-plan) stream)
  (format stream "#<Plan: ~{~A~^, ~}>"
	  ;; "#<Plan-~A: ~{~A~^, ~}>" (id plan) ; for debugging
	  (mapcar #'step-print-name 
		  (find-all-if #'(lambda (step)
				   (real-step-p plan step))
			       (linearized-steps plan)))))

(defmethod copy-plan ((plan propositional-pop-plan))
  (make-instance *plan-class*
                 :start (plan-start plan)
                 :finish (plan-finish plan)
                 :steps (plan-steps plan)
                 :ordering (plan-ordering plan)
                 :links (plan-links plan)
                 :open (plan-open plan)))

(defmethod describe-plan ((plan propositional-pop-plan)
                          &optional (stream *standard-output*))
  ;; (format stream "~%Plan-~A:" (id plan))
  ;; (pprint plan stream)
  (format stream "~%Plan initial state:" )
  (pprint (step-effect (plan-start plan)) stream)
  (format stream "~%Plan goal state:" )
  (pprint (step-precond (plan-finish plan)) stream)
  (format stream "~%Plan ordering constraints:" )
  (pprint (plan-ordering plan) stream)
  (format stream "~%Plan causal links:" )
  (pprint (plan-links plan) stream)
  (format stream "~%Plan open preconditions:" )
  (pprint (plan-open plan) stream)
  plan)

(defmethod describe-plan :around ((plan propositional-pop-plan)
                                  &optional (stream *standard-output*))
  ;; After describing a plan, print an empty line.
  (call-next-method)
  (terpri stream))

(defmethod real-step-p ((plan propositional-pop-plan) step)
  "Test whether step is not start or finish--'virtual' steps."
  (and (not (eql step (plan-start plan)))
       (not (eql step (plan-finish plan)))))

(defmethod real-plan-steps ((plan propositional-pop-plan))
  "Return all steps except start and finish."
  (find-all-if #'(lambda (step)
		   (real-step-p plan step))
	       (plan-steps plan)))

;;; ==============================
;;; First-order partial-order planning

;;; The following are data structures and utilities for partial-order
;;; planning with variable bindings.  The prefix "first-order-"
;;; indicates that an action or step includes first-order literals,
;;; with variables.

(defvar *plan-bindings* nil             ; Support for printing
  "If this variable is bound to a set of bindings,
  steps within a plan are printed with their bindings
  rather than variable names.")

;;; Actions

(defclass first-order-action (propositional-action plan-object)
  ((parameters :accessor action-parameters :initarg :parameters :initform nil)))

(defmethod print-object ((action first-order-action) stream)
  (with-slots (name parameters) action
    (format stream "#<Action: ~A~@[~A~]>" name parameters)))

;;; Steps

(defclass first-order-step (propositional-step plan-object)
  ((variables :accessor step-variables :initarg :variables :initform nil)
   (inequality-constraints :accessor step-inequalities :initarg :inequalities :initform nil)
   (precond :accessor step-precond :initarg :precond :initform nil)
   (effect :accessor step-effect :initarg :effect :initform nil)))

(defparameter *pretty-step-variables* t)

(defmethod step-print-name ((step first-order-step))
  (let ((variables (if *pretty-step-variables*
		       (pretty-step-variables step)
		       (step-variables step))))
    (if variables
	(format nil  "~:(~A~)~@[~A~]" (step-name step) variables)
	(call-next-method))))

(defmethod pretty-step-variables ((step first-order-step))
  (let ((variables (step-variables step))
	;; AIMA compatibility
	(*variable-prefix-char* #\?))
    (loop for v in variables
       for p in (action-parameters (step-action step))
       for binding = (if *plan-bindings*
			 (subst-bindings *plan-bindings* v)
			 v)
       collect (if (variable-p binding)
		   p
		   binding))))

;;; Causal links

;;; The link class is not changed, but we can print more useful
;;; information about it.

(defmethod print-object ((link link) stream)
  (with-slots (from to literal) link
    (format stream "#<~A =>[~A] ~A>" 
            (step-print-name from)
            (if *plan-bindings*
                (subst-bindings *plan-bindings* literal)
                literal)
            (step-print-name to))))

;;; Plans

(defclass pop-plan (propositional-pop-plan plan-object)
  ((bindings :accessor plan-bindings :initarg :bindings :initform +no-bindings+)
   (inequality-constraints :accessor plan-inequalities :initarg :inequalities :initform nil)))

(defmethod copy-plan :around ((plan pop-plan))
  (let ((copy (call-next-method)))
    (setf (plan-bindings copy) (plan-bindings plan))
    (setf (plan-inequalities copy) (plan-inequalities plan))
    copy))

(defmethod print-object ((plan pop-plan) stream)
  (declare (ignore stream))
  (let ((*plan-bindings* (plan-bindings plan))
	;; AIMA compatibility
	(*variable-prefix-char* #\?))
    (call-next-method)))

(defmethod describe-plan :after ((plan pop-plan)
                                 &optional (stream *standard-output*))
  (format stream "~%Plan bindings:" )
  (pprint (plan-bindings plan) stream)
  (format stream "~%Plan inequality constraints:" )
  (pprint (plan-inequalities plan) stream))  

(defmethod describe-plan :around ((plan pop-plan)
                                  &optional (stream *standard-output*))
  (declare (ignore stream))
  (let ((*plan-bindings* (plan-bindings plan)))
    (call-next-method)))

;;; ==============================
;;; GraphPlan

;;; The following are data structures and utilities for our GraphPlan
;;; implementation.

;;; Actions

;;; simple-GP relies on the existing propositional-action class, but
;;; we add utilities for persistent actions.

(defun make-persistent-action (literal)
  (make-action :name literal :precond (list literal) :effect (list literal)))

(defmethod action-persistent-p ((the-action propositional-action))
  (equal (action-precond the-action)
	 (action-effect the-action)))

;;; Plans

(defclass gp-plan (numbered-object plan-object)
  ((planning-graph :accessor planning-graph :initarg :planning-graph)
   (actions :initarg :actions)))

(defparameter *include-persistent-actions-p* nil)

(defmethod print-object ((the-plan gp-plan) stream)
  (with-slots (actions) the-plan
    (format stream "#<Plan: ~{[~{~A~^, ~}]~^; ~}>"
	    (mapcar #'(lambda (level)
			(mapcar #'action-print-name level))
		    (if *include-persistent-actions-p*
			actions
			(mapcar #'(lambda (action-list)
				    (remove-if #'action-persistent-p action-list))
				actions))))))

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