;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The JAR example - Written by Shaul Markovitch, CS, Technion
;;;
;;; A JAR problem consists of a list of capacities (in Gallons) of
;;; containers (jars) and a target water volume.  The goal is to have
;;; one jar with exactly the goal capacity.  There is a pool of water
;;; with very large amount of water.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A jar state is represented by a list of the current volume of the
;;; water in each of the jars.  The first element represents the
;;; volume in the pool. The capacities are stored in a global variable
;;; since they do not change during the search (this was done to save
;;; memory)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *jars* nil  "should contain a list of jar capacities")
(defparameter *pool-capacity* 1000000  "The capacity of the pool")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BFS search.
;;; Gets an initial state, a goal predicate and a successor function
;;; and returns the path to the goal.  This is not the most efficient
;;; implementation (because of pedagogical reasons).  A search node is
;;; a list of two elements.  The first is the state, the second is a
;;; pointer to the parent node (to allow tracing the solution).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *trace*  nil)   ;Should be either nil or a number.  A
			      ;number N indicates to print trace each
			      ;N nodes

(defun bfs (init-state goal-predicate succ
		       &key (state-eq #'equalp))
  (let ((open (list (list init-state nil)))
	(closed nil))
    (loop while open for counter from 0
	  for next-node = (pop open)
	  for new-states = (funcall succ (first next-node))
	  do
	  (when (and *trace* (= (mod counter *trace*) 0))
		(format t
			"~%Open: ~d Closed: ~d Depth: ~d"
			(length open)(length closed)
			(length (trace-back next-node))))
	  (push (first next-node) closed)
	  (loop for s in new-states
		when (not (member s closed :test state-eq))
		do
		(let ((new-node (list s next-node)))
		  (when (funcall goal-predicate s)
			(return-from bfs (reverse (trace-back new-node))))
		  (setf open (nconc open (list new-node))))))))

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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  solve-jar
;;;  The main function.  To solve the problem of "Die Hard 3" call it
;;;  with (solve-jar '(3 5) 4)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun solve-jar (capacities goal &optional
			     (init-jars (make-list (length capacities)
						   :initial-element 0)))
  (setf *jars* (cons *pool-capacity* capacities))
  (bfs (cons *pool-capacity* init-jars)
       #'(lambda (state)(member goal state :test #'=))
       #'jar-succ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; verbal-solution
;;;
;;; Makes the solution more readable.  Can be used as follows:
;;; (verbal-sloution (solve-jar '(3 5) 4))
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun verbal-solution (solution)
  (let ((jar-namer #'(lambda (i) (if (zerop i) "the pool"
				   (format nil "jar ~D" i)))))
    (format t "~%The initial Jar setup: ~A " (rest (first solution)))
    (loop for state-before in solution
        for state-after in (rest solution)
	for step from 1
	do (let (source-index target-index amount)
	     (loop for before in state-before
	       for after in state-after
	       for index from 0
	       do (cond ((> before after)
			 (setf source-index index
			       amount (- before after)))
			((< before after)
			 (setf target-index index))))
	     (format t "~%Step ~D: ~D gallons poured from ~A to ~A. New setup: ~A"
	           step amount (funcall jar-namer source-index)
		   (funcall jar-namer target-index)
		   (rest state-after)
		   )))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Running examples:
#|
 (verbal-solution (solve-jar '(3 5) 4))
The initial Jar setup: (0 0) 
Step 1: 5 gallons poured from the pool to jar 2. New setup: (0 5)
Step 2: 3 gallons poured from jar 2 to jar 1. New setup: (3 2)
Step 3: 3 gallons poured from jar 1 to the pool. New setup: (0 2)
Step 4: 2 gallons poured from jar 2 to jar 1. New setup: (2 0)
Step 5: 5 gallons poured from the pool to jar 2. New setup: (2 5)
Step 6: 1 gallons poured from jar 2 to jar 1. New setup: (3 4)
NIL
* (verbal-solution (solve-jar '(3 5 7 4 4 3 8) 6))
The initial Jar setup: (0 0 0 0 0 0 0) 
Step 1: 3 gallons poured from the pool to jar 1. New setup: (3 0 0 0 0 0 0)
Step 2: 7 gallons poured from the pool to jar 3. New setup: (3 0 7 0 0 0 0)
Step 3: 3 gallons poured from jar 1 to jar 4. New setup: (0 0 7 3 0 0 0)
Step 4: 1 gallons poured from jar 3 to jar 4. New setup: (0 0 6 4 0 0 0)
NIL
* 
|#