;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Iterative deepening search

;;; Structure for holding information for each node

(defstruct (node (:print-function print-node))
  (state nil)				;state of problem for this node
  (parent nil)				;pointer to parent node structure
  (action nil)
  (depth 0))				;depth, for depth-limited search

;;;Define this mainly so printing won't attempt to follow parent links
(defun print-node (node stream depth)
  (format stream "~&Node ~s ~s " (node-state node) (node-action)))

(defun tree-search-iterative-deepening (initial-state goalp successors
					node-key want-path)
  "
 (tree-search-iterative-deepening initial-state goalp successors node-key want-path)
    initial-state   a lisp form that represents the first state
    goalp           a function that accepts a state and returns t or nil
    successors      a function that accepts a state and returns a list of successor states
    node-key        a function that accepts a node and returns the state or any
                     other lisp form that represents the search result
    want-path       t or nil, specifying whether or not the full path is wanted

   returns the path or final state representation, formed by node-key"
  ;; Repeat for depths of 1, 2, 3, until goal found or user terminates
  (loop for d from 1
      ;; Do depth-first-search limited to depth d
      for answer = (tree-search-depth-first-limited 
		    (list (make-node :state initial-state))
		    goalp successors d)
      ;; Stop when search returns non-nil
      until (not (null answer))
      ;; When goal found, return full path if wanted. Otherwise, just return final state
      finally (return (if want-path
			  ;; Build full path by backtracking from goal to start through
			  ;; #'node-parent, then reverse resulting list
			  (reverse (loop for n = answer then (node-parent n)
				       until (null n)
				       collect (funcall node-key n)))
			;;else
			(funcall node-key answer)))))

(defun tree-search-depth-first-limited (queue goalp successors limit)
  "
  (tree-search-depth-first-limited queue goalp successors limit)
    queue           a list containing nodes
    goalp           a function that accepts a state and returns t or nil
    successors      a function that accepts a state and returns a list of successor states
    node-key        a function that accepts a node and returns the state or any
                     other lisp form that represents the search result
    want-path       t or nil, specifying whether or not the full path is wanted

   returns the path or final state representation, formed by node-key"

  (cond
   ;; If no more paths to explore in queue, quit and return nil
   ((endp queue) nil)
   ;; If first state on queue is the goal, return the path
   ((funcall goalp (node-state (first queue))) (first queue))
   ;; If first path has reached depth limit, discard it and continue with
   ;; next one in the queue
   ((>= (node-depth (first queue)) limit)
    (tree-search-depth-first-limited (rest queue) 
				     goalp successors limit))
   ;; Otherwise, expand the current state in the first path, combine with
   ;; the remaining paths in the queue, and search again.
   (t (tree-search-depth-first-limited 
       (append (mapcar #'(lambda (s) (make-node 
				      :state s :parent (first queue)
				      :depth (1+ (node-depth (first queue)))))
		       (funcall successors (node-state (first queue))))
	       (rest queue))
       goalp successors limit))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;tree-search-iterative-deepening assumes the node structure has
;;; at least these slots.  More can be added if your problem needs them


(defun findpath (start goal map)
  (let ((path (tree-search-iterative-deepening
	       ;; initial state
	       start
	       ;; goalp
	       #'(lambda (s) (eql s goal))
	       ;; successors
	       #'(lambda (state) (cdr (assoc state map))))))
    (loop for n in path
	collect (node-state n))))

;;;(findpath 'a 'z '((a b c d z) (b e f) (c g h) (d i j) (e k z)))
;;;  returns (A Z)

;;;(findpath 'a 'e '((a b c d z) (b e f) (c g h) (d i j) (e k z)))
;;;  returns (A B E)


(defun all-ways-to-replace-atoms (exp)
  (cond ((atom exp) `((+ ,exp 1) (+ ,exp n)
				 (- ,exp 1) (- 1 ,exp) (- ,exp n) (- n ,exp)
				 (* ,exp n)
				 (/ 1 ,exp) (/ ,exp n) (/ n ,exp)
				 (expt ,exp n) (expt n ,exp)))
	(t (nconc 
	    (mapcar #'(lambda (z) (list (first exp) z (third exp)))
		    (all-ways-to-replace-atoms (second exp)))
	    (mapcar #'(lambda (z) (list (first exp) (second exp) z))
		    (all-ways-to-replace-atoms (third exp)))))))

(defun predict (sequence)
  (let* ((exp (tree-search-iterative-deepening
	      ;; initial state
	       1
	       ;; goalp
	       #'(lambda (exp) 
		   (let ((fn `(lambda (n) (ignore-errors ,exp))))
		     (loop for i from 0 below (length sequence)
			 always (eql (nth i sequence) (funcall fn i)))))
	       ;; successors
	       #'(lambda (exp) (all-ways-to-replace-atoms exp))
	       ;; node-key
	       #'node-state
	       ;; want-path
	       nil))
	 (fn `(lambda (n) (ignore-errors ,exp))))
    (list exp (funcall fn (length sequence)))))

;(predict '(1 2 3))