;;; The caller must supply a plunk-generator
;;;   if there are units, for example.

(define (algebraic-solver plunk-generator #!optional plunk-chooser)
  (if (default-object? plunk-chooser) (set! plunk-chooser car))
  (let ((*plunked-variables* '())
	(*equations* '()))

    (define (numerical-quantities-equal? x y)
      (let ((x (u:value x)) (y (u:value y)))
	(if (and (number? x) (number? y))
	    (= x y)
	    (let ((z (new-simplify (- x y))))
	      (zero? (expression z))))))

    (define (choose-numerical-quantity ns)
      (or (find-matching-item ns number?)
	  (find-matching-item ns (lambda (n) (symbol? (expression n))))
	  (car ns)))

    (define (plunk-connector connector)
      (if (cp:has-value? connector)
	  (error "Connector has a value -- plunk" connector))
      (let ((new-variable
	     (if plunk-generator
		 (plunk-generator connector)
		 (symbol "x-" (cp:connector-name connector)))))
	(set! *plunked-variables*
	      (cons (cons new-variable connector)
		    *plunked-variables*))
	(cp:assume-value connector new-variable)))

    (define (coincidence-handler connector value justify)
      (let ((old-value (cp:value-of connector)))
	(let* ((residual (new-simplify (- value old-value)))
	       (resi (expression (u:value residual))))
	  (if (number? resi)
	      (if (= resi 0)
		  (justify (cp:supported-assignment connector))
		  (cp:set-contradiction connector value justify))
	      (let* ((residual
		      (if (quotient? resi)
			  (symb:dividend resi)
			  resi))
		     (same-equation
		      (find-matching-item *equations*
			(lambda (eqn)
			  (let ((expr
				 (expression (u:value (equation-expression eqn)))))
			    (number? (new-simplify (/ expr resi))))))))
		(if same-equation
		    (let ((current-assignment (cp:supported-assignment connector)))
		      (tms:justify-node
		       (car (equation-justifications same-equation))
		       'additional
		       (list (cp:set-justified-value connector value justify)
			     current-assignment)))
		    (let ((current-assignment (cp:supported-assignment connector)))
		      (let ((equation
			     (make-equation
			      residual
			      (list (cp:set-justified-value connector value justify)
				    current-assignment))))
			(if equation
			    (set! *equations* (cons equation *equations*))))
		      )))))))

    (define (post-propagation-processor network)
      (and (pair? *equations*)
	   (let* ((results
		   (solve-incremental
		    (keep-matching-items *equations* equation-supported?)
		    (map car
			 (keep-matching-items *plunked-variables*
			   (lambda (varpair)
			     (eq? (cp:value-of (cdr varpair))
				  (car varpair)))))))
		  (substitutions (caddr results)))
	     (for-each (lambda (subst)
			 (let ((var (substitution-variable subst))
			       (expr (substitution-expression subst))
			       (justs (substitution-justifications subst)))
			   (cp:set-justified-value
			    (plunked-connector var)
			    expr
			    (lambda (node)
			      (tms:conditional-justification
			       node
			       'equation-solver
			       justs
			       (map plunk-assignment
				    (plunked-vars-not-in expr)))))))
		       substitutions)))
      (and *complete-propagation*
	   (let ((unassigned-connectors
		  (delete-matching-items (cp:network-connectors network)
		    cp:has-value?)))
	     (and (pair? unassigned-connectors)
		  (cp:plunk-connector (plunk-chooser unassigned-connectors)))
	     )))

    (define (plunk-assignment var)
      (find-matching-item
	  (cp:connector-assignments (plunked-connector var))
	(lambda (assignment)
	  (eq? var (cp:assignment-value assignment)))))

    (define (plunked-connector var)
      (let ((entry (assoc var *plunked-variables*)))
	(if (not entry)
	    (error "Not a plunked variable." var))
	(cdr entry)))

    (define (plunked-vars-in expr)
      (cond ((pair? expression)
	     (list-union (plunked-vars-in (car expression))
			 (plunked-vars-in (cdr expression))))
	    ((assq expression *plunked-variables*) expression)
	    (else '())))

    (define (plunked-vars-not-in expr)
      (list-difference (map car *plunked-variables*)
		       (plunked-vars-in expr)))

    (lambda (message)
      (case message
	((membership) numerical-quantity?)
	((equality) numerical-quantities-equal?)
	((choose-value) choose-numerical-quantity)
	((coincidence-handler) coincidence-handler)
	((post-propagation-processor) post-propagation-processor)
	((value-model)
	 (cp:make-value-model numerical-quantity?
			      numerical-quantities-equal?
			      choose-numerical-quantity
			      coincidence-handler
			      post-propagation-processor))
	((plunk-connector) plunk-connector)
	((plunked-variables) *plunked-variables*)
	((equations) *equations*)
	(else (error "algebra: Unknown message:" message))))
    ))

(define *complete-propagation* #f)

(define (equation-supported? equation)
  (for-all? (cadr equation) tms:node-supported?))