#| -*-Scheme-*-

$Id: compile-policy.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.

|#

;;;; Compiler for AIR policy elements

(declare (usual-integrations))

(define (compile-policy-file input output)
  (let ((exprs
	 (compile-policies (make-tstore (amord:read-turtle-file input)))))
    (with-notification (lambda (port)
			 (write-string "Writing: " port)
			 (write (enough-namestring output) port))
      (lambda ()
	(call-with-output-file output
	  (lambda (port)
	    (write-string ";;; This file generated from " port)
	    (write-string (->namestring input) port)
	    (newline port)
	    (write-string ";;; on " port)
	    (write-string (universal-time->local-iso8601-string
			   (get-universal-time))
			  port)
	    (newline port)
	    (for-each (lambda (expr)
			(newline port)
			(pp expr port))
		      exprs)))))))

(define (compile-policies tstore)
  (fluid-let ((*name-counter* 0)
	      (*load-time-prefixes* '())
	      (*load-time-objects* (make-eq-hash-table))
	      (*load-time-bindings* '()))
    (let ((vars (filter uri? (find-resources-of-type <air:variable> tstore))))
      (let ((actions
	     (append-map!
	      (lambda (policy)
		(compile-actions policy
				 (append (find-local-vars policy tstore) vars)
				 tstore))
	      (find-resources-of-type <air:policy> tstore))))
	`((declare (usual-integrations))
	  ,@(map (lambda (prefix)
		   `(register-rdf-prefix ',prefix
					 ,(rdf-prefix-expansion prefix)))
		 *load-time-prefixes*)
	  ,(load-time-binding-expr
	    `(lambda (system ctx)
	       (list ,@actions))))))))

(define *name-counter*)
(define *load-time-prefixes*)
(define *load-time-objects*)
(define *load-time-bindings*)

(define (compile-actions container vars tstore)
  (append-map! (lambda (p)
		 (map (lambda (resource)
			((cdr p) resource vars tstore))
		      (find-multiple-values container (car p) tstore)))
	       action-compilers))

(define (define-action-compiler property compiler)
  (let ((p (assq property action-compilers)))
    (if p
	(set-cdr! p compiler)
	(begin
	  (set! action-compilers
		(cons (cons property compiler) action-compilers))
	  unspecific))))

(define action-compilers '())

(define-action-compiler air:rule
  (lambda (rule vars tstore)
    (compile-rule 'amord:belief-rule
		  rule
		  (compile-justification rule tstore)
		  vars
		  tstore)))

(define-action-compiler air:goal-rule
  (lambda (rule vars tstore)
    (compile-rule 'amord:goal-rule
		  rule
		  (compile-justification rule tstore)
		  vars
		  tstore)))

(define-action-compiler air:assertion
  (lambda (assertion vars tstore)
    (compile-assertion 'amord:assert
		       (find-action-statement assertion tstore)
		       (compile-justification assertion tstore)
		       vars)))

(define-action-compiler air:goal-assertion
  (lambda (assertion vars tstore)
    (compile-assertion 'amord:assert-goal
		       (find-action-statement assertion tstore)
		       (compile-justification assertion tstore)
		       vars)))

(define-action-compiler air:assert
  (lambda (graph vars tstore)
    tstore
    (compile-assertion 'amord:assert
		       graph
		       (compile-default-justification)
		       vars)))

(define-action-compiler air:assert-goal
  (lambda (graph vars tstore)
    tstore
    (compile-assertion 'amord:assert-goal
		       graph
		       (compile-default-justification)
		       vars)))

(define (compile-rule constructor rule just-expr vars tstore)
  (let ((vars* (append (find-local-vars rule tstore) vars))
	(pattern-graph (find-required-value rule air:pattern tstore))
	(matched-var (find-optional-value rule air:matched-graph tstore))
	(alt (find-optional-value rule air:alt tstore)))
    (let ((actions (compile-actions rule vars* tstore))
	  (alt-actions (if alt (compile-actions alt vars tstore) '())))
      (receive (graph condition) (amord:extract-condition pattern-graph)
	`(,constructor ,(compile-resource rule)
		       ,(compile-pattern graph vars*)
		       ,(compile-pattern condition vars*)
		       system
		       ctx
		       ,(if matched-var
			    (compile-resource matched-var)
			    '#f)
		       ,(if (find-triple rule rdf:type <air:hidden-rule>
					 tstore)
			    '#t
			    '#f)
		       (lambda (system ctx) ,@actions)
		       ,(if (pair? alt-actions)
			    `(lambda (system ctx) ,@alt-actions)
			    '#f)
		       ,just-expr)))))

(define (compile-assertion action graph just-expr vars)
  `(,action ,(compile-pattern graph vars)
	    system
	    ,just-expr))

(define (compile-justification resource tstore)
  (let ((just (find-optional-value resource air:justification tstore)))
    (if just
	(compile-explicit-justification
	 (find-required-value just air:rule-id tstore)
	 (find-multiple-values just air:antecedent tstore))
	(compile-default-justification))))

(define (compile-explicit-justification rule antecedents)
  `(let ((rule (amord:registered-rule ,(compile-resource rule) system)))
     (amord:make-justification
      rule
      (list 'and
	    (amord:rule-belief-node rule)
	    ,@(map (lambda (name)
		     `(amord:resolve-antecedent ,(compile-resource name)
						ctx))
		   antecedents)))))

(define (compile-default-justification)
  '(amord:default-justification ctx))

(define (find-action-statement action tstore)
  (find-required-value action air:statement tstore))

(define (find-local-vars container tstore)
  (find-multiple-values container air:variable tstore))

(define (compile-pattern graph vars)
  `(amord:make-pattern ,(compile-graph graph)
		       ,(compile-resource-list
			 (amord:vars-used-in-graph graph vars))
		       ctx))

(define (compile-resource-list resources)
  (load-time-binding resources
		     (lambda (resources)
		       `(list ,@(map compile-resource resources)))))

(define (compile-resource resource)
  (cond ((uri? resource)
	 (cond ((uri->scheme-var resource)
		=> (lambda (var-name)
		     var-name))
	       ((uri->rdf-qname resource #!default #f)
		=> (lambda (qname)
		     (let ((prefix (rdf-qname-prefix qname)))
		       (if (not (memq prefix *load-time-prefixes*))
			   (begin
			     (set! *load-time-prefixes*
				   (cons prefix *load-time-prefixes*))
			     unspecific)))
		     (load-time-binding
		      resource
		      (lambda (uri)
			`(rdf-qname->uri ',(uri->rdf-qname uri)))
		      qname)))
	       (else
		(load-time-binding resource
				   (lambda (uri)
				     `(string->uri ,(uri->string uri)))))))
	((rdf-bnode? resource)
	 (load-time-binding resource
			    (lambda (bnode) bnode '(make-rdf-bnode))))
	((rdf-literal? resource)
	 (load-time-binding
	  resource
	  (lambda (literal)
	    `(make-rdf-literal ,(rdf-literal-text literal)
			       ,(let ((type (rdf-literal-type literal)))
				  (if type
				      (compile-resource type)
				      (rdf-literal-language literal)))))))
	((rdf-graph? resource)
	 (compile-graph resource))
	(else
	 (error:wrong-type-argument resource "RDF resource"
				    'compile-resource))))

(define (compile-graph graph)
  (load-time-binding
   graph
   (lambda (graph)
     `(make-rdf-graph
       (list ,@(map compile-triple (rdf-graph-triples graph)))))))

(define (compile-triple t)
  (load-time-binding
   t
   (lambda (t)
     `(make-rdf-triple ,(compile-resource (rdf-triple-subject t))
		       ,(compile-resource (rdf-triple-predicate t))
		       ,(compile-resource (rdf-triple-object t))))))

(define (load-time-binding object make-expr #!optional var-name)
  (cond ((pair? object)
	 (let ((binding
		(find (lambda (binding)
			(and (pair? (car binding))
			     (eqv-set=? (car binding) object)))
		      *load-time-bindings*)))
	   (if binding
	       (cadr binding)
	       (let* ((expr (make-expr object))
		      (name (load-time-binding-name object var-name)))
		 (set! *load-time-bindings*
		       (cons (list object name expr)
			     *load-time-bindings*))
		 name))))
	((null? object)
	 ''())
	((hash-table-ref/default *load-time-objects* object #f)
	 => (lambda (name)
	      (if (eq? name #t)
		  (error "Cycle in graph structure:" object))
	      name))
	(else
	 (hash-table-set! *load-time-objects* object #t)
	 (let ((expr (make-expr object)))
	   (let ((name (load-time-binding-name object var-name)))
	     (hash-table-set! *load-time-objects* object name)
	     (set! *load-time-bindings*
		   (cons (list object name expr)
			 *load-time-bindings*))
	     name)))))

(define (load-time-binding-name object var-name)
  (if (default-object? var-name)
      (symbol (cond ((pair? object) 'l)
		    ((uri? object) 'u)
		    ((rdf-bnode? object) 'b)
		    ((rdf-literal? object) 's)
		    ((rdf-graph? object) 'g)
		    ((rdf-triple? object) 't)
		    (else 'v))
	      (get-name-number))
      var-name))

(define (get-name-number)
  (let ((n (+ *name-counter* 1)))
    (set! *name-counter* n)
    n))

(define (load-time-binding-expr body)
  (let ((bindings (optimize-bindings body (reverse *load-time-bindings*))))
    (receive (uris other)
	(partition (lambda (binding)
		     (uri? (car binding)))
		   bindings)
      (receive (bnodes other)
	  (partition (lambda (binding)
		       (rdf-bnode? (car binding)))
		     other)
	`(let (,@(map cdr
		      (sort uris
			(lambda (b1 b2)
			  (symbol<? (cadr b1) (cadr b2)))))
	       ,@(map cdr bnodes))
	   (let* (,@(map cdr other))
	     ,body))))))

(define (optimize-bindings body bindings)
  (let ((bindings
	 (map (lambda (binding)
		(cons 0 binding))
	      bindings)))
    (count-expr-refs! body bindings)
    (let ((unref
	   (remove (lambda (binding)
		     (or (> (car binding) 0)
			 (uri? (cadr binding))))
		   bindings)))
      (for-each (lambda (binding)
		  (count-expr-refs! (cadddr binding) bindings))
		bindings)
      (for-each (lambda (binding)
		  (set-car! (cdddr binding)
			    (subst-expr-refs (cadddr binding) unref)))
		bindings))
    (map cdr
	 (filter (lambda (binding)
		   (> (car binding) 0))
		 bindings))))

(define (count-expr-refs! expr bindings)
  (let loop ((expr expr))
    (cond ((pair? expr)
	   (if (not (list? (cdr expr)))
	       (error "Malformed expr:" expr))
	   (if (not (eq? (car expr) 'quote))
	       (for-each loop expr)))
	  ((symbol? expr)
	   (let ((binding
		  (find (lambda (binding)
			  (eq? (caddr binding) expr))
			bindings)))
	     (if binding
		 (set-car! binding (+ (car binding) 1))))))))

(define (subst-expr-refs expr bindings)
  (let loop ((expr expr))
    (cond ((pair? expr)
	   (if (eq? (car expr) 'quote)
	       expr
	       (map loop expr)))
	  ((symbol? expr)
	   (let ((binding
		  (find (lambda (binding)
			  (eq? (caddr binding) expr))
			bindings)))
	     (if (and binding (= (car binding) 1))
		 (begin
		   (set-car! binding 0)
		   (cadddr binding))
		 expr)))
	  (else expr))))