#| -*-Scheme-*-

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

Copyright (C) 2006,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 (AMORD in RDF)

(declare (usual-integrations))

(define-record-type <amord:system>
    (%make-system name
		  belief-registrations
		  goal-registrations
		  rule-registrations
		  goal-patterns
		  scheduler
		  trace-tags
		  documents)
    amord:system?
  (name amord:system-name)
  (tms amord:tms amord:set-tms!)
  (belief-registrations amord:belief-registrations)
  (goal-registrations amord:goal-registrations)
  (rule-registrations amord:rule-registrations)
  (goal-patterns %goal-patterns %set-goal-patterns!)
  (scheduler amord:scheduler)
  (trace-tags amord:trace-tags amord:set-trace-tags!)
  (documents amord:documents))

(define (amord:make-system #!optional name)
  (let ((name (if (default-object? name) #f (symbol name))))
    (let ((system
	   (%make-system name
			 (make-eq-hash-table)
			 (make-eq-hash-table)
			 (make-eq-hash-table)
			 '()
			 (amord:make-scheduler)
			 '()
			 (list #f))))
      (amord:set-tms! system
		      (tms:make (and name (symbol name '-tms))
				(amord:make-event-handler system)))
      (%update-documents! system)
      system)))

(set-record-type-unparser-method! <amord:system>
  (simple-unparser-method 'amord:system
    (lambda (system)
      (let ((name (amord:system-name system)))
	(if name
	    (list name)
	    '())))))

(define (amord:register-belief-node object system)
  (hash-table/intern! (amord:belief-registrations system) object
    (lambda ()
      (tms:make-node (amord:tms system) object))))

(define (amord:register-goal-node object system)
  (hash-table/intern! (amord:goal-registrations system) object
    (lambda ()
      (tms:make-node (amord:tms system) object))))

(define (amord:belief-node object system #!optional error?)
  (let ((node (hash-table/get (amord:belief-registrations system) object #f)))
    (if (and (not node) error?)
	(error:bad-range-argument object 'amord:belief-node))
    node))

(define (amord:goal-node object system #!optional error?)
  (let ((node (hash-table/get (amord:goal-registrations system) object #f)))
    (if (and (not node) error?)
	(error:bad-range-argument object 'amord:goal-node))
    node))

(define (amord:trace system . tags)
  (if (not (eqv-subset? tags amord:known-trace-tags))
      (error:bad-range-argument tags 'amord:trace))
  (amord:set-trace-tags! system tags))

(define (amord:untrace system)
  (amord:set-trace-tags! system '()))

(define amord:known-trace-tags
  '(enable-rule
    rule-pattern
    assert-belief
    assert-goal
    run-rule
    run-alt
    matched-graph
    rule-condition-failure))

(define (amord:maybe-trace system tag message #!optional thunk)
  (if (memq tag (amord:trace-tags system))
      (if (default-object? thunk)
	  (write-notification-line message)
	  (with-notification message thunk))
      (if (not (default-object? thunk))
	  (thunk))))

(define (amord:write-beliefs system #!optional port)
  (write-rdf/turtle-subgraph (make-rdf-graph
			      (%scheduler-beliefs (amord:scheduler system)))
			     port)
  (newline port))

(define (amord:write-goals system #!optional port)
  (for-each (lambda (g)
	      (newline port)
	      (write-rdf/turtle-subgraph g port)
	      (newline port))
	    (%scheduler-goals (amord:scheduler system))))

(define (%add-document! uri t system)
  (let ((docs (amord:documents system)))
    (let ((p (assq uri (cdr docs))))
      (if p
	  (if (not (= (cdr p) t))
	      (begin
		(set-cdr! p t)
		(%update-documents! system)))
	  (begin
	    (set-cdr! docs (cons (cons uri t) (cdr docs)))
	    (%update-documents! system))))))

(define (%update-documents! system)
  (let ((docs (amord:documents system)))
    (if (car docs)
	(begin
	  (tms:retract-node (car docs))
	  (set-car! docs #f)))))

(define (%closed-world-assumption system)
  (let ((docs (amord:documents system)))
    (or (car docs)
	(let ((node
	       (tms:make-node (amord:tms system)
			      (cons air:closed-world-assumption
				    (map car (cdr docs))))))
	  (tms:assume-node node)
	  (set-car! docs node)
	  node))))

(define (make-air-system)
  (let ((system (amord:make-system)))
    (for-each
     (lambda (pathname)
       (load-assumptions-file (merge-pathnames pathname air:base-directory)
			      system))
     '("rdf" "rdfs" "owl" "xsd" "base-assumptions"))
    (load-policy-file (merge-pathnames "base-rules" air:base-directory)
		      system)
    (amord:run system)
    (amord:trace system 'assert-belief)
    system))

(define (load-assumptions-file pathname system)
  (let ((pathname (merge-pathnames (pathname-default-type pathname "ttl"))))
    (for-each (let ((just (amord:assumption-justification)))
		(lambda (t)
		  (amord:justify-node (amord:register-belief-node t system)
				      just)))
	      (rdf-graph-triples (amord:read-turtle-file pathname)))
    (%add-document! (pathname->uri (pathname-new-type pathname #f))
		    (file-modification-time pathname)
		    system)))

(define (load-policy-file pathname system)
  (let* ((pathname1 (merge-pathnames (pathname-default-type pathname "ttl")))
	 (pathname2
	  (pathname-new-name pathname1
			     (string-append (pathname-name pathname1)
					    "-expanded")))
	 (pathname3 (pathname-new-type pathname2 "scm")))
    (if (file-modification-time<? pathname2 pathname1)
	(%preprocess-policy-file pathname1 pathname2))
    (if (file-modification-time<? pathname3 pathname2)
	(compile-policy-file pathname2 pathname3))
    (compile-file pathname3 '() air:base-environment)
    ((load (pathname-new-type pathname3 #f) air:base-environment) system #f)
    (%add-document! (pathname->uri (pathname-new-type pathname1 #f))
		    (file-modification-time pathname1)
		    system)
    (amord:run system)))

(define (amord:read-turtle-file pathname)
  (let ((pathname
	 (if (pathname-type pathname)
	     pathname
	     (let loop ((types '("ttl" "n3")))
	       (if (pair? types)
		   (let ((p (pathname-new-type pathname (car types))))
		     (if (file-exists? p)
			 p
			 (loop (cdr types))))
		   pathname)))))
    (with-notification (lambda (port)
			 (write-string "Loading: " port)
			 (write (enough-namestring pathname) port))
      (lambda ()
	(receive (graph registry) (read-rdf/turtle-file pathname)
	  (merge-rdf-prefix-registry! registry *default-rdf-prefix-registry*)
	  graph)))))

(define (%preprocess-policy-file pathname1 pathname2)
  (receive (graph registry) (read-rdf/turtle-file pathname1)
    (write-rdf/turtle-file (%preprocess-policy-graph graph)
			   registry
			   pathname2)))

#|
(define (%file-prefix pathname registry)
  (or (rdf-prefix-expansion ': registry)
      (let ((uri
	     (merge-uris "#"
			 (pathname->uri
			  (pathname-new-type (merge-pathnames pathname)
					     #f)))))
	(register-rdf-prefix ': uri registry)
	(uri->string uri))))
|#

(define (%preprocess-policy-graph graph)
  (let ((renames (make-eq-hash-table)))
    (for-each (let ((new-suffix
		     (let ((counter 0))
		       (lambda ()
			 (let ((n (+ counter 1)))
			   (set! counter n)
			   (number->string n))))))
		(lambda (t)
		  (if (and (or (eq? (rdf-triple-predicate t) air:rule)
			       (eq? (rdf-triple-predicate t) air:goal-rule))
			   (rdf-bnode? (rdf-triple-object t)))
		      (hash-table-set! renames
				       (rdf-triple-object t)
				       (string->relative-uri
					(string-append "#AIR-RULE-"
						       (new-suffix)))))))
	      (rdf-graph-triples graph))
    (make-rdf-graph
     (map (let ((map-elt
		 (lambda (elt)
		   (hash-table-ref renames elt (lambda () elt)))))
	    (lambda (t)
	      (make-rdf-triple (map-elt (rdf-triple-subject t))
			       (map-elt (rdf-triple-predicate t))
			       (map-elt (rdf-triple-object t)))))
	  (rdf-graph-triples graph)))))

;;;; Rules

(define (amord:belief-rule name pattern condition system ctx matched-var
			   hidden? action alternative just)
  (%make-rule name pattern condition system ctx matched-var hidden? #f
	      action alternative just))

(define (amord:goal-rule name pattern condition system ctx matched-var
			 hidden? action alternative just)
  (%make-rule name pattern condition system ctx matched-var hidden? #t
	      action alternative just))

(define (%make-rule name pattern condition system ctx matched-var
		    hidden? matches-goals? action alternative just)
  (guarantee-absolute-uri name '%make-rule)
  (guarantee-amord:pattern pattern '%make-rule)
  (guarantee-amord:pattern condition '%make-rule)
  (guarantee-procedure-of-arity action 2 '%make-rule)
  (if alternative
      (guarantee-procedure-of-arity alternative 2 '%make-rule))
  (let ((rule
	 (%%make-rule name
		      pattern
		      condition
		      system
		      ctx
		      matched-var
		      (append (if hidden? '(hidden) '())
			      (if matches-goals? '(matches-goals) '()))
		      action
		      alternative)))
    (let ((node (amord:register-belief-node rule system)))
      (amord:justify-node node just)
      (hash-table-set! (amord:rule-registrations system) name rule)
      node)))

(define-record-type <amord:rule>
    (%%make-rule name pattern condition system ctx matched-var flags
		 action alternative)
    amord:rule?
  (name amord:rule-name)
  (pattern amord:rule-pattern)
  (condition amord:rule-condition)
  (system amord:rule-system)
  (ctx amord:rule-ctx)
  (matched-var amord:rule-matched-var)
  (flags %rule-flags)
  (action amord:rule-action)
  (alternative amord:rule-alternative))

(define-guarantee amord:rule "AIR rule")

(set-record-type-unparser-method! <amord:rule>
  (standard-unparser-method 'rule
    (lambda (rule port)
      (write-string " " port)
      (write-rdf/turtle-uri (amord:rule-name rule) port))))

(define (amord:rule-container rule)
  (let ((ctx (amord:rule-ctx rule)))
    (and ctx
	 (amord:ctx-rule ctx))))

(define (amord:rule-belief-node rule)
  (amord:belief-node rule (amord:rule-system rule)))

(define (amord:registered-rule uri system)
  (let ((rule
	 (hash-table-ref/default (amord:rule-registrations system) uri #f)))
    (if (not rule)
	(error:bad-range-argument uri 'amord:registered-rule))
    rule))

(define (amord:rule-matches-goals? rule)
  (amord:rule-flagged? rule 'matches-goals))

(define (amord:rule-flagged? rule flag)
  (if (memq flag (%rule-flags rule)) #t #f))

;;;; Binding contexts

(define (%make-ctx rule proposition substitute)
  (let ((ctx (%%make-ctx rule proposition substitute))
	(system (amord:rule-system rule)))
    (amord:justify-node
     (amord:register-belief-node ctx system)
     (amord:make-justification
      rule
      (let ((ctx* (amord:rule-ctx rule))
	    (node
	     (if proposition
		 (if (amord:rule-matches-goals? rule)
		     (amord:goal-node proposition system)
		     (amord:belief-node proposition system))
		 (%closed-world-assumption system))))
	(if ctx*
	    `(and ,(amord:ctx-support-node ctx*)
		  ,node)
	    node))))
    ctx))

(define-record-type <amord:ctx>
    (%%make-ctx rule proposition substitute)
    amord:ctx?
  (rule amord:ctx-rule)
  (proposition amord:ctx-proposition)
  (substitute amord:ctx-substitute))

(define-guarantee amord:ctx "AMORD binding context")

(set-record-type-unparser-method! <amord:ctx>
  (simple-unparser-method 'ctx
    (lambda (ctx)
      (list (amord:ctx-rule ctx)))))

(define (amord:ctx-support-node ctx)
  (amord:belief-node ctx (amord:rule-system (amord:ctx-rule ctx))))

(define (amord:resolve-antecedent name ctx)
  (let loop ((ctx ctx))
    (let ((rule (amord:ctx-rule ctx)))
      (if (eq? (amord:rule-matched-var rule) name)
	  (let ((graph (amord:ctx-proposition ctx)))
	    (if (not graph)
		(error "Reference to matched-graph name in alternative:" name))
	    (let ((system (amord:rule-system rule)))
	      (if (amord:rule-matches-goals? rule)
		  (amord:goal-node graph system)
		  (amord:belief-node graph system))))
	  (let ((parent (amord:rule-ctx rule)))
	    (if (not parent)
		(error "Unknown matched-graph name:" name))
	    (loop parent))))))

;;;; Justifications

(define (amord:justify-node node just)
  (let ((rule (amord:justification-rule just)))
    (if (not (or (amord:rule? rule)
		 (eq? rule air:assumption)
		 (eq? rule air:composite-justification)
		 (eq? rule air:implicit-goal)))
	(error "Illegal justification rule:" rule))
    (if (amord:assumption-justification? just)
	(tms:assume-node node)
	(tms:justify-node node rule (amord:justification-expr just)))
    ;; Force TMS to evaluate node support:
    (tms:node-supported? node)))

(define (amord:assert pattern system just)
  (if (pair? (amord:pattern-vars pattern))
      (error "Variables not allowed in assertion:" pattern))
  (for-each (lambda (triple)
	      (amord:justify-node (amord:register-belief-node triple system)
				  just))
	    (amord:pattern-triples pattern))
  ;; guarantee pattern justification:
  (%pattern-belief-node pattern system))

(define (amord:assert-goal pattern system just)
  (map (lambda (pattern)
	 (let ((pattern
		;; Intern the goal pattern to avoid lots of work.
		(or (find (lambda (pattern*)
			    (amord:equivalent-patterns? pattern pattern*))
			  (%goal-patterns system))
		    (let ((pattern* (amord:rename-pattern pattern)))
		      (%set-goal-patterns! system
					   (cons pattern*
						 (%goal-patterns system)))
		      pattern*))))
	   (for-each (lambda (t)
		       (amord:justify-node
			(amord:register-goal-node t system)
			(amord:make-justification
			 (amord:justification-rule just)
			 `(and ,(amord:justification-expr just)
			       (not ,(amord:register-belief-node t system))))))
		     (amord:pattern-triples pattern))
	   ;; guarantee pattern justification:
	   (%pattern-goal-node pattern system)))
       (amord:partition-pattern pattern)))

(define (amord:make-justification rule expr) (cons rule expr))
(define (amord:justification-rule just) (car just))
(define (amord:justification-expr just) (cdr just))

(define (amord:assumption-justification)
  (amord:make-justification air:assumption '(and)))

(define (amord:assumption-justification? justification)
  (and (eq? (amord:justification-rule justification) air:assumption)
       (equal? (amord:justification-expr justification) '(and))))

(define (amord:default-justification ctx)
  (if ctx
      (let ((just
	     (car (tms:node-justifications (amord:ctx-support-node ctx)))))
	(amord:make-justification (tms:justification-rule just)
				  (tms:justification-expression just)))
      (amord:assumption-justification)))

(define (amord:generate-tms-graph system)
  (receive (premises derivations)
      (%generate-tms-exprs
       (map (lambda (t)
	      (amord:belief-node t system))
	    (stream->list
	     ((amord:belief-universe system) #f
					     (list air:compliant-with
						   air:non-compliant-with)
					     #f)))
       system)
    (%tms-exprs->rdf premises derivations)))

(define (%generate-tms-exprs root-nodes system)
  (let ((seen (make-eq-hash-table))
	(queue (make-queue))
	(premises (make-eq-hash-table)))
    (let ((new-node!
	   (lambda (node)
	     (if (not (hash-table-ref/default seen node #f))
		 (if (tms:node-assumed? node)
		     (hash-table-set! premises node #t)
		     (begin
		       (enqueue! queue node)
		       (hash-table-set! seen node 'queued)))))))

      (define (gen-just-expr just)
	(let loop ((expr (tms:justification-expression just)))
	  (if (tms:node? expr)
	      (if (tms:node-assumed? expr)
		  (begin
		    (hash-table-set! premises expr #t)
		    expr)
		  (let ((justs
			 (filter tms:justification-supported?
				 (tms:node-justifications expr))))
		    (if (and (not amord:show-hidden-rules?)
			     (every (lambda (just)
				      (amord:rule-hidden?
				       (tms:justification-rule just)
				       system))
				    justs))
			`(or ,@(map gen-just-expr justs))
			(begin
			  (new-node! expr)
			  expr))))
	      (%optimize-just-expr (cons (car expr) (map loop (cdr expr)))))))

      (for-each new-node! root-nodes)
      (queue-map! queue
	(lambda (node)
	  (hash-table-set! seen node
			   (map (lambda (just)
				  (list (tms:justification-rule just)
					(gen-just-expr just)))
				(filter tms:justification-supported?
					(tms:node-justifications node)))))))
    (values (hash-table-keys premises)
	    (hash-table->alist seen))))

(define amord:show-hidden-rules? #f)

(define (%tms-exprs->rdf premises derivations)
  (let ((output '()))
    (let ((emit
	   (lambda (s p o)
	     (set! output
		   (cons (make-rdf-triple s p o)
			 output))
	     unspecific)))
      (let ((new-bnode
	     (let ((table (make-eq-hash-table)))
	       (lambda (key #!optional constructor)
		 (or (hash-table-ref/default table key #f)
		     (let ((bnode (make-rdf-bnode)))
		       (if (not (default-object? constructor))
			   (constructor bnode emit))
		       (hash-table-set! table key bnode)
		       bnode))))))
	(%with-tms-node-handler new-bnode
				(lambda (ref)
				  (emit ref tms:justification tms:premise))
				(lambda (handle-node)
				  (for-each handle-node premises)))
	(for-each (lambda (derivation)
		    (let ((cnode (make-rdf-bnode)))
		      (emit (%tms-node-ref (car derivation) new-bnode)
			    tms:justification
			    cnode)
		      (for-each
		       (lambda (just)
			 (%gen-just-rule (car just) cnode emit)
			 (%gen-just-expr (cadr just) cnode emit new-bnode))
		       (cdr derivation))))
		  derivations)))
    (make-rdf-graph output)))

(define (%gen-just-rule rule cnode emit)
  (let ((name (%tms-rule-name rule)))
    (if name
	(emit cnode tms:rule-name name))))

(define (%gen-just-expr expr cnode emit new-bnode)
  (let ((handle-ref (lambda (ref) (emit cnode tms:antecedent-expr ref))))
    (let loop
	((expr expr)
	 (handle-ref handle-ref)
	 (handle-node (%simple-node-handler handle-ref new-bnode)))
      (if (tms:node? expr)
	  (handle-node expr)
	  (let ((bnode (make-rdf-bnode)))
	    (handle-ref bnode)
	    (emit bnode rdf:type (%tms-expr-class expr))
	    (let ((handle-ref (lambda (ref) (emit bnode tms:sub-expr ref))))
	      (let ((k
		     (lambda (handle-node)
		       (for-each (lambda (expr)
				   (loop expr handle-ref handle-node))
				 (cdr expr)))))
		(if (eq? (car expr) 'and)
		    (%with-tms-node-handler new-bnode handle-ref k)
		    (k (%simple-node-handler handle-ref new-bnode))))))))))

(define (%simple-node-handler handle-ref new-bnode)
  (lambda (node)
    (let ((ref (%tms-node-ref node new-bnode)))
      (if ref
	  (handle-ref ref)))))

(define (%with-tms-node-handler new-bnode handle-ref procedure)
  (let ((triples '()))
    (procedure
     (lambda (node)
       (let ((datum (tms:node-datum node)))
	 (cond ((amord:rule? datum)
		(handle-ref (amord:rule-name datum)))
	       ((amord:ctx? datum)
		(handle-ref (new-bnode datum)))
	       ((and (pair? datum)
		     (eq? (car datum) air:closed-world-assumption))
		(handle-ref
		 (new-bnode datum
		   (lambda (bnode emit)
		     (emit bnode
			   air:closed-world-assumption
			   (let loop ((uris (cdr datum)))
			     (if (pair? uris)
				 (let ((bnode (make-rdf-bnode)))
				   (emit bnode rdf:type <rdf:list>)
				   (emit bnode rdf:first (car uris))
				   (emit bnode rdf:rest (loop (cdr uris)))
				   bnode)
				 rdf:nil)))))))
	       ((rdf-triple? datum)
		(set! triples (cons datum triples))
		unspecific)
	       ((amord:pattern? datum)
		(set! triples
		      (append (amord:pattern-triples datum)
			      triples))
		unspecific)
	       (else
		(error:bad-range-argument node #f))))))
    (if (pair? triples)
	(handle-ref (make-rdf-graph triples)))))

(define (amord:rule-hidden? rule system)
  (cond ((uri? rule)
	 (if (or (eq? rule air:composite-justification)
		 (eq? rule air:assumption)
		 (eq? rule air:implicit-goal))
	     #t
	     (amord:rule-hidden? (amord:registered-rule rule system) system)))
	((amord:rule? rule)
	 (let loop ((rule rule))
	   (or (amord:rule-flagged? rule 'hidden)
	       (let ((rule* (amord:rule-container rule)))
		 (and rule*
		      (loop rule*))))))
	(else (error:not-amord:rule rule 'amord:rule-hidden?))))

(define (%tms-rule-name rule)
  (cond ((or (eq? rule air:composite-justification)
	     (eq? rule air:implicit-goal))
	 rule)
	((amord:rule? rule) (amord:rule-name rule))
	(else #f)))

(define (%optimize-just-expr expr)
  (if (tms:node? expr)
      (and (or (tms:node-assumed? expr)
	       (%tms-node-ref expr #f))
	   expr)
      (case (car expr)
	((and)
	 (let ((subexprs
		(append-map (lambda (expr)
			      (let ((expr (%optimize-just-expr expr)))
				(cond ((and (pair? expr)
					    (eq? (car expr) 'and))
				       (cdr expr))
				      ((not expr) '())
				      (else (list expr)))))
			    (cdr expr))))
	   (cond ((null? subexprs) '(and))
		 ((null? (cdr subexprs)) (car subexprs))
		 ((member '(or) subexprs) '(or))
		 (else `(and ,@subexprs)))))
	((or)
	 (let ((subexprs
		(append-map (lambda (expr)
			      (let ((expr (%optimize-just-expr expr)))
				(cond ((and (pair? expr)
					    (eq? (car expr) 'or))
				       (cdr expr))
				      ((not expr) '())
				      (else (list expr)))))
			    (cdr expr))))
	   (cond ((null? subexprs) '(or))
		 ((null? (cdr subexprs)) (car subexprs))
		 ((member '(and) subexprs) '(and))
		 (else `(or ,@subexprs)))))
	((not)
	 (let ((subexpr (%optimize-just-expr (cadr expr))))
	   (if (not subexpr)
	       (error "Can't negate an empty statement:" expr))
	   (cond ((and (pair? subexpr)
		       (eq? (car subexpr) 'not))
		  (cadr subexpr))
		 ((equal? subexpr '(and)) '(or))
		 ((equal? subexpr '(or)) '(and))
		 (else `(not ,subexpr)))))
	(else
	 (error:bad-range-argument expr #f)))))

(define (%tms-expr-class expr)
  (case (car expr)
    ((and) <tms:and-justification>)
    ((or) <tms:or-justification>)
    ((not) <tms:not-justification>)
    (else (error:bad-range-argument expr #f))))

(define (%tms-node-ref node new-bnode)
  (let ((object (tms:node-datum node)))
    (cond ((rdf-triple? object) (make-rdf-graph (list object)))
	  ((amord:rule? object) (amord:rule-name object))
	  ((amord:ctx? object) (if new-bnode (new-bnode object) #t))
	  ((amord:pattern? object)
	   (let ((g (amord:pattern-graph object)))
	     (if (null? (rdf-graph-triples g))
		 #f
		 g)))
	  (else (error:bad-range-argument node #f)))))

;;;; Interface to scheduler

(define (amord:make-event-handler system)
  (let ((scheduler (amord:scheduler system)))
    (lambda (node supported?)
      (let ((object (tms:node-datum node)))
	(cond ((eq? (amord:belief-node object system #f) node)
	       (cond ((amord:rule? object)
		      (amord:maybe-trace system 'enable-rule
			  (lambda (port)
			    (write-string (if supported?
					      "enable rule:    "
					      "disable rule:   ")
					  port)
			    (write object port)))
		      (amord:maybe-trace system 'rule-pattern
			  (lambda (port)
			    (write-string "pattern: " port)
			    (newline port)
			    (write-rdf/turtle-subgraph
			     (amord:pattern-graph (amord:rule-pattern object))
			     port)))
		      (if (amord:rule-matches-goals? object)
			  (amord:event:goal-rule object supported? scheduler)
			  (begin
			    (if supported?
				(amord:assert-goal
				 (amord:rule-pattern object)
				 system
				 (amord:make-justification air:implicit-goal
							   node)))
			    (amord:event:belief-rule object
						     supported?
						     scheduler))))
		     ((rdf-triple? object)
		      (amord:maybe-trace system 'assert-belief
			  (lambda (port)
			    (write-string (if supported?
					      "assert belief:  "
					      "retract belief: ")
					  port)
			    (write-rdf/turtle-triple object port)))
		      (amord:event:belief object supported? scheduler))))
	      ((eq? (amord:goal-node object system #f) node)
	       (cond ((amord:pattern? object)
		      (amord:event:goal object supported? scheduler))
		     ((rdf-triple? object)
		      (amord:maybe-trace system 'assert-goal
			  (lambda (port)
			    (write-string (if supported?
					      "assert goal:    "
					      "retract goal:   ")
					  port)
			    (write-rdf/turtle-triple object port)))))))))))

(define (amord:run system)
  (let loop ()
    (if (or (amord:run-one-action system)
	    (amord:run-one-alternative system))
	(loop))))

(define (amord:run-one-action system)
  (amord:handle-next-action
   (amord:scheduler system)
   (lambda (rule substitute matched)
     (if (and (tms:node-supported? (amord:rule-belief-node rule))
	      (tms:node-supported?
	       (if (amord:rule-matches-goals? rule)
		   (%pattern-goal-node matched system)
		   (%pattern-belief-node matched system))))
	 (amord:maybe-trace system 'run-rule
	     (lambda (port)
	       (write-string "running rule:   " port)
	       (write rule port))
	   (lambda ()
	     (amord:maybe-trace system 'matched-graph
		 (lambda (port)
		   (write-string "matched graph:" port)
		   (newline port)
		   (write-rdf/turtle-subgraph (amord:pattern-graph matched)
					      port)))
	     (let ((substitute (%compose-substitutions substitute rule)))
	       (if (air:condition-satisfied?
		    (amord:map-pattern-vars substitute
					    (amord:rule-condition rule))
		    (if (amord:rule-matches-goals? rule)
			(amord:goal-universe system)
			(amord:belief-universe system)))
		   ((amord:rule-action rule) system
					     (%make-ctx rule
							matched
							substitute))
		   (amord:maybe-trace system 'rule-condition-failure
		       (lambda (port)
			 (write-string "rule condition not satisfied"
				       port)))))))))))

(define (amord:run-one-alternative system)
  (amord:handle-next-alternative
   (amord:scheduler system)
   (lambda (rule)
     (if (tms:node-supported? (amord:rule-belief-node rule))
	 (amord:maybe-trace system 'run-alt
	     (lambda (port)
	       (write-string "running alt:    " port)
	       (write rule port))
	   (lambda ()
	     ((amord:rule-alternative rule)
	      system
	      (%make-ctx rule #f (%rule-substitute rule)))))))))

(define (%pattern-belief-node pattern system)
  (or (amord:belief-node pattern system #f)
      (%composite-just (amord:register-belief-node pattern system)
		       `(and ,@(map (lambda (t)
				      (amord:register-belief-node t system))
				    (amord:pattern-triples pattern))))))

(define (%pattern-goal-node pattern system)
  (or (amord:goal-node pattern system #f)
      (%composite-just (amord:register-goal-node pattern system)
		       (let ((goals
			      (map (lambda (t)
				     (amord:register-goal-node t system))
				   (amord:pattern-triples pattern)))
			     (beliefs
			      (map (lambda (t)
				     (amord:register-belief-node t system))
				   (amord:pattern-triples pattern))))
			 `(and ,@(map (lambda (g b) `(or ,g ,b))
				      goals
				      beliefs)
			       (or ,@goals))))))

(define (%composite-just node expr)
  (amord:justify-node node
		      (amord:make-justification air:composite-justification
						expr))
  node)

(define (%compose-substitutions substitute rule)
  (let ((substitute* (%rule-substitute rule)))
    (if substitute*
	(lambda (var) (substitute (substitute* var)))
	substitute)))

(define (%rule-substitute rule)
  (let ((ctx (amord:rule-ctx rule)))
    (and ctx
	 (amord:ctx-substitute ctx))))

(define (air:condition-triple? triple)
  (eq? (rdf-triple-predicate triple) air:is-variable))

(define (air:condition-satisfied? condition universe)
  universe				;ignore
  (let ((vars (amord:pattern-vars condition)))
    (every (lambda (triple)
	     (if (rdf-boolean-value (rdf-triple-object triple))
		 (amord:var? (rdf-triple-subject triple) vars)
		 (not (amord:var? (rdf-triple-subject triple) vars))))
	   (amord:pattern-triples condition))))

(define (rdf-boolean-value node)
  (if (not (eq? (rdf-literal-type node) <xsd:boolean>))
      (error:wrong-type-argument node "RDF boolean" 'rdf-boolean-value))
  (cond ((string-ci=? (rdf-literal-text node) "true") #t)
	((string-ci=? (rdf-literal-text node) "false") #f)
	(else (error "Ill-formed RDF boolean:" node))))

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