Water Jug Solution

Lisp code to for goalp and new-states

;;; Solve the Water Jug problem
(in-package "USER")

(defvar *start* '(0 0))

(defun first-jug (state) (car state))
(defun second-jug (state) (cadr state))
(defun mk-state (f s) (list f s))

(defun goalp (state)
    (eq (first-jug state) 2))

(defun new-states (state)
    (remove-null
	(list
	    (fill-first state)
	    (fill-second state)
	    (pour-first-second state)
	    (pour-second-first state)
	    (empty-first state)
	    (empty-second state))))

(defun remove-null (x)
    (cond
	((null x) nil)
	((null (car x)) (remove-null (cdr x)))
	((cons (car x) (remove-null (cdr x))))))

(defun fill-first (state)
    (cond
	((< (first-jug state) 4) (mk-state 4 (second-jug state))))))

(defun fill-second (state)
    (cond
	((< (second-jug state) 3) (mk-state (first-jug state) 3))))


(defun pour-first-second (state)
    (let (   (f (first-jug state))
	     (s (second-jug state)))
	(cond
	    ((zerop f) nil)		; Cant pour nothing
	    ((= s 3) nil)		; Second full
	    ((<= (+ f s) 3)		; Empty first into second
		(mk-state 0 (+ f s)))
	    (t				; Fill second from first
		(mk-state (- (+ f s) 3) 3)))))

(defun pour-second-first (state)
    (let (   (f (first-jug state))
	     (s (second-jug state)))
	(cond
	    ((zerop s) nil)		; Cant pour nothing
	    ((= f 4) nil)		; First full	    
	    ((<= (+ f s) 4)		; Empty second into first
		(mk-state (+ f s) 0))	    
	    (t				; Fill first from second
		(mk-state 4 (- (+ f s) 4))))))

(defun empty-first (state)
    (cond
	((> (first-jug state) 0) (mk-state 0 (second-jug state)))))

(defun empty-second (state)
    (cond
	((> (second-jug state) 0) (mk-state (first-jug state) 0))))

Code for Depth First Search

;;; Depth first search with state limit
(in-package "USER")

(defun dfs (state depth limit)
    (setf *nodes* 0)
    (setf *expanded* 0)
    (setf *branches* 0)
    (setf *limit* limit)
    (setf *result* (dfs1 state depth))
    (print (list *nodes* *expanded* *branches*))
    *result*
)

;;; dfs1 expands a node and calls dfs2 to recurse on it

(defun dfs1 (state depth)
    (setf *nodes* (+ 1 *nodes*))
    (cond
	((goalp state) (list state))
	((zerop depth) nil)
	((> *nodes* *limit*) nil)
	((let ((children (new-states state)))
	     (setf *expanded* (+ 1 *expanded*))
	     (setf *branches* (+ (length children) *branches*))
	     (let ((result (dfs2 children (- depth 1))))
		 (and result (cons state result)))))))

;;; dfs2 recurses on each sibling from a single node, calling dfs1
(defun dfs2 (states depth)
    (cond
	((null states) nil)
	((dfs1 (car states) depth))
	((dfs2 (cdr states) depth))))

Code for Breadth First Search

;;; Solve by breadth-first search
(in-package "USER")

(defun bfs (state limit)
    (setf *nodes* 0)
    (setf *expanded* 0)
    (setf *branches* 0)
    (setf *limit* limit)
    (setf *result* (bfs1 (list (list state))))
    (print (list *nodes* *expanded* *branches*))
    (reverse *result*))

(defun bfs1 (queue)
    (setf *nodes* (+ 1 *nodes*))
    (cond
	((null queue) nil)
	((goalp (caar queue)) (car queue))
	((> *nodes* *limit*) nil)
	((let ((children (new-states (caar queue))))
	     (setf *expanded* (+ 1 *expanded*))
	     (setf *branches* (+ (length children) *branches*))
	     (bfs1
		 (append
		     (cdr queue)
		     (mapcar
			 #'(lambda (state)
			       (cons state (car queue)))
			 children)))))))

Sample Run

;;; Sun Common Lisp, Development Environment 4.0.0 , 6 July 1990
;;; Sun-4 Version for SunOS 4.0.x and sunOS 4.1 

> (compile-file "wj.lisp")
#P"/usr2/mlm/wj.sbin"

> (compile-file "bfs")
#P"/usr2/mlm/bfs.sbin"

> (compile-file "dfs")
#P"/usr2/mlm/dfs.sbin"

> (load "wj")
> (load "dfs")
> (load "bfs")

> *start*
(0 0)

> (new-states *start*)
((4 0) (0 3))

> (dfs *start* 7 100000)
(584 206 591) 		; Branching factor 2.86 (591/206)
((0 0) (4 0) (1 3) (1 0) (0 1) (4 1) (2 3))

> (bfs *start* 100000)
(341 340 981) 		; Branching factor 2.88 (981/340)
((0 0) (4 0) (1 3) (1 0) (0 1) (4 1) (2 3))