;;; bf-search.lisp
;;; Perform a breadth-first search in some search space.
;;; Copyright (C) Jens G Jensen 1999
;;; Created on: Sun Apr 11 13:44:18 MEST 1999
;;; Revised on: Sun Apr 18 09:12:57 MEST 1999
;;; License: GNU GPL (http://www.gnu.org/copyleft/gpl.html)
;;; Warranty: _none_ _whatsoever_; see above reference.


(defun bf-search (init-state rule-list goalp
			     &key (test #'equal) path all (limit 541))
  "*Perform a breadth-first search.  (Version 1.2)
Synopsis:
 (bf-search init-state rule-list goal-function [keys])

 ([keys] means that the keys (see below) are optional.)

  A *state* should be some Lisp type; *init-state* should be the one
from which the search starts.  The *set of rules* should be a list of
functions or lambda expressions; each should take a single state as an
argument and return a (possibly empty) list of states that can be
reached from the given state.  They may not modify their argument.

  The *goal* specifier should be a function or lambda expression that
takes a state as an argument and returns a boolean value; however, if
:path is true, it should take the _reverse_ _path_ as argument (such
that the current state is the `car').  It may not modify its argument.

  Additionally, the following keywords are recognized:

:test specifies a function that should take two states as arguments
and return true if and only if they should be considered equal.  The
default value is #'equal.

:path specifies whether the full *reverse* path should be passed to
the goal-function, or just the current state.  The default value is
nil, meaning just the current state.

:all means find all solutions.  This only makes sense in a finite
search space.  The default value is nil.

:limit is a value intended to safeguard against infinite searches.
Every time the limit is reached, the program will stop and display
a message.  You can then abort the search or continue.  A negative
value or nil means no limit.  The default value is 541.

  The return value depends on the :all keyword.  If :all is nil, the
first (i.e, shortest) path to a solution will be returned if one exists,
otherwise nil will be returned.  If :all is true, the full list of
solutions will be returned (finite search-spaces only!) in the order
they were found (ie., best first).  (Note that while each list is
freshly cons'ed, for efficiency reasons a state is never copied, so the
states appearing in each solution will (probably) be eq.)"
  (if (not (numberp limit)) (setq limit -1))
  ;; main loop
  (do*
      ((solutions nil)
       (iter 0 (1+ iter))
       (queue (list (list init-state)) (cdr queue))
       (queue-tail queue)
       ;; a node is a cons cell (state . ptr-to-parent)
       ;; so a node is really a reverse path
       (node (car queue) (car queue))
       (state (car node) (car node))
       (been-there (cons node nil) (cons node been-there)))
      ((endp queue) (nreverse solutions))
    (when (= iter limit) (break) (setq iter 0))
    (do* ((states (mapcan
		   #'(lambda (rule) (funcall rule state))
		   rule-list)
		  (cdr states))
	  (state (car states) (car states))
	  (eek))
	((endp states))
      ;; from states remove duplicates and those
      ;; appearing in been-there and queue, and the goals
      (unless (or (assoc state been-there :test test)
		  (member state (cdr states) :test test)
		  (assoc state queue :test test)
		  ;; hairy bit, but workink when searchink exhaustively
		  (when
		      ;; from this point, we very probably need a new
		      ;; node and `eek' gets to hold it
		      (progn
			(setq eek (cons state node))
			(funcall goalp (if path eek state)))
		    (if all
			(setq solutions (cons (reverse eek) solutions))
		      (return-from bf-search (nreverse eek)) )))
	(rplacd queue-tail (cons eek nil))
	(setq queue-tail (cdr queue-tail)) )  )  ))


;;; Example: the water-jug problem.
;;; Two jugs can hold, respectively, 4 liters and 3 liters.
;;; Goal: put two liters into the 4-liter jug (in as few moves as possible).
;;; Rules: either jug can be filled completely or emptied completely,
;;; or water can be poured from one to the other until either the
;;; former is empty or the latter is full, whichever happens first.

;;; The state: a cons cell (a . b) where `a' and `b' are integers
;;; and `a' is the amount of water in the 4-liter jug.

;;; Call this as (bf-search wj-init-state wj-rules #'wj-goal-p) and
;;; see what happens.

(setq wj-init-state '(0 . 0))

(setq wj-rules
      ;; fill first jug, note rule returns a list
      '((lambda (s) (list (cons 4 (cdr s))))
	;; fill second jug
	(lambda (s) (list (cons (car s) 3)))
	;; empty either jug (this time as one rule)
	(lambda (s) (list (cons 0 (cdr s)) (cons (car s) 0)))
	;; pour water from second to first; returns () if not possible
	(lambda (s) (if (or (= (car s) 4) (zerop (cdr s))) nil
		      (list (cons (min (+ (car s) (cdr s)) 4)
				  (max (+ (car s) (cdr s) -4) 0)))))
	;; pour water from first to second; returns () if not possible
	(lambda (s) (if (or (= (cdr s) 3) (zerop (car s))) nil
		      (list (cons (max (+ (car s) (cdr s) -3) 0)
				  (min (+ (car s) (cdr s)) 3))))) ))

(defun wj-goal-p (s) (equal s '(2 . 0)))