;;;; "British Museum Algorithm" Problem Solver
;;; This is the dumbest possible problem solver.

(define ((rule-solver the-rules satisfied?) initial)
  (let expr-lp ((possible (list initial)))
    (if (null? possible)
	#f
	(let rule-lp ((rules the-rules) (results '()))
	  (if (null? rules)
	      (expr-lp (append (cdr possible) results))
	      (let ((first-results
		     (one-step-expression (car rules)
					  (car possible))))
		(cond ((null? first-results)
		       (rule-lp (cdr rules) results))
		      ((find-matching-item first-results
			                   satisfied?))
		      (else
		       (rule-lp (cdr rules)
				(append first-results
					results))))))))))

;;; Returns a list of the results of applying the rule to an
;;; expression and all subexpressions of the expression.

(define (one-step-expression rule expression)
  (let ((result (rule expression)))
    (if result
	(cons (canonical-copy result)
	      (one-step-subexpressions rule expression))	
	(one-step-subexpressions rule expression))))

(define (one-step-subexpressions rule subexpressions)
  (if (list? subexpressions)
      (let ((sub-results
	     (map (lambda (subexpression)
		    (one-step-expression rule subexpression))
		  subexpressions)))
	(if (not (for-all? sub-results null?))
	    (all-sequences
	     (map (lambda (subexpression sub-result)
		    (if (null? sub-result)
			(list subexpression)
			sub-result))
		  subexpressions
		  sub-results))
	    '()))
      '()))

(define (all-sequences lst)
  (if (null? lst)
      '(())
      (let ((subs
	     (all-sequences (cdr lst))))		    
	(append-map (lambda (x)
		      (map (lambda (sub)
			     (cons x sub))
			   subs))
		    (car lst)))))

#|
(all-sequences '((1 2) (a) (d e f)))
;Value: ((1 a d) (1 a e) (1 a f) (2 a d) (2 a e) (2 a f))
|#