;;;
;;; Search Tools
;;; Based Roughly On The Descriptions In Russell & Norvig (1995)
;;;
;;; This code requires the previous loading of the "QUEUE" utilities.
;;;
;;; DAVID NOELLE  Wed Apr 17 12:22:47 1996
;;;


;;;
;;; Package
;;;

(cl::defpackage "SEARCH"
  (:use "COMMON-LISP" "QUEUE")
  (:export "PROBLEM"
	   "MAKE-PROBLEM"
	   "COPY-PROBLEM"
	   "NODE"
	   "CLEAR-EXPAND-COUNT"
	   "INCREMENT-EXPAND-COUNT"
	   "CURRENT-EXPAND-COUNT"
	   "EXPAND"
	   "GENERAL-SEARCH"
	   "PRINT-PATH"
	   "BREADTH-FIRST-SEARCH"
	   "DEPTH-FIRST-SEARCH"))

(cl::in-package "SEARCH")


;;;
;;; Problem Structure
;;;

;;;
;;; States can be of any type, as long as the user is consistent.
;;;
;;; Operators are functions which take a current state as input and 
;;; return a fresh list containing child states of that current
;;; state.  The order of this returned list will determine the order
;;; in which siblings are visited.  Also, the order of operators
;;; in the "operators" field of a "problem", below, will determine
;;; the order in which operators are applied.
;;;
;;; Goal test functions take a state as input and return non-nil if
;;; the given state is a goal state.
;;;
;;; Path cost functions take a single list, representing a path, as
;;; input, and return the cost of that path.  Each element of the
;;; input list is a list containing three elements describing the
;;; application of an operation:  the parent state, the operator
;;; function, and the resulting child state.
;;;

(defstruct (problem
	    (:constructor make-problem-given-operator-list)
	    (:copier copy-problem-structure-only))
  (initial-state nil :type t)
  (operators nil :type list)
  (goal-test #'identity :type function)
  (path-cost-function #'list-length :type function))
  

;;; make-problem  --  Makes a problem, copying the given "operators" list.
(defun make-problem (&key (initial-state nil)
			  (operators (list #'identity) operators-provided-p)
			  (goal-test #'identity)
			  (path-cost-function #'list-length))
  (declare (type list operators) 
	   (type function goal-test)
	   (type function path-cost-function))
  (let ((ops
	 (if operators-provided-p
	   (copy-list operators)
	   operators)))
    (declare (type list ops))
    (make-problem-given-operator-list
     :initial-state initial-state
     :operators ops
     :goal-test goal-test
     :path-cost-function path-cost-function)))

;;; copy-problem  --  Copys the given problem, copying the conses of
;;; the operators list.
(defun copy-problem (p)
  (declare (type problem p))
  (let ((new-p (copy-problem-structure-only p)))
    (declare (type problem new-p))
    (setf (problem-operators new-p) (copy-list (problem-operators p)))
    new-p))


;;;
;;; Node Structure
;;;

(defstruct node
  (state nil :type t)
  (parent-node nil :type (or node nil))
  (operator nil :type (or function nil))
  (depth 0 :type fixnum)
  (path-cost 0 :type fixnum))
  

;;;
;;; Node Utilities
;;;

;;;
;;; These utilities count the number of calls to the "expand" function.
;;;

(defvar *expand-count* 0)

(defun clear-expand-count ()
  (setq *expand-count* 0))

(defun increment-expand-count ()
  (incf *expand-count*))

(defun current-expand-count ()
  *expand-count*)

;;; expand  --  Expand the given parent node, linking in children
;;; generated by application of the given list of operators.  Also,
;;; update the path cost to each of these new children.  Return a
;;; fresh list of the children.
(defun expand (parent-node 
	       operators 
	       &optional 
	       (path-cost-function #'list-length))
  (declare (type node parent-node) (type list operators))
  (let* ((child-depth (+ (node-depth parent-node) 1))
	 (parent-state (node-state parent-node))
	 (parent-path-cost (node-path-cost parent-node))
	 (children
	  (loop
	    for op in operators 
	    nconc 
	    (loop
	      for child-state in (funcall op parent-state)
	      collect 
	      (make-node :state child-state
			 :parent-node parent-node
			 :operator op
			 :depth child-depth
			 :path-cost
			 (+ parent-path-cost
			    (funcall 
			     path-cost-function
			     (list (list parent-state op child-state)))))))))
    (increment-expand-count)
    children))

  
;;;
;;; General Search
;;;

(defun general-search (prob 
		       qing-function 
		       &key
		       depth-limit 
		       path-cost-limit)
  (declare (type problem prob) 
	   (type function qing-function)
	   (type (or fixnum nil) depth-limit)
	   (type (or fixnum nil) path-cost-limit))
  (let ((frontier (make-queue 
		   (list 
		    (make-node :state (problem-initial-state prob)
			       :parent-node nil
			       :operator nil
			       :depth 0
			       :path-cost 0))))
	(current-node nil)
	(goal-test-function (problem-goal-test prob))
	(all-operators (problem-operators prob))
	(path-cost-function (problem-path-cost-function prob)))
    (loop
      (when (empty-queue-p frontier)
	(return nil))            ; Failure!
      (setq current-node (remove-front frontier))
      (when (funcall goal-test-function (node-state current-node))
	(return current-node))   ; Success!
      (unless (or (and depth-limit 
		       (>= (node-depth current-node) depth-limit))
		  (and path-cost-limit 
		       (>= (node-path-cost current-node) path-cost-limit)))
	;; Expand a node ...
	(setq frontier
	      (funcall qing-function
		       (expand current-node all-operators path-cost-function)
		       frontier))))))


;;;
;;; Print Path
;;;

(defun print-path (end-node 
		   &optional 
		   (stream t) 
		   (state-printing-function #'prin1))
  (declare (type node end-node))
  (let ((parent-node (node-parent-node end-node)))
    (when parent-node
      (print-path parent-node stream state-printing-function)
      (format stream " => "))
    (funcall state-printing-function (node-state end-node) stream)
    stream))

    
;;;
;;; Breadth-First Search
;;;

(defun breadth-first-search (prob &key depth-limit path-cost-limit)
  (declare (type problem prob) (type (or fixnum nil) depth-limit))
  (general-search prob #'enqueue-at-end 
		  :depth-limit depth-limit :path-cost-limit path-cost-limit))


;;;
;;; Depth-First Search
;;;

(defun depth-first-search (prob &key depth-limit path-cost-limit)
  (declare (type problem prob) (type (or fixnum nil) depth-limit))
  (general-search prob #'enqueue-at-front
		  :depth-limit depth-limit :path-cost-limit path-cost-limit))