#| -*-Scheme-*-

$Id: rdf-match.scm 7258 2007-11-27 02:10:05Z 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.

|#

;;;; RDF pattern matcher

(declare (usual-integrations))

(define (rdf-match triples vars universe unmatched-too?)
  (let loop ((triples triples) (vars vars))
    (stream-delay
     (if (pair? triples)
	 (receive (triple triples)
	     (choose-pattern-triple-to-match triples vars)
	   (stream-append-map
	    (lambda (result)
	      (combine-match-results
	       result
	       (loop (specialize-triples triples (match-result-dict result))
		     (remove-bound-vars vars result))))
	    (match-triple triple vars universe unmatched-too?)))
	 (stream (make-match-result '() '() '() '()))))))

(define (choose-pattern-triple-to-match pattern vars)
  (let loop
      ((triples (cdr pattern))
       (triple (car pattern))
       (score (triple-score (car pattern) vars)))
    (if (and (> score 0)
	     (pair? triples))
	(let ((triple* (car triples))
	      (triples (cdr triples)))
	  (let ((score* (triple-score triple* vars)))
	    (if (< score* score)
		(loop triples triple* score*)
		(loop triples triple score))))
	(values triple (delq triple pattern)))))

(define (triple-score t vars)
  (let ((elt-score
	 (lambda (elt)
	   (if (amord:var? elt vars)
	       1
	       0))))
    (+ (elt-score (rdf-triple-subject t))
       (elt-score (rdf-triple-predicate t))
       (elt-score (rdf-triple-object t)))))

(define (specialize-triples triples dict)
  (delete-duplicates!
   (map (let ((map-elt
	       (lambda (elt)
		 (let ((p (assq elt dict)))
		   (if p
		       (cdr p)
		       elt)))))
	  (lambda (t)
	    (make-rdf-triple (map-elt (rdf-triple-subject t))
			     (map-elt (rdf-triple-predicate t))
			     (map-elt (rdf-triple-object t)))))
	triples)
   eq?))

(define (remove-bound-vars vars result)
  (filter (let ((dict (match-result-dict result)))
	    (lambda (var)
	      (not (assq var dict))))
	  vars))

(define (combine-match-results result results)
  (stream-map (lambda (result*)
		;; The variables in RESULT's dict never appear in RESULT*.
		(make-match-result (append (match-result-dict result)
					   (match-result-dict result*))
				   (eqv-union (match-result-matched result)
					      (match-result-matched result*))
				   (append (specialize-triples
					    (match-result-unmatched result)
					    (match-result-dict result*))
					   (match-result-unmatched result*))
				   (eqv-union (match-result-vars result)
					      (match-result-vars result*))))
	      results))

(define (match-triple pattern vars universe unmatched-too?)
  (let ((id (get-trace-id)))
    (maybe-trace-match id 'attempt-to-match pattern)
    (let ((s (rdf-triple-subject pattern))
	  (p (rdf-triple-predicate pattern))
	  (o (rdf-triple-object pattern)))
      (let ((sv? (subject-var? s vars))
	    (pv? (predicate-var? p vars))
	    (ov? (object-var? o vars)))
	(let ((sd (dict-elt s sv? rdf-triple-subject))
	      (pd (dict-elt p pv? rdf-triple-predicate))
	      (od (dict-elt o ov? rdf-triple-object)))
	  (let loop
	      ((triples
		(universe (if sv? #f s)
			   (if pv? #f p)
			   (if ov? #f o))))
	    (stream-delay
	     (cond ((stream-pair? triples)
		    (let ((t (stream-car triples)))
		      (maybe-trace-match id 'matched t)
		      (stream-cons (make-match-result (append! (sd t)
							       (pd t)
							       (od t))
						      (list t)
						      '()
						      '())
				   (loop (stream-cdr triples)))))
		   (unmatched-too?
		    (stream
		     (make-match-result '()
					'()
					(list pattern)
					(eqv-union (if sv? (list s) '())
						   (if pv? (list p) '())
						   (if ov? (list o) '())))))
		   (else stream-null)))))))))

(define (subject-var? s vars)
  (cond ((amord:var? s vars) #t)
	((rdf-bnode? s) #f)
	((uri? s) #f)
	(else (error "Illegal pattern subject:" s))))

(define (predicate-var? p vars)
  (cond ((amord:var? p vars) #t)
	((uri? p) #f)
	(else (error "Illegal pattern predicate:" p))))

(define (object-var? o vars)
  (cond ((amord:var? o vars) #t)
	((rdf-bnode? o) #f)
	((uri? o) #f)
	((rdf-literal? o) #f)
	(else (error "Illegal pattern object:" o))))

(define (dict-elt x var? get-elt)
  (if var?
      (lambda (t) (list (cons x (get-elt t))))
      (lambda (t) t '())))

(define-record-type <match-result>
    (make-match-result dict matched unmatched vars)
    match-result?
  (dict match-result-dict)
  (matched match-result-matched)
  (unmatched match-result-unmatched)
  (vars match-result-vars))

(define (lookup-in-match-dict var dict)
  (let ((p (assq var dict)))
    (and p
	 (cdr p))))

(define ((rdf-triples->universe triples) subject predicate object)
  (let loop ((triples triples))
    (stream-delay
     (if (pair? triples)
	 (let ((triple (car triples)))
	   (if (let ((test
		      (lambda (pat accessor)
			(cond ((not pat) (not (rdf-graph? (accessor triple))))
			      ((null? pat) #f)
			      ((pair? pat) (memq (accessor triple) pat))
			      (else (eq? (accessor triple) pat))))))
		 (and (test subject rdf-triple-subject)
		      (test predicate rdf-triple-predicate)
		      (test object rdf-triple-object)))
	       (stream-cons triple (loop (cdr triples)))
	       (loop (cdr triples))))
	 stream-null))))

(define (compose-universes . universes)
  (lambda (subject predicate object)
    (apply stream-append
	   (map (lambda (universe)
		  (universe subject predicate object))
		universes))))

(define (maybe-trace-match . items)

  (define (do-list items)
    (map do-item items))

  (define (do-item item)
    (cond ((rdf-triple? item)
	   (vector item
		   (rdf-triple-subject item)
		   (rdf-triple-predicate item)
		   (rdf-triple-object item)))
	  ((list? item) (do-list item))
	  ((pair? item)
	   (list (do-item (car item))
		 (do-item (cdr item))))
	  (else item)))

  (if trace-rdf-match?
      (begin
	(fresh-line)
	(pp (do-list items)))))

(define trace-rdf-match? #f)

(define get-trace-id
  (let ((counter 0))
    (lambda ()
      (let ((n (+ counter 1)))
	(set! counter n)
	n))))