#| -*-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 value-model tms connectors activation-queue)
    cp:network?
  (name cp:network-name)
  (value-model cp:network-value-model)
  (tms cp:network-tms)
  (connectors cp:network-connectors cp:set-network-connectors!)
  (activation-queue cp:activation-queue))

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

(define (cp:make-network name value-model)
  (cp:%make-network name
		    value-model
		    (tms:make name cp:event-handler)
		    '()
		    (cp:make-queue)))

(define (cp:add-connector-to-network connector network)
  (cp:set-network-connectors! network
			      (cons connector
				    (cp:network-connectors network))))

(define (cp:network-value-models network)
  (let loop
      ((connectors (cp:network-connectors network))
       (models (list (cp:network-value-model network))))
    (if (pair? connectors)
	(loop (cdr connectors)
	      (let ((model (cp:%connector-value-model (car connectors))))
		(if (and model (not (memq model models)))
		    (cons model models)
		    models)))
	models)))

(define (cp:post-propagation-hooks network)
  (let loop ((models (cp:network-value-models network)) (hooks '()))
    (if (pair? models)
	(loop (cdr models)
	      (let ((hook (cp:value-post-propagation-hook (car models))))
		(if hook
		    (cons hook hooks)
		    hooks)))
	hooks)))

(define-record-type <cp:value-model>
    (cp:%make-value-model acceptance-predicate
			  equality-predicate
			  value-chooser
			  coincidence-handler
			  post-propagation-hook)
    cp:value-model?
  (acceptance-predicate cp:value-acceptance-predicate)
  (equality-predicate cp:value-equality-predicate)
  (value-chooser cp:value-chooser)
  (coincidence-handler cp:value-coincidence-handler)
  (post-propagation-hook cp:value-post-propagation-hook))

(define-guarantee cp:value-model "constraint value model")

(define (cp:make-value-model acceptance-predicate
			     equality-predicate
			     #!optional
			     value-chooser
			     coincidence-handler
			     post-propagation-hook)
  (cp:%make-value-model acceptance-predicate
			equality-predicate
			(if (or (default-object? value-chooser)
				(not value-chooser))
			    (lambda (values) (car values))
			    value-chooser)
			(if (or (default-object? coincidence-handler)
				(not coincidence-handler))
			    cp:default-coincidence-handler
			    coincidence-handler)
			(if (default-object? post-propagation-hook)
			    #f
			    post-propagation-hook)))

(define (cp:default-coincidence-handler connector value justify)
  (let ((assignment (cp:supported-assignment connector)))
    (if (not (cp:values-equal? (cp:assignment-value assignment)
			       value
			       connector))
	(cp:set-contradiction connector value justify))))

(define (cp:value-acceptable? v connector)
  ((cp:value-acceptance-predicate (cp:connector-value-model connector)) v))

(define (cp:values-equal? v1 v2 connector)
  ((cp:value-equality-predicate (cp:connector-value-model connector)) v1 v2))

(define (cp:choose-value values connector)
  ((cp:value-chooser (cp:connector-value-model connector)) values))

(define (cp:handle-coincidence connector value justify)
  ((cp:value-coincidence-handler (cp:connector-value-model connector))
   connector
   value
   justify))

;;;; Constraints

(define-record-type <cp:constraint-type>
    (cp:%make-constraint-type name propagator validator)
    cp:constraint-type?
  (name cp:constraint-type-name)
  (propagator cp:constraint-type-propagator)
  (validator cp:constraint-type-validator))

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

(define (cp:make-constraint-type name propagator #!optional validator)
  (cp:%make-constraint-type name
			    propagator
			    (if (default-object? validator)
				#f
				validator)))

(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 connector . connectors)
  (let ((connectors (cons connector connectors)))
    (for-each (lambda (connector)
		(guarantee-cp:connector connector 'cp:make-constraint))
	      connectors)
    (let ((validator (cp:constraint-type-validator type)))
      (if validator
	  (validator connectors)))
    (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)))

;;;; Connectors

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

(define-guarantee cp:connector "connector")

(set-record-type-unparser-method! <cp:connector>
  (standard-unparser-method 'connector
    (lambda (connector port)
      (write-char #\space port)
      (write (cp:connector-name connector) port))))

(define (cp:make-connector name network #!optional value-model)
  (let ((value-model (if (default-object? value-model) #f value-model)))
    (if value-model
	(guarantee-cp:value-model value-model 'cp:make-connector))
    (let ((connector
	   (cp:%make-connector name
			       network
			       value-model
			       '()
			       '())))
      (cp:add-connector-to-network connector network)
      connector)))

(define (cp:connector-value-model connector)
  (or (cp:%connector-value-model connector)
      (cp:network-value-model (cp:connector-network connector))))

(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
   (append! (cp:connector-assignments connector) (list assignment))))

(define (cp:supported-assignments connector)
  (keep-matching-items (cp:connector-assignments connector)
    tms:node-supported?))

(define (cp:supported-assignment connector)
  (let ((assignments (cp:supported-assignments connector)))
    (if (not (pair? assignments))
	(error:bad-range-argument connector 'cp:supported-assignment))
    (let ((value
	   (cp:choose-value (map cp:assignment-value assignments)
			    connector)))
      (let ((assignment
	     (find-matching-item assignments
	       (lambda (assignment)
		 (cp:assignment-has-value? assignment value)))))
	(if (not assignment)
	    (error "Can't find matching assignment:" value))
	assignment))))

(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:values-of connector)
  (map cp:assignment-value (cp:supported-assignments connector)))

(define (cp:value-is? connector value)
  (and (cp:has-value? connector)
       (cp:values-equal? (cp:value-of connector) value connector)))

(define (cp:find-assignment connector value)
  (find-matching-item (cp:connector-assignments connector)
    (lambda (assignment)
      (cp:assignment-has-value? assignment value))))

(define (cp:assignment-for-value connector value)
  (or (cp:find-assignment connector value)
      (cp:make-assignment connector value)))

;;;; Assignments

(define (cp:make-assignment connector value)
  (if (not (cp:value-acceptable? value connector))
      (error:bad-range-argument value 'cp:make-assignment))
  (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 (cp:assignment-has-value? assignment value)
  (let ((datum (tms:node-datum assignment)))
    (cp:values-equal? (cp:assignment-datum-value datum)
		      value
		      (cp:assignment-datum-connector datum))))

(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:assume-value connector value)
  (if (cp:has-value? connector)
      (cp:handle-coincidence connector value tms:assume-node)
      (cp:set-justified-value connector value tms:assume-node))
  (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?))))

;;;; Assigning values

(define (cp:set-value connector value operands constraint)
  (let* ((supports (map cp:supported-assignment operands))
	 (justify (lambda (node) (tms:justify-node node constraint supports))))
    (if (cp:has-value? connector)
	(if (cp:constraint-satisfied? constraint
				      (cons (cp:supported-assignment connector)
					    supports))
	    unspecific
	    (cp:handle-coincidence connector value justify))
	(cp:set-justified-value connector value justify))))

(define (cp:constraint-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:set-justified-value connector value justify)
  (let ((assignment (cp:assignment-for-value connector value)))
    (justify assignment)
    assignment))

(define (cp:set-contradiction connector value justify)
  (cp:signal-contradiction
   connector
   (let ((current (cp:supported-assignment connector)))
     ;; Force order of evaluation
     (list (cp:set-justified-value connector value justify)
	   current))))

(define (cp:signal-contradiction connector 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)
      (cp:awaken-connector (cp:assignment-connector node))))

(define (cp:awaken-connector connector)
  (cp:awaken-constraints (cp:connector-constraints connector)))

(define (cp:awaken-constraints constraints)
  (for-each cp:awaken-constraint constraints))

(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))
	(contra (tms:contradiction (cp:network-tms network)))
	(hooks (cp:post-propagation-hooks network)))
    (let loop ()
      (if (and (tms:node-supported? contra)
	       cp:warn-on-contradiction?)
	  (warn "Contradiction:" contra))
      (cond ((cp:non-empty-queue? queue)
	     (let ((constraint (cp:dequeue queue)))
	       ;;(write-line `(activate ,constraint))
	       ((cp:constraint-type-propagator (cp:constraint-type constraint))
		constraint)
	       (loop)))
	    ((pair? hooks)
	     (for-each (lambda (hook) (hook network)) hooks)
	     (if (cp:non-empty-queue? queue)
		 (loop)))))))

(define cp:warn-on-contradiction? #t)

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

(define (cp:non-empty-queue? queue)
  (pair? (car queue)))

(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)
  (let ((old (car queue)))
    (let ((new (cdr old)))
      (set-car! queue new)
      (if (not (pair? new))
	  (set-cdr! queue new)))
    (car old)))