;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Basic search functions - Written by Shaul Markovitch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; General functions:
;;;;;;;;;;;;;;;;;;;;;;
(defvar *search-algorithm* 'dfs-l-search)
(defvar *succ-function* nil)
(defvar *goalp* nil)
(defvar *cost-function* #'(lambda (s1 s2) 1))
(defvar *expanded-counter* 0)
(defun succ (s)(setf *expanded-counter* (1+ *expanded-counter*))
  (funcall *succ-function* s))
(defun goalp (s)(funcall *goalp* s))
(defun cost (s1 s2)(funcall *cost-function* s1 s2))
(defun solve-problem (s)
  (setf *expanded-counter* 0)
  (multiple-value-bind (solution cost)
      (funcall *search-algorithm* s)
    (format t "~%Solution: ~a ~%Expanded: ~d  Length: ~d "
            solution *expanded-counter* (1- (length solution)))
    (when cost (format t "Cost: ~A " cost))
    (format t "~%==========================~%")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun dfs (state)
  "Basic DFS with no depth limit and no tests for cycles"
  (cond ((goalp state)(list state))
        (t (let ((childs (succ state)))
             (loop for c in childs
               for solution = (dfs c)
               do (when solution
                    (return-from dfs (cons state solution))))))))


(defun dfs-l (state depth)
  "DFS with limited depth"
  (cond ((goalp state)(list state))
        ((> depth 0)
         (let ((childs (succ state)))
             (loop for c in childs
               for solution = (dfs-l c (1- depth))
               do (when solution
                    (return-from dfs-l (cons state solution))))))))

(defun dfs-l-g (state depth parents)
  "DFS with limited depth and test for cycles."
  (cond ((goalp state)(list state))
        ((> depth 0)
         (let ((childs (succ state)))
             (loop for c in childs
               for solution = (when (not (member c parents :test
                                                 #'equalp))
                                (dfs-l-g c (1- depth)(cons state parents)))
               do (when solution
                    (return-from dfs-l-g (cons state solution))))))))

(defparameter *default-depth-limit* 20)
(defun id (state &optional (max-depth *max-id-depth*))
  "Iterative Deepening."
  (loop for d from 0 to max-depth
    for solution = (dfs-l state d)
    when solution do (return-from id solution)))

(defun node-state (node)(first node))
(defun node-parent (node)(second node))
(defun bfs (state)
  "Basic breadth-first search treating the search space as a tree"
  (let ((open (list (list state nil))))
    (loop while open
      for next-node = (pop open)
      do
       (when (goalp (first next-node))
         (return-from bfs (reverse (trace-back next-node))))
       (setf open (nconc open
                         (loop for s in (succ (first next-node))
                           collect (list s next-node)))))))

(defun find-state (state s-list)
  (find state s-list :test #'equalp :key #'node-state))

(defun bfs-g (state)
  "Breadth-first search treating the search space as a graph, i.e.,
   testing for duplicate nodes."
  (let ((open (list (list state nil)))(close nil))
    (loop while open
      for next-node = (pop open)
      do
       (when (goalp (node-state next-node))
         (return-from bfs-g (reverse (trace-back next-node))))
       (push next-node close)
       (setf open
          (nconc open
             (loop for s in (succ (node-state next-node))
               when (not (or (find-state s open)(find-state s close)))
               collect (list s next-node)))))))

(defun dfs-l-search (s &optional (depth *default-depth-limit*))
  (dfs-l s depth))
(defun dfs-l-g-search (s &optional (depth *default-depth-limit*))
  (dfs-l-g s depth nil))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; trace-back.
;;; Gets a node, returns a list of states to the initial-state.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun trace-back (node)
  (cond ((null node ) nil)
	(t (cons (node-state node)(trace-back (node-parent node))))))

(defun node-g (node)(third node))
(defun uniform-cost (s)
  (let ((open (list (list s nil 0)))(close nil))
    (loop while open
      for next-node = (pop open)
      do
       (when (goalp (first next-node))
         (return-from uniform-cost
           (values (reverse (trace-back next-node))(node-g next-node))))
       (push next-node close)
       (loop for s in  (succ (node-state next-node))
         when (not (find-state s close))
         do (let ((new-g (+ (node-g next-node)
                            (cost (node-state next-node) s)))
                  (old-node (find-state s open)))
              (cond (old-node
                     (when (< new-g (node-g old-node))
                       (insert (update-node old-node next-node new-g)
                               (delete old-node open) #'node-g)))
                    (t (setf open (insert (list s next-node new-g)
                                          open #'node-g)))))))))
                                 
(defun update-node (node new-parent new-g)
  (setf (second node) new-parent (third node) new-g) node)

(defun insert (node a-list access-func)
  (cond ((null a-list)(list node))
        ((< (funcall access-func node)
            (funcall access-func (first a-list)))
         (cons node a-list))
        (t (cons (first a-list)(insert node (rest a-list) access-func)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Domains
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Cannibals and missionaries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *can-operators* '((-1 0 1 0) (-2 0 2 0)(-1 -1 1 1)(0 -1 0 1)(0 -2 0 2)))
(defun opp (op)(case op (+ '-)(- '+))) 
(defun can-succ (state)
  (loop for o in *can-operators*
       for s = (mapcar #'+ (first state) (mapcar (second state) o))
       when (legal-state s) collect (list s (opp (second state)))))
(defun legal-state (s)
  (and (notany #'(lambda (cm)(< cm 0)) s)
       (or (zerop (first s))(>= (first s)(second s)))
       (or (zerop (third s))(>= (third s)(fourth s)))))
(defun can-goalp (state)(and (zerop (caar state))(zerop (cadar
                                                         state))))
(defun ticket-cost (s1 s2)(+ (abs (- (caar s1)(caar s2)))
                             (abs (- (cadar s1)(cadar s2)))))

(defun setup-can ()
  (setf *goalp* #'can-goalp
        *succ-function* #'can-succ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; jars
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; jar-succ
;;; The successor function for the jar problem space.  Gets a jar
;;; state and returns the list of next states.  To be sure that the
;;; volume of the water in all jars will be known after the operation,
;;; we consider only one type of operation: pouring water from one
;;; container to the other until either the second is full or the
;;; first is empty.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *jars*  '(10000 5 3) )
(defun jar-succ (state)
  (loop for jar1 in state for j1 from 0	
	append
	(loop for jar2 in state for j2 from 0
	      for capacity in *jars*
	      when (and (not (eql j1 j2))
			(not (zerop jar1))
			(< jar2 capacity))
	      collect
	      (let ((new-state (copy-list state))
		    new-jar1 new-jar2)
		(cond ((<= jar1 (- capacity jar2))
		       (setf new-jar1 0
			     new-jar2 (+ jar2 jar1)))
		      (t (setf new-jar1 (- jar1 (- capacity jar2))
			       new-jar2 capacity)))
		(setf (elt new-state j1) new-jar1)
		(setf (elt new-state j2) new-jar2)
		new-state))))

(defparameter *jars-target* 4)
(defun jars-goalp (s)(member *jars-target* s :test #'=))


(defun setup-jars ()
  (setf *goalp* #'jars-goalp
        *succ-function* #'jar-succ))

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