(define *equations* '())

(define (coincidence-handler new-assignment old-assignment)
  (let ((connector (cp:assignment-connector old-assignment)))
    (if (not (eq? (cp:assignment-connector new-assignment) connector))
	(error "Inconsistent connectors: coincidence"
	       new-assignment old-assignment))
    (let ((new-value (cp:assignment-value new-assignment))
	  (old-value (cp:assignment-value old-assignment)))
      (let ((residual (simplify (- new-value old-value))))
	(if (number? residual)
	    (if (= residual 0)
		#t			;ignore -- wrong thing?
		#f			;contradiction
		)
	    (let ((equation
		   (make-equation residual
				  (list new-assignment old-assignment))))
	      (if equation
		  (set! *equations* (cons equation *equations*)))
	      #t))))))


;;; expr should have value zero
;;; justs is a list of tms nodes

(define (make-equation expr justs)
  (let* ((specs (standardize-equation expr '() '() #f list))
	 (pexpr (car specs))
	 (vspecs (cadr specs))
	 (tms (tms:node-tms (car justs))))
    (if (and (number? pexpr) (not (= pexpr 0)))
	(begin (tms:justify-node (tms:contradiction tms) 'equation justs)
	       #f)
	(let ((node (tms:make-node tms (cp:make-equation-datum pexpr))))
	  (tms:justify-node node 'equation justs)
	  (list pexpr (list node) vspecs)))))

(define-record-type <cp:equation-datum>
    (cp:make-equation-datum residual)
    cp:equation-datum?
  (residual cp:equation-datum-residual))

(define (cp:equation? x)
  (and (tms:node? x)
       (cp:equation-datum? (tms:node-datum x))))


(define (D? x)
  (and (pair? x)
       (eq? (car x) 'D)))

(define (D2? x)
  (and (pair? x) 
       (equal? (car x) '(expt D 2))))
  
(define (standardize-equation residual variables functions variable continue)
  ;; continue = (lambda (new-residual new-map functions) ...)
  (let ((redo #f))
    (define (walk-expression expression map functions continue)
      (cond ((pair? expression)
	     (let ((rator (operator expression))
		   (rands (operands expression)))
	       (cond ((and (= (length rands) 1) (eq? (car rands) variable))
		      (walk-expression rator
				       (list-adjoin rator map)
				       (list-adjoin rator functions)
				       continue))
		     ((or (D? expression) (D2? expression))
		      (continue expression
				(list-adjoin expression map)
				(list-adjoin expression functions)))
		     (else
		      (walk-expression rator map functions
			(lambda (rator-result rator-map rator-functions)
			  (walk-list rands rator-map rator-functions
				     (lambda (rands-result rands-map rands-functions)
				       (continue (cons rator-result
						       rands-result)
						 rands-map
						 rands-functions)))))))))
	    ((number? expression)
	     (continue (if (and (inexact? expression)
				(< (abs expression) *zero-threshold*))
			   (begin (set! redo #t) 0)
			   expression)
		       map
		       functions))
	    ((memq expression '(+ - / * D expt exp sin cos))
	     (continue expression map functions))
	    (else
	     (continue expression
		       (list-adjoin expression map)
		       functions))))
    (define (walk-list elist map functions continue)
      (if (pair? elist)
	  (walk-expression (car elist) map functions
	    (lambda (car-result car-map car-functions)
	      (walk-list (cdr elist) car-map car-functions 
			 (lambda (cdr-result cdr-map cdr-functions)
			   (continue (cons car-result cdr-result)
				     cdr-map
				     cdr-functions)))))
	  (continue elist map functions)))
    (let lp ((residual (simplify residual)))
      (walk-expression (if (quotient? residual)
			   (symb:dividend residual)
			   residual)
		       variables
		       functions
		       (lambda (expression map funs)
			 (if redo
			     (begin (set! redo #f)
				    (lp (simplify expression)))
			     (continue expression map funs)))))))

(define *zero-threshold* 1e-15)		;for small numbers