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