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

|#

;;;; Simple constraint propagator

(declare (usual-integrations))

(define-record-type <cp:network>
    (cp:%make-network name tms activation-queue)
    cp:network?
  (name cp:network-name)
  (tms cp:network-tms)
  (activation-queue cp:activation-queue))

(define-guarantee cp:network "constraint network")

(define (cp:make-network name)
  (guarantee-symbol name 'cp:make-network)
  (cp:%make-network name
		    (tms:make name cp:event-handler)
		    (cp:make-queue)))

;;;; Constraints

(define-record-type <cp:constraint-type>
    (cp:make-constraint-type connector-names propagator)
    cp:constraint-type?
  (connector-names cp:constraint-type-connector-names)
  (propagator cp:constraint-type-propagator))

(define-guarantee cp:constraint-type "constraint type")

(define-record-type <cp:constraint>
    (cp:%make-constraint type name network connectors)
    cp:constraint?
  (type cp:constraint-type)
  (name cp:constraint-name)
  (network cp:constraint-network)
  (connectors cp:constraint-connectors))

(define-guarantee cp:constraint "constraint")

(define (cp:make-constraint type name network . connectors)
  (let ((n-given (length connectors))
	(n-expected (length (cp:constraint-type-connector-names type))))
    (if (not (= n-given n-expected))
	(error "Wrong number of connectors:" n-given n-expected)))
  (let ((constraint (cp:%make-constraint type name network connectors)))
    (for-each (lambda (connector)
		(cp:add-constraint-to-connector constraint connector))
	      connectors)
    (cp:awaken-constraint constraint)
    constraint))

(define (cp:constraint-connector-names constraint)
  (cp:constraint-type-connector-names (cp:constraint-type constraint)))

(define (cp:get-connector constraint name)
  (let loop
      ((names (cp:constraint-connector-names constraint))
       (conns (cp:constraint-connectors constraint)))
    (if (not (pair? names))
	(error:bad-range-argument name 'cp:get-connector))
    (if (eq? (car names) name)
	(car conns)
	(loop (cdr names) (cdr conns)))))

;;;; Connectors

(define-record-type <cp:connector>
    (cp:%make-connector name network constraints assignments)
    cp:connector?
  (name cp:connector-name)
  (network cp:connector-network)
  (constraints cp:connector-constraints cp:set-connector-constraints!)
  (assignments cp:connector-assignments cp:set-connector-assignments!))

(define (cp:make-connector name network)
  (cp:%make-connector name network '() '()))

(define (cp:add-constraint-to-connector constraint connector)
  (cp:set-connector-constraints!
   connector
   (cons constraint (cp:connector-constraints connector))))

(define (cp:add-assignment-to-connector assignment connector)
  (cp:set-connector-assignments!
   connector
   (cons assignment (cp:connector-assignments connector))))

(define (cp:has-value? connector)
  (there-exists? (cp:connector-assignments connector)
    tms:node-supported?))

(define (cp:value-of connector)
  (cp:assignment-value (cp:supported-assignment connector)))

(define (cp:value-is? connector value)
  (tms:node-supported? (cp:assignment-for-value connector value)))

(define (cp:assignment-for-value connector value)
  (or (find-matching-item (cp:connector-assignments connector)
	(lambda (assignment)
	  (cp:compare-values (cp:assignment-value assignment) value)))
      (cp:make-assignment connector value)))

(define (cp:supported-assignment connector)
  (let ((assignment
	 (find-matching-item (cp:connector-assignments connector)
	   tms:node-supported?)))
    (if (not assignment)
	(error:bad-range-argument connector 'cp:supported-assignment))
    assignment))

;;;; Assignments

(define (cp:make-assignment connector value)
  (let ((assignment
	 (tms:make-node (cp:network-tms (cp:connector-network connector))
			(cp:make-assignment-datum connector value))))
    (cp:add-assignment-to-connector assignment connector)
    assignment))

(define (cp:assignment? object)
  (and (tms:node? object)
       (cp:assignment-datum? (tms:node-datum object) )))

(define (cp:assignment-connector assignment)
  (cp:assignment-datum-connector (tms:node-datum assignment)))

(define (cp:assignment-value assignment)
  (cp:assignment-datum-value (tms:node-datum assignment)))

(define-record-type <cp:assignment-datum>
    (cp:make-assignment-datum connector value)
    cp:assignment-datum?
  (connector cp:assignment-datum-connector)
  (value cp:assignment-datum-value))

(define (cp:compare-values v1 v2)
  (if (and (number? v1)
	   (inexact? v1)
	   (number? v2)
	   (inexact? v2))
      (<= (magnitude (- v1 v2))
	  (+ (* 1e-10
		(/ (+ (magnitude v1) (magnitude v2))
		   2.))
	     1.0e-18))
      (eqv? v1 v2)))

;;;; Assigning values

(define (cp:assume-value connector value)
  (tms:assume-node (cp:assignment-for-value connector value))
  (cp:maybe-signal-contradiction connector)
  (cp:propagate (cp:connector-network connector)))

(define (cp:retract-value connector)
  (let loop
      ((assignments (cp:connector-assignments connector))
       (retractions? #f))
    (if (pair? assignments)
	(if (tms:node-assumed? (car assignments))
	    (begin
	      (tms:retract-node (car assignments))
	      (loop (cdr assignments) #t))
	    (loop (cdr assignments) retractions?))
	(begin
	  (if retractions?
	      (cp:propagate (cp:connector-network connector)))
	  retractions?))))

(define (cp:set-value result value operands constraint)
  (if (cp:has-value? result)
      (cp:check-functional-coincidence result value operands constraint)
      (cp:set-value-1 result value operands constraint)))

(define (cp:set-value-1 connector value connectors constraint)
  (tms:justify-node (cp:assignment-for-value connector value)
		    constraint
		    (map cp:supported-assignment connectors))
  (cp:maybe-signal-contradiction connector))

(define (cp:check-functional-coincidence result value operands constraint)
  (let ((result-asn (cp:supported-assignment result))
	(operand-asns (map cp:supported-assignment operands)))
    (if (not (or (cp:constraint-already-satisfied?
		  constraint
		  (cons result-asn operand-asns))
		 (cp:compare-values (cp:assignment-value result-asn) value)))
	;; Forces contradiction:
	(cp:set-value-1 result value operands constraint))))

(define (cp:constraint-already-satisfied? constraint supports)
  (there-exists? supports
    (lambda (support)
      (there-exists? (tms:node-justifications support)
	(lambda (j)
	  (and (eq? (tms:justification-rule j) constraint)
	       (tms:justification-supported? j)
	       (for-all? (tms:justification-antecedents j)
		 (lambda (node)
		   (memq node supports)))))))))

(define (cp:maybe-signal-contradiction connector)
  (let ((assignments
	 (keep-matching-items (cp:connector-assignments connector)
	   tms:node-supported?)))
    (if (and (pair? assignments)
	     (pair? (cdr assignments)))
	(tms:justify-node (tms:contradiction
			   (cp:network-tms (cp:connector-network connector)))
			  connector
			  assignments))))

;;;; Propagation

(define (cp:event-handler node justification)
  (if (cp:assignment? node)
      (for-each cp:awaken-constraint
		(cp:connector-constraints (cp:assignment-connector node)))))

(define (cp:awaken-constraint constraint)
  (cp:enqueue constraint
	      (cp:activation-queue (cp:constraint-network constraint))))

(define (cp:propagate network)
  (let ((queue (cp:activation-queue network)))
    (let loop ()
      (let ((constraint (cp:dequeue queue #f)))
	(if constraint
	    (begin
	      ((cp:constraint-type-propagator (cp:constraint-type constraint))
	       constraint)
	      (loop)))))))

(define (cp:make-queue)
  (cons '() '()))

(define (cp:enqueue item queue)
  (if (not (memq item (car queue)))	;don't queue twice
      (let ((old (cdr queue))
	    (new (list item)))
	(if (pair? old)
	    (set-cdr! old new)
	    (set-car! queue new))
	(set-cdr! queue new))))

(define (cp:dequeue queue default)
  (let ((old (car queue)))
    (if (pair? old)
	(begin
	  (let ((new (cdr old)))
	    (set-car! queue new)
	    (if (not (pair? new))
		(set-cdr! queue new)))
	  (car old))
	default)))