#| -*-Scheme-*-

$Id: patterns.scm 10153 2008-01-15 05:10:49Z 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 patterns

(declare (usual-integrations))

(define-record-type <amord:pattern>
    (%make-pattern graph vars)
    amord:pattern?
  (graph amord:pattern-graph)
  (vars amord:pattern-vars))

(define-guarantee amord:pattern "AMORD pattern")

(define (amord:make-pattern graph vars #!optional ctx)
  (guarantee-list vars 'amord:make-pattern)
  (for-each (lambda (var) (guarantee-uri var 'amord:make-pattern)) vars)
  (let ((graph
	 (if (or (default-object? ctx) (not ctx))
	     graph
	     (%map-graph-vars (amord:ctx-substitute ctx) graph vars))))
    (let ((vars (amord:vars-used-in-graph graph vars)))
      (let ((p
	     (hash-table/intern! %pattern-cache graph
	       (lambda ()
		 (list 'patterns)))))
	(or (find (lambda (pattern)
		    (eqv-set=? (amord:pattern-vars pattern) vars))
		  (cdr p))
	    (let ((pattern (%make-pattern graph vars)))
	      (set-cdr! p (cons pattern (cdr p)))
	      pattern))))))

(define %pattern-cache
  (make-eq-hash-table))

(define (amord:vars-used-in-graph graph vars)
  (eqv-union*
   (map (lambda (t) (amord:vars-used-in-triple t vars))
	(rdf-graph-triples graph))))

(define (amord:vars-used-in-triple triple vars)
  (let ((elt-vars
	 (lambda (elt)
	   (if (amord:var? elt vars)
	       (list elt)
	       '()))))
    (eqv-union (elt-vars (rdf-triple-subject triple))
	       (elt-vars (rdf-triple-predicate triple))
	       (elt-vars (rdf-triple-object triple)))))

(define (amord:extract-condition graph)
  (let loop ((ts (rdf-graph-triples graph)) (gts '()) (cts '()))
    (if (pair? ts)
	(if (air:condition-triple? (car ts))
	    (loop (cdr ts) gts (cons (car ts) cts))
	    (loop (cdr ts) (cons (car ts) gts) cts))
	(values (make-rdf-graph gts)
		(make-rdf-graph cts)))))

(define (amord:pattern-triples pattern)
  (rdf-graph-triples (amord:pattern-graph pattern)))

(define (amord:map-pattern-vars procedure pattern)
  (amord:make-pattern (%map-graph-vars procedure
				       (amord:pattern-graph pattern)
				       (amord:pattern-vars pattern))
		      '()))

(define (%map-graph-vars procedure graph vars)
  (make-rdf-graph
   (map (lambda (t)
	  (let ((do-node
		 (lambda (node)
		   (if (amord:var? node vars)
		       (or (procedure node) node)
		       node))))
	    (make-rdf-triple (do-node (rdf-triple-subject t))
			     (do-node (rdf-triple-predicate t))
			     (do-node (rdf-triple-object t)))))
	(rdf-graph-triples graph))))

(define (amord:contradiction-pattern)
  (amord:make-pattern amord:contradiction-graph '()))

(define (amord:contradiction-pattern? pattern)
  (eq? (amord:pattern-graph pattern) amord:contradiction-graph))

(define amord:contradiction-graph
  (make-rdf-graph
   (list (make-rdf-triple (make-rdf-bnode)
			  rdf:type
			  <air:contradiction>))))

(define (amord:partition-pattern pattern)
  (let ((parts '()))
    (for-each
     (lambda (t)
       (set! parts
	     (let ((vars
		    (amord:vars-used-in-triple t
					       (amord:pattern-vars pattern))))
	       (let ((parts*
		      (filter (lambda (part)
				(eqv-sets-intersect? (car part) vars))
			      parts))
		     (part (list vars t)))
		 (if (pair? parts*)
		     (cons (let ((parts* (cons part parts*)))
			     (cons (eqv-union* (map car parts*))
				   (eqv-union* (map cdr parts*))))
			   (remove! (lambda (f) (memq f parts*))
				    parts))
		     (cons part parts)))))
       unspecific)
     (amord:pattern-triples pattern))
    (map (lambda (part)
	   (amord:make-pattern (make-rdf-graph (cdr part)) (car part)))
	 parts)))

(define (amord:rename-pattern pattern)
  (let ((table (make-eq-hash-table)))
    (let ((graph
	   (%map-graph-vars (lambda (var)
			      (hash-table/intern! table var
				amord:make-global-var))
			    (amord:pattern-graph pattern)
			    (amord:pattern-vars pattern))))
      (amord:make-pattern graph
			  (hash-table/datum-list table)))))

(define (amord:equivalent-patterns? p1 p2)
  (let ((ts1 (amord:pattern-triples p1))
	(v1 (amord:pattern-vars p1))
	(ts2 (amord:pattern-triples p2))
	(v2 (amord:pattern-vars p2)))
    (let loop ((ts1 ts1) (ts2 ts2) (dict '()))
      (if (pair? ts1)
	  (let ((t1 (car ts1))
		(ts1 (cdr ts1)))
	    (any (lambda (t2)
		   (let ((dict* (%simple-match-triples t1 v1 t2 v2 dict)))
		     (and dict*
			  (loop ts1 (delq t2 ts2) dict*))))
		 ts2))
	  (null? ts2)))))

(define (%simple-match-triples t1 v1 t2 v2 dict)
  (let ((match
	 (lambda (accessor dict)
	   (let ((e1 (accessor t1))
		 (e2 (accessor t2)))
	     (if (amord:var? e1 v1)
		 (let ((p (assq e1 dict)))
		   (if p
		       (and (eqv? (cdr p) e2)
			    dict)
		       (and (amord:var? e2 v2)
			    (cons (cons e1 e2) dict))))
		 (and (eqv? e2 e1)
		      dict))))))
    (let ((d1 (match rdf-triple-subject dict)))
      (and d1
	   (let ((d2 (match rdf-triple-predicate d1)))
	     (and d2
		  (match rdf-triple-object d2)))))))

(define (amord:make-global-var)
  (string->absolute-uri
   (string-append %global-var-prefix
		  (vector-8b->hexadecimal (random-byte-vector 8)))))

(define (amord:global-var? elt)
  (and (uri? elt)
       (string-prefix? %global-var-prefix (uri->string elt))))

(define %global-var-prefix
  (string-append (rdf-prefix-expansion 'air:) "GV-"))

(define (amord:var? elt vars)
  (or (memq elt vars)
      (amord:global-var? elt)))