EK201 HAND OUT #10 APRIL 6, 1987

  Time: 7:30-9:30 MON, 7:30-8:30 WED
  Instructor: George Carrette
  Office:     room 171, sociology building
  Hours:      6:30-7:30 Wed, on-line during evening hours

Lecture topics:

 * PUSH and POP used on structure references.

Two problems solved by tree search.
 * NQUEENS
 * Farmers Problem

Homework: (due Monday april 13'th)
 * complete the Farmers problem and print out the
   solution, by writing FARMERS-STATUS-CHILDREN
   and using the modified version of VISIT etc
   in addition to ~gjc/search.l
 * write a function FARMERS-STATUS-PATH-INTO-MOVES
   to take a final winning status path and convert
   it to a list of moves of the form:
   ((farmer goat) (farmer) (farmer cabbage) ...)
   That is, farmer takes goat across, farmer comes back
   across alone, farmer takes cabbage across, ...

Lets modify our VISIT function to take an extra
argument, a VISIT-NODE object.

(defun visit-node (visitor node level)
  (funcall (operation visitor 'visit-node) visitor node level))

(defprop symbol funcall visit-node)

(defun print-node (node level)
  (format t "~&~D = ~S~%" level (node-name node)))
		   
(defun visit (tree visitor qt cutoff)
  (let ((q (make-queue qt)))
    (queue-in (cons tree 0) q)
    (do ()
	((queue-empty q))
      (let ((n (queue-out q)))
	(visit-node visitor (car n) (cdr n))
	(when (or (not cutoff)
		  (< (cdr n) cutoff))
	  (dolist (c (node-children (car n)))
	    (queue-in (cons c (1+ (cdr n))) q)))))))

* The NQUEENS problem: Place N queens on an NxN chess board
  so that no queen attacks another. We can think of this as
  a search over a decision tree. There are N^2 places to place
  the first queen, (N^2)-1 to place the second, etc.
   or  product((n^2)-j,j,0,n-1) ends of the tree to consider.
  But this is much more than we need to look at. We know that
  each queen must be on its own row, so we only have to look
  at most at N^N. Which is still a lot (16 million for N=8).
  Instead, consider a legal position (no queens attacking)
  as a NODE, and all legal next positions with one more queen
  as the NODE-CHILDREN. This is the tree we have to search,
  and we can solve this problem if we simply write the function
  NQUEENS-NODE-CHILDREN.

(defstruct (nqueens #+lispm :named
		    #+lispm (:print "#<NQUEENS ~S>" (nqueens-queens nqueens)))
  nqueens-board-size
  nqueens-queens)

(defprop nqueens nqueens-node-name node-name)
(defprop nqueens nqueens-node-children node-children)

(defun nqueens-node-name (q)
  (nqueens-queens q))

;; we represent the queens as a list of (x-position y-position)
;; zero-based.

(defun nqueens-node-children (q)
  (let ((queens (nqueens-queens q))
	(size (nqueens-board-size q)))
    (let ((next-y (length queens)))
      (cond ((= next-y size)
	     ())
	    ('else
	     (do ((children nil)
		  (x 0 (1+ x)))
		 ((= x size)
		  children)
	       (or (nqueens-attack x next-y queens)
		   (push (make-nqueens
			   nqueens-board-size size
			   nqueens-queens (cons (list x next-y) queens))
			 children))))))))

(defun nqueens-attack (x y l)
  (let ((x+y (+ x y))
	(x-y (- x y)))
    (dolist (q l)
      (let ((xq (car q))
	    (yq (cadr q)))
	(and (or (= x xq) (= y yq)
		 (= x+y (+ xq yq)) (= x-y (- xq yq)))
	     (return t))))))

;; Now, this would print all intermediate steps to the
;; solution, and lastly the solutions:

(defun solve-nqueens-test (size)
  (visit (make-nqueens nqueens-board-size size)
	 'print-node
	 'fifo
	 nil))

;; Lets try it for Size 0,1,3,4
(solve-nqueens-test 0)
0 = NIL ;; one solution, an empty board!

(solve-nqueens-test 1)
0 = NIL
1 = ((0 0))  ;; one solution.

(solve-nqueens-test 2)
0 = NIL
1 = ((1 0))
1 = ((0 0)) 
;; notice, this never gets to level 2, therefore there is no
;; solution.

(solve-nqueens-test 4)
0 = NIL
1 = ((3 0))
1 = ((2 0))
1 = ((1 0))
1 = ((0 0))
2 = ((1 1) (3 0))
2 = ((0 1) (3 0))
2 = ((0 1) (2 0))
2 = ((3 1) (1 0))
2 = ((3 1) (0 0))
2 = ((2 1) (0 0))
3 = ((2 2) (0 1) (3 0))
3 = ((3 2) (0 1) (2 0))
3 = ((0 2) (3 1) (1 0))
3 = ((1 2) (3 1) (0 0))
4 = ((1 3) (3 2) (0 1) (2 0)) ;; solution 1
4 = ((2 3) (0 2) (3 1) (1 0)) ;; solution 2.

;; But what we would really like is to only print out
;; solutions, not intermediate results. And print the
;; solutions out like a chess board. And lastly return
;; a list of the solutions. We can do all this by using
;; our own special using a node visitor object.

(defstruct (nqueens-node-visitor #+lispm :named)
  nqueens-node-visitor-solutions)

(defprop nqueens-node-visitor visit-nqueens-node visit-node)

(defun visit-nqueens-node (visitor node level)
  (cond ((= level (nqueens-board-size node))
	 (push node (nqueens-node-visitor-solutions visitor))
	 (format t "~&Solution ~D:~%"
		 (length (nqueens-node-visitor-solutions visitor)))
	 (pretty-print-nqueens node))))

(defun pretty-print-nqueens (board)
  (let ((size (nqueens-board-size board))
	(moves (reverse (nqueens-queens board))))
    (dolist (m moves)
      (dotimes (j size)
	(if (= j (car m))
	    (princ " Q")
	  (princ " _")))
      (terpri))
    (terpri)))

(defun solve-nqueens (size)
  (let ((v (make-nqueens-node-visitor)))
    (visit (make-nqueens nqueens-board-size size)
	   v
	   'lifo ;; depth first search will give first solution faster
	   nil)
    (nqueens-node-visitor-solutions v)))

		       
(solve-nqueens 4)
Solution 1:
 _ Q _ _
 _ _ _ Q
 Q _ _ _
 _ _ Q _

Solution 2:
 _ _ Q _
 Q _ _ _
 _ _ _ Q
 _ Q _ _

(#<NQUEENS ((1 3) (3 2) (0 1) (2 0))> #<NQUEENS ((2 3) (0 2) (3 1) (1 0))>)

*** FARMERS PROBLEM ***

He has a FOX, GOAT, CABBAGE, and needs to take a boat from SHORE-1 to SHORE-2.

Problem: Boat only holds him and one item.
         FOX eats goat and GOAT eats cabbage when left alone.

The state or status of the problem at any point can be expressed:

(defstruct (farmers-status #+lispm :named)
  farmers-status
  fox-status
  goat-status
  cabbage-status)

(defprop farmers-status farmers-status-name node-name)
(defprop farmers-status farmers-status-next node-children)

The problem is to find a path starting at the state of everything on
SHORE-1 to everything on SHORE-2. To do this we introduce another
structure for FORWARD-PATH.

(defstruct (forward-path #+lispm :named)
  forward-path-nodes)

(defprop forward-path forward-path-name node-name)
(defprop forward-path forward-path-children node-children)

(defun forward-path-name (p)
  (mapcar #'node-name (reverse (forward-path-nodes p))))

;; A forward path is one that never crosses back on a node,
;; so we need the concept of NODE-EQUAL to make sure of that.

(defun node-equal (n1 n2)
  (funcall (operation n1 'node-equal) n1 n2))

(defprop symbol eq node-equal)

(defun forward-path-children (p)
  (let ((children)
	(l (forward-path-nodes p)))
    (cond ((null l)
	   ())
	  ('else
	   (dolist (c (node-children (car l)))
	     (do ((n l (cdr n)))
		 ((null n)
		  (push (make-forward-path forward-path-nodes (cons c l))
			children))
	       (if (node-equal c (car n))
		   (return nil))))
	   children))))

  
;; On a test graph like this:
;; 
;; A ---- B
;; !      !
;; !      !
;; C ---- D ---- E 

(defprop a (c b) children)
(defprop b (a d) children)
(defprop c (a d) children)
(defprop d (c b e) children)
(defprop e (d) children)

(visit (make-forward-path forward-path-nodes '(a)) 'print-node 'fifo nil)

0 = (A)
1 = (A B)
1 = (A C)
2 = (A B D)
2 = (A C D)
3 = (A B D E)
3 = (A B D C)
3 = (A C D E)
3 = (A C D B)

;; The solution to the farmers problem is then:

(defstruct (farmers-solution-finder #+lispm :named)
  farmers-solutions)

(defun solve-farmers-problem ()
  (let ((v (make-farmers-solution-finder)))
    (visit (make-forward-path
	     forward-path-nodes
	     (list (make-farmers-status
		     farmers-status 'shore-1
		     fox-status 'shore-1
		     goat-status 'shore-1
		     cabbage-status 'shore-1)))
	   v
	   'lifo
	   nil)
    (farmers-solutions v)))

;; With the following helper functions

(defprop farmers-solution-finder farmers-solution-visit visit-node)

(defun farmers-solution-visit (v path level)
  (let ((nodes (forward-path-nodes path)))
    (cond ((not nodes))
	  ((and (eq (farmers-status (car nodes)) 'shore-2)
		(eq (fox-status (car nodes)) 'shore-2)
		(eq (goat-status (car nodes)) 'shore-2)
		(eq (cabbage-status (car nodes)) 'shore-2))
	   (print-node path level)
	   (push path (farmers-solutions v))))))

(defun farmers-status-name (x)
  (list (list 'farmer (farmers-status x))
	(list 'fox (fox-status x))
	(list 'goat (goat-status x))
	(list 'cabbage (cabbage-status x))))


(defprop farmers-status farmers-status-equal node-equal)

(defun farmers-status-equal (n1 n2)
  (and (eq (farmers-status n1) (farmers-status n2))
       (eq (fox-status n1) (fox-status n2))
       (eq (goat-status n1) (goat-status n2))
       (eq (cabbage-status n1) (cabbage-status n2))))