;; This program solves the Missionaries and Cannibals Problem using
;; breadth-first search.


(setf start '(3 3 1 0 0 0))

(setf finish '(0 0 0 3 3 1))

(setf list-of-actions '((1 0 1) (0 1 1) (2 0 1) (0 2 1) (1 1 1)))

(defun breadth-first (start finish &optional
                       (queue (list (list start))))
     (cond ((endp queue) nil)
	   ((equal finish (first (first queue)))
	       (reverse (first queue)))
	   (t (breadth-first start finish
                             (append (rest queue)
			             (extend (first queue)))))))

(defun extend (path)
	(print (reverse path))
	(setf extensions (get-extensions path))
	(mapcar #'(lambda (new-node) (cons new-node path))
		(filter-extensions extensions path)))

(defun get-extensions (path)
        (if (= 1 (third (first path)))
	    (apply1-2 (first path) list-of-actions)
	    (apply2-1 (first path) list-of-actions)))

(defun filter-extensions (extensions path)
	(cond ((endp extensions) nil)
	      ((and (not (endp (first extensions)))
		    (not (member (first extensions) path :test #'equal)))
		  (cons (first extensions) 
                        (filter-extensions (rest extensions) path)))
	      (t (filter-extensions (rest extensions) path))))

(defun apply1-2 (state list-of-actions)
	(let ((valid-extensions nil))
           (dolist (action list-of-actions valid-extensions)
              (setf new-state (test-state1 state action))
	      (setf valid-extensions  (cons new-state valid-extensions)))))
		
(defun test-state1 (state action)
	(setf m1-new (- (first state) (first action)))
	(setf c1-new (- (second state) (second action)))
	(setf b1-new (- (third state) (third action)))
	(setf m2-new (+ (fourth state) (first action)))
	(setf c2-new (+ (fifth state) (second action)))
	(setf b2-new (+ (sixth state) (third action)))
        (when (and 
		  (or (> m1-new c1-new) (= m1-new 0) (= m1-new c1-new))
                  (or (> m2-new c2-new) (= m2-new 0) (= m2-new c2-new))
                  (and (not (minusp m1-new)) (not (minusp m2-new))
                       (not (minusp c1-new)) (not (minusp c2-new))))
              (list m1-new c1-new b1-new m2-new c2-new b2-new)))
            
(defun apply2-1 (state list-of-actions)
      (let ((valid-extensions nil))
        (dolist (action list-of-actions valid-extensions)
              (setf new-state (test-state2 state action))
	      (setf valid-extensions  (cons new-state valid-extensions)))))

(defun test-state2 (state action)
	(setf m1-new (+ (first state) (first action)))
	(setf c1-new (+ (second state) (second action)))
	(setf b1-new (+ (third state) (third action)))
	(setf m2-new (- (fourth state) (first action)))
	(setf c2-new (- (fifth state) (second action)))
	(setf b2-new (- (sixth state) (third action)))
        (when (and 
		  (or (> m1-new c1-new) (= m1-new 0) (= m1-new c1-new))
                  (or (> m2-new c2-new) (= m2-new 0) (= m2-new c2-new))
                  (and (not (minusp m1-new)) (not (minusp m2-new))
                       (not (minusp c1-new)) (not (minusp c2-new))))
              (list m1-new c1-new b1-new m2-new c2-new b2-new)))