#| -*-Scheme-*-

$Id: scheduler.scm 10155 2008-01-15 05:13:58Z cph $

Copyright (C) 2007 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.

|#

;;;; AIR: scheduler stub

(declare (usual-integrations))

(define (amord:make-scheduler)
  (%make-scheduler '() '() #f '() '() #f (make-queue) (cons '() '())))

(define-record-type <amord:scheduler>
    (%make-scheduler belief-rules beliefs belief-universe
		     goal-rules goals goal-universe
		     actions alternatives)
    amord:scheduler?
  (belief-rules %scheduler-belief-rules %set-scheduler-belief-rules!)
  (beliefs %scheduler-beliefs %set-scheduler-beliefs!)
  (belief-universe %%scheduler-belief-universe %set-scheduler-belief-universe!)
  (goal-rules %scheduler-goal-rules %set-scheduler-goal-rules!)
  (goals %scheduler-goals %set-scheduler-goals!)
  (goal-universe %%scheduler-goal-universe %set-scheduler-goal-universe!)
  (actions %scheduler-actions)
  (alternatives %scheduler-alternatives))

(define (amord:belief-universe system)
  (%scheduler-belief-universe (amord:scheduler system)))

;;; The OWL support uses universes as memoization keys, so it's
;;; important that they be reused when possible.

(define (%scheduler-belief-universe scheduler)
  (or (%%scheduler-belief-universe scheduler)
      (let ((universe (rdf-triples->universe (%scheduler-beliefs scheduler))))
	(%set-scheduler-belief-universe! scheduler universe)
	universe)))

(define (amord:goal-universe system)
  (%scheduler-goal-universe (amord:scheduler system)))

(define (%scheduler-goal-universe scheduler)
  (or (%%scheduler-goal-universe scheduler)
      (let ((universe
	     (rdf-triples->universe
	      (append! (append-map amord:pattern-triples
				   (%scheduler-goals scheduler))
		       (%scheduler-beliefs scheduler)))))
	(%set-scheduler-goal-universe! scheduler universe)
	universe)))

(define (%consume-results rule scheduler results)
  (stream-for-each (lambda (result)
		     (enqueue! (%scheduler-actions scheduler)
			       (cons rule result)))
		   results)
  (if (stream-null? results)
      (%add-alternative! rule scheduler)
      (%delete-alternative! rule scheduler)))

(define (amord:handle-next-action scheduler handler)
  (%handle-next (%scheduler-actions scheduler)
    (lambda (rule result)
      (handler rule
	       (%result-substitute result)
	       (amord:make-pattern
		(make-rdf-graph (match-result-matched result))
		'())))))

(define (%handle-next q handler)
  (if (queue-empty? q)
      #f
      (let ((item (dequeue! q)))
	(handler (car item) (cdr item))
	#t)))

(define (%result-substitute result)
  (let ((dict (match-result-dict result)))
    (lambda (var)
      (or (lookup-in-match-dict var dict)
	  var))))

(define (amord:handle-next-alternative scheduler handler)
  (let ((alt
	 (let ((alts (%scheduler-alternatives scheduler)))
	   (let ((p (cdr alts)))
	     (and (pair? p)
		  (begin
		    (set-cdr! alts (cdr p))
		    (set-cdr! p (car alts))
		    (set-car! alts p)
		    (car p)))))))
    (if alt
	(begin
	  (handler alt)
	  #t)
	#f)))

(define (%add-alternative! rule scheduler)
  (let ((alts (%scheduler-alternatives scheduler)))
    (if (and (amord:rule-alternative rule)
	     (not (memq rule (car alts))))
	(let loop ((this (cdr alts)) (prev alts))
	  (cond ((not (pair? this))
		 (set-cdr! prev (list rule)))
		((not (eq? (car this) rule))
		 (loop (cdr this) this)))))))

(define (%delete-alternative! rule scheduler)
  (if (amord:rule-alternative rule)
      (%set-scheduler-alternatives!
       scheduler
       (delq! rule (%scheduler-alternatives scheduler)))))

(define (amord:event:belief-rule rule supported? scheduler)
  (let ((rules (%scheduler-belief-rules scheduler)))
    (if supported?
	(if (not (memq rule rules))
	    (begin
	      (%set-scheduler-belief-rules! scheduler (cons rule rules))
	      (%handle-belief-rule rule scheduler)))
	(%set-scheduler-belief-rules! scheduler (delq! rule rules)))))

(define (amord:event:goal-rule rule supported? scheduler)
  (let ((rules (%scheduler-goal-rules scheduler)))
    (if supported?
	(if (not (memq rule rules))
	    (begin
	      (%set-scheduler-goal-rules! scheduler (cons rule rules))
	      (%handle-goal-rule rule scheduler)))
	(%set-scheduler-goal-rules! scheduler (delq! rule rules)))))

(define (amord:event:belief belief supported? scheduler)
  (let ((beliefs (%scheduler-beliefs scheduler)))
    (if supported?
	(if (not (memq belief beliefs))
	    (begin
	      (%set-scheduler-beliefs! scheduler (cons belief beliefs))
	      (%set-scheduler-belief-universe! scheduler #f)
	      (%set-scheduler-goal-universe! scheduler #f)
	      (%handle-belief belief scheduler)))
	(if (memq belief beliefs)
	    (begin
	      (%set-scheduler-beliefs! scheduler (delq! belief beliefs))
	      (%set-scheduler-belief-universe! scheduler #f)
	      (%set-scheduler-goal-universe! scheduler #f))))))

(define (amord:event:goal goal supported? scheduler)
  (let ((goals (%scheduler-goals scheduler)))
    (if supported?
	(begin
	  (%set-scheduler-goals! scheduler (cons goal goals))
	  (%set-scheduler-goal-universe! scheduler #f)
	  (%handle-goal goal scheduler))
	(if (memq goal goals)
	    (begin
	      (%set-scheduler-goals! scheduler (delq! goal goals))
	      (%set-scheduler-goal-universe! scheduler #f))))))

(define (%handle-belief-rule rule scheduler)
  (%consume-results rule scheduler
		    (let ((pattern (amord:rule-pattern rule)))
		      (rdf-match (amord:pattern-triples pattern)
				 (amord:pattern-vars pattern)
				 (%scheduler-belief-universe scheduler)
				 #f))))

(define (%handle-belief triple scheduler)
  (for-each (lambda (rule)
	      (%split-match (list triple) rule scheduler))
	    (%scheduler-belief-rules scheduler))
  (for-each (lambda (rule)
	      (for-each (lambda (goal)
			  (for-each (lambda (triple*)
				      (%split-match (list triple triple*)
						    rule
						    scheduler))
				    (amord:pattern-triples goal)))
			(%scheduler-goals scheduler)))
	    (%scheduler-goal-rules scheduler)))

(define (%handle-goal-rule rule scheduler)
  (for-each (lambda (goal)
	      (for-each (lambda (triple)
			  (%split-match (list triple) rule scheduler))
			(amord:pattern-triples goal)))
	    (%scheduler-goals scheduler)))

(define (%handle-goal goal scheduler)
  (for-each (lambda (rule)
	      (for-each (lambda (triple)
			  (%split-match (list triple) rule scheduler))
			(amord:pattern-triples goal)))
	    (%scheduler-goal-rules scheduler)))

(define (%split-match prematches rule scheduler)
  (let ((initial-results
	 (stream-filter (lambda (result)
			  (eqv-set=? (match-result-matched result)
				     prematches))
			(let ((pattern (amord:rule-pattern rule)))
			  (rdf-match (amord:pattern-triples pattern)
				     (amord:pattern-vars pattern)
				     (rdf-triples->universe prematches)
				     #t)))))
    (if (stream-pair? initial-results)
	(%consume-results
	 rule scheduler
	 (stream-append-map
	  (lambda (result)
	    (stream-map
	     (lambda (result*)
	       (make-match-result (append (match-result-dict result)
					  (match-result-dict result*))
				  (eqv-union (match-result-matched result)
					     (match-result-matched result*))
				  (match-result-unmatched result*)
				  (match-result-vars result*)))
	     (rdf-match (match-result-unmatched result)
			(match-result-vars result)
			(if (amord:rule-matches-goals? rule)
			    (%scheduler-goal-universe scheduler)
			    (%scheduler-belief-universe scheduler))
			#f)))
	  initial-results)))))

;;; Edwin Variables:
;;; lisp-indent/amord:maybe-trace: 3
;;; End: