#| -*-Scheme-*-

$Id$

Copyright 2006 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Numerical constraint types

;;; Want generic arithmetic to allow symbolic stuff.
;;; (declare (usual-integrations))

(define cp:adder
  (cp:make-constraint-type 'multiplier
    (lambda (constraint)
      (let ((connectors (cp:constraint-connectors constraint)))
	(let ((sum (car connectors))
	      (addends (cdr connectors))
	      (n-known (count-matching-items connectors cp:has-value?))
	      (n-needed (- (length connectors) 1)))
	  (let ((propagate
		 (lambda (target)
		   (if (eq? target sum)
		       (cp:set-value sum
				     (apply + (map cp:value-of addends))
				     addends
				     constraint)
		       (let ((supports (cons sum (delq target addends))))
			 (cp:set-value target
				       (apply - (map cp:value-of supports))
				       supports
				       constraint))))))
	    (cond ((= n-known n-needed)
		   (propagate
		    (find-matching-item connectors
		      (lambda (connector)
			(not (cp:has-value? connector))))))
		  ((> n-known n-needed)
		   (propagate sum)
		   (for-each propagate addends)))))))
    (lambda (connectors)
      (if (not (>= (length connectors) 3))
	  (error "adder: Too few connectors:" connectors)))))

(define cp:multiplier
  (cp:make-constraint-type 'multiplier
    (lambda (constraint)
      (let ((connectors (cp:constraint-connectors constraint)))
	(let ((product (car connectors))
	      (multiplicands (cdr connectors))
	      (n-known (count-matching-items connectors cp:has-value?))
	      (n-needed (- (length connectors) 1)))
	  (let ((propagate
		 (lambda (target)
		   (if (eq? target product)
		       (cp:set-value product
				     (apply * (map cp:value-of multiplicands))
				     multiplicands
				     constraint)
		       (let ((supports
			      (cons product (delq target multiplicands))))
			 (cp:set-value target
				       (apply / (map cp:value-of supports))
				       supports
				       constraint)))))
		(zeros
		 (keep-matching-items multiplicands
		   (lambda (multiplicand)
		     (and (cp:has-value? multiplicand)
			  (zero? (cp:value-of multiplicand)))))))
	    (cond ((pair? zeros)
		   (cp:set-value product
				 (apply * (map cp:value-of zeros))
				 zeros
				 constraint))
		  ((= n-known n-needed)
		   (propagate
		    (find-matching-item connectors
		      (lambda (connector)
			(not (cp:has-value? connector))))))
		  ((> n-known n-needed)
		   (propagate product)
		   (for-each propagate multiplicands)))))))
    (lambda (connectors)
      (if (not (>= (length connectors) 3))
	  (error "multiplier: Too few connectors:" connectors)))))