;;; bf-search --- perform a breadth-first search
;;; specified by a goal, a set of rules, an initial state,
;;; and an (optional) compare-function.

;;; Copyright (C) 1999 Jens G Jensen
;;; Author: Jens G Jensen <jens@math.u-strasbg.fr>
;;; Created: Wed Apr  7 19:52:05 MEST 1999
;;; Version: 1.1
;;; License: GPL
;;; (Type `M-x describe-copying' in Emacs to see the details.)
;;; Warranty: none
;;; (Type `C-h C-w' in Emacs for details.)

;;; See example at end of file


(and
 (fboundp 'equalp)
 (equalp '(0) '(1))
 (progn (princ "Your equalp is broken; fixing...\n") t)
 (defun equalp (x y)
  "T if two Lisp objects have similar structures and contents.
This is like `equal', except that it accepts numerically equal
numbers of different types (float vs. integer), and also compares
strings case-insensitively."
  (cond ((eq x y) t)
	((stringp x)
	 (and (stringp y) (= (length x) (length y))
	      (or (string-equal x y)
		  (string-equal (downcase x) (downcase y)))))   ; lazy but simple!
	((numberp x)
	 (and (numberp y) (= x y)))
	;; Dave Gillespie's fix
	((consp x)
	 (while (and (consp x) (consp y) (equalp (car x) (car y)))
	   (cl-pop x) (cl-pop y))
	 (and (not (consp x)) (equalp x y)))
	((vectorp x)
	 (and (vectorp y) (= (length x) (length y))
	      (let ((i (length x)))
		(while (and (>= (setq i (1- i)) 0)
			    (equalp (aref x i) (aref y i))))
		(< i 0))))
	(t (equal x y)))) )


(defun bf-search (init-state rule-list goalp &optional eqlp)
  "*Perform a breadth-first search.  (Version 1.1)
Synopsis:
 (bf-search init-state rule-list goal-function &opt compare-function)

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, each function
should take a single state as an argument and return a (possibly
empty) list of states that can be reached from the given state.

The *goal* specifier should be a function that takes a state as an
argument and returns a boolean value; if that value is nil, the search
will continue, if non-nil, the search will be aborted and the path
that led to the goal will be returned (but not which rules were
used).

The compare function should be a function of two states, returning
true if and only if they should be considered equal.  The default
value is equal.

bf-search returns the path to the goal-state (but not which rules
were used to go from one state to another), or nil if no match was
found (unless the search space is infinite, in which case bad things
may happen)."
  (or eqlp (setq eqlp #'equal))
  ;; set up "global" variables (in fact they are "special" in XElisp)
  (let* ((queue (list (list init-state))) (queue-tail queue) (been-there nil))
    (catch 'found
      ;; put functions here to avoid polluting global namespace
      (flet
	  ;; standard member function but with eqlp for comparison
	  ;; and not recursive (easier in Common Lisp)
	  ((bf-member (el ls)
		      (while
			  (not (or (endp ls) (funcall eqlp el (car ls))))
			(setq ls (cdr ls)))
		      ls)
	   (bf-assoc (el ls)
		     (while (not (or (endp ls)
				     (funcall eqlp el (caar ls))))
		       (setq ls (cdr ls)))
		     (car ls)) )
	;; main loop
	(while queue
	  ;; a node is a cons cell (state . parent)
	  (let* ((node (car queue)) (state (car node)))
	    (setq been-there (cons node been-there))
	    ;; change `state' to `node' to pass
	    ;; the reverse path to the goal function
	    (if (funcall goalp state)
		(throw 'found (nreverse node)))
	    (let ((states (mapcan
			   '(lambda (rule) (funcall rule state))
			   rule-list)))
	      (while states
		(if (or (bf-assoc (car states) been-there)
			(bf-member (car states) (cdr states))
			(bf-assoc (car states) queue))
		    ()
		  (setcdr queue-tail (cons (cons (car states) node) nil))
		  (setq queue-tail (cdr queue-tail)))
		(setq states (cdr states))) ))
	  (setq queue (cdr queue))  )  ))))


;;; Example: the water-jug problem.
;;; Two jugs can hold, respectively, 3 liters and 4 liters.
;;; Goal: put two liters into the 4-liter jug.
;;; Rules: either jug can fill completely or emptied completely,
;;; possibly into the other jug.

;;; 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) (and (= (car s) 2) (= (cdr s) 0)))

;;; For an exhaustive search (in a finite search space!), modify the
;;; bf-search code as described above and use this function as a goal
;;; function instead.  Note it prints the path *without* modifying it
;;; and returns nil ("not found") every time.

; (defun wj-goal-p (s) (if (equal (car s) '(2 . 0)) (print (reverse s))) nil)