#| -*-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.

|#

;;;; Boolean constraint types

(declare (usual-integrations))

(define cp:boolean-not
  (cp:make-constraint-type 'boolean-not
    (lambda (constraint)
      (receive (b a) (apply values (cp:constraint-connectors constraint))
	(cond ((cp:has-value? a)
	       (cp:set-value b
			     (not (cp:value-of a))
			     (list a)
			     constraint))
	      ((cp:has-value? b)
	       (cp:set-value a
			     (not (cp:value-of b))
			     (list b)
			     constraint)))))
    (lambda (connectors)
      (if (not (= (length connectors) 2))
	  (error "boolean-not: requires exactly two connectors:"
		 connectors)))))

(define cp:boolean-and
  (cp:make-constraint-type 'boolean-and
    (lambda (constraint)
      (let ((connectors (cp:constraint-connectors constraint)))
	(let ((product (car connectors))
	      (operands (cdr connectors)))
	  (let ((falses
		 (keep-matching-items operands
		   (lambda (operand)
		     (cp:value-is? operand #f)))))
	    (cond ((pair? falses)
		   (for-each (lambda (false)
			       (cp:set-value product
					     #f
					     (list false)
					     constraint))
			     falses))
		  ((for-all? operands cp:has-value?)
		   (cp:set-value product #t operands constraint))
		  ((cp:value-is? product #t)
		   (let ((supports (list product)))
		     (for-each (lambda (operand)
				 (cp:set-value operand #t supports constraint))
			       operands)))
		  ((cp:value-is? product #f)
		   (let ((unknown
			  (delete-matching-items operands cp:has-value?)))
		     (if (and (pair? unknown)
			      (null? (cdr unknown)))
			 (cp:set-value (car unknown)
				       #f
				       (delq (car unknown) connectors)
				       constraint)))))))))
    (lambda (connectors)
      (if (not (>= (length connectors) 3))
	  (error "boolean-and: Too few connectors:" connectors)))))

(define cp:boolean-or
  (cp:make-constraint-type 'boolean-or
    (lambda (constraint)
      (let ((connectors (cp:constraint-connectors constraint)))
	(let ((sum (car connectors))
	      (operands (cdr connectors)))
	  (let ((trues
		 (keep-matching-items operands
		   (lambda (operand)
		     (cp:value-is? operand #t)))))
	    (cond ((pair? trues)
		   (for-each (lambda (true)
			       (cp:set-value sum
					     #t
					     (list true)
					     constraint))
			     trues))
		  ((for-all? operands cp:has-value?)
		   (cp:set-value sum #f operands constraint))
		  ((cp:value-is? sum #f)
		   (let ((supports (list sum)))
		     (for-each (lambda (operand)
				 (cp:set-value operand #f supports constraint))
			       operands)))
		  ((cp:value-is? sum #t)
		   (let ((unknown
			  (delete-matching-items operands cp:has-value?)))
		     (if (and (pair? unknown)
			      (null? (cdr unknown)))
			 (cp:set-value (car unknown)
				       #t
				       (delq (car unknown) connectors)
				       constraint)))))))))
    (lambda (connectors)
      (if (not (>= (length connectors) 3))
	  (error "boolean-or: Too few connectors:" connectors)))))