;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- File: search/algorithms/repeated

;;;; Search Algorithms That Avoid Repeated States

;;; In this file we show algorithms that worry about repeated states.
;;; Here are the three ways to deal with repeated states, from [p 82]:

(defun eliminate-returns (nodes)
  "Get rid of nodes that return to the state they just came from,
  i.e., where the last two actions just undo each other."
  (remove-if #'return-node? nodes))

(defun eliminate-cycles (nodes)
  "Get rid of nodes that end in a state that has appeared before in the path."
  (remove-if #'looping-node? nodes))

(defun eliminate-all-duplicates (nodes node-table)
  "Get rid of all nodes that have been seen before in any path."
  (let ((result nil))
   (for each node in nodes do
	(let ((state (node-state node)))
	  (when (not (gethash state node-table))
	    (push node result))
	  (setf (gethash state node-table) node)))
   result))

;;; Here are examples of search algorithms that use these methods.  In
;;; retrospect, a better organization would have been to have GENERAL-SEARCH
;;; take two arguments, a problem and a strategy, where the strategy would
;;; have a queueing function and an expansion function as components.  That
;;; way, we wouldn't have EXPAND generate nodes that we are just going to
;;; throw away anyway.

(defun no-cycles-depth-first-search (problem)
  "Do depth-first search, but eliminate paths with repeated states."
  (general-search problem
		  #'(lambda (old-q nodes)
		      (enqueue-at-front old-q (eliminate-cycles nodes)))))

(defun no-returns-breadth-first-search (problem)
  "Do breadth-first search, but eliminate immediate returns to a prior state."
  (general-search problem
		  #'(lambda (old-q nodes)
		      (enqueue-at-end old-q (eliminate-returns nodes)))))
			      
(defun no-duplicates-breadth-first-search (problem)
  "Do breadth-first search, but eliminate all duplicate states."
  (let ((table (make-hash-table :test #'equal)))
    (general-search problem
		    #'(lambda (old-q nodes)
			(enqueue-at-end old-q (eliminate-all-duplicates
					       nodes table))))))

(defun A*-search (problem)
  "Search the nodes with the best f cost first.  If a node is ever reached by
  two different paths, keep only the better path."
  (general-search problem (make-eliminating-queuing-fn #'node-f-cost)))

(defun make-eliminating-queuing-fn (eval-fn)
  (let ((table (make-hash-table :test #'equal)))
    #'(lambda (old-q nodes)
	(enqueue-by-priority
	 old-q
	 (let ((result nil))
	  (for each node in nodes do
	       (let ((old-node (gethash (node-state node) table)))
		 (cond
		  ((null old-node)
		   ;; First time we've reached state; just return node
		   (setf (gethash (node-state node) table) node)
		   (push node result))
		  ((<= (funcall eval-fn old-node) (funcall eval-fn node))
		   ;; If the old node is better, discard the new node
		   nil)
		  (t;; Otherwise, discard the old node
		   (setf (node-expanded? old-node) t)
		   (setf (gethash (node-state node) table) node)
		   (push node result)))))
	  (nreverse result))
	 eval-fn))))


;;;; Auxiliary Functions

(defun looping-node? (node &optional (depth infinity))
  "Did this node's state appear previously in the path?"
  ;; Search up to DEPTH nodes deep in the path
  (let ((n (node-parent node)))
    (for i = 1 to depth do
	 (when (null n) (return nil))
	 (when (equal (node-state node) (node-state n)) (return t))
	 (setf n (node-parent n)))))

(defun return-node? (node)
  "Is this a node that returns to the state it just came from?"
  (looping-node? node 2))