;;;; NS runtime support -- part 1

(declare (usual-integrations))

(define (ns-base-uri uri)
  (let ((eu (current-eval-unit #f)))
    (if eu
	(hash-table/put! %ns-base-uris eu (->absolute-uri uri)))))

(define (get-ns-base-uri)
  (let ((eu (current-eval-unit #f)))
    (and eu
	 (hash-table/get %ns-base-uris eu #f))))

(define %ns-base-uris
  (make-eq-hash-table))

(define (ns-prefix prefix uri)
  (if (not (string=? prefix ":"))
      (let ((uri (->absolute-uri uri)))
	(let ((p (assq uri %ns-prefixes)))
	  (if p
	      (if (not (member prefix (cdr p)))
		  (set-cdr! p (cons prefix (cdr p))))
	      (begin
		(set! %ns-prefixes
		      (cons (list uri prefix)
			    %ns-prefixes))
		unspecific))))))

(define %ns-prefixes
  '())

(define (trips subject . plist)
  (let ((subject (ns-canonicalize-subject subject)))
    (walk-plist (lambda (predicate object)
		  (add-to-rdf-index
		   (make-rdf-triple subject
				    (canonicalize-rdf-predicate predicate)
				    (canonicalize-rdf-object object))
		   ns-index))
		plist)
    subject))

(define (ns-canonicalize-subject subject)
  (if subject
      (canonicalize-rdf-subject subject)
      (make-rdf-bnode)))

(define ns-index
  (make-rdf-index))

(define (walk-plist procedure plist)
  (let loop ((plist plist))
    (if (pair? plist)
	(begin
	  (if (not (pair? (cdr plist)))
	      (error "Odd number of elements in plist:" plist))
	  (procedure (car plist) (cadr plist))
	  (loop (cddr plist)))
	(if (not (null? plist))
	    (error "Ill-formed plist tail:" plist)))))

(define (map-plist procedure plist)
  (let loop ((plist plist))
    (if (pair? plist)
	(begin
	  (if (not (pair? (cdr plist)))
	      (error "Odd number of elements in plist:" plist))
	  (cons (procedure (car plist) (cadr plist))
		(loop (cddr plist))))
	(begin
	  (if (not (null? (cdr plist)))
	      (error "Ill-formed plist tail:" plist))
	  '()))))

;;;; Simple search

(define (search-index subject predicate object)
  (intersect-triples
   (and subject
	(triples-with-subject (canonicalize-rdf-subject subject)
			      ns-index))
   (and predicate
	(triples-with-predicate (canonicalize-rdf-predicate predicate)
				ns-index))
   (and object
	(triples-with-object (canonicalize-rdf-object object)
			     ns-index))))

(define (intersect-triples . tss)
  (reduce (lambda (ts1 ts2)
	    (let loop ((ts1 ts1) (result '()))
	      (if (pair? ts1)
		  (loop (cdr ts1)
			(if (memq (car ts1) ts2)
			    (cons (car ts1) result)
			    result))
		  result)))
	  '()
	  (keep-matching-items tss (lambda (ts) ts))))

(define (exists-triple? subject predicate object)
  (test-intersect-triples
   (and subject
	(triples-with-subject (canonicalize-rdf-subject subject)
			      ns-index))
   (and predicate
	(triples-with-predicate (canonicalize-rdf-predicate predicate)
				ns-index))
   (and object
	(triples-with-object (canonicalize-rdf-object object)
			     ns-index))))

(define (test-intersect-triples sts pts ots)
  (if sts
      (if pts
	  (if ots
	      (there-exists? sts
		(lambda (t)
		  (and (memq t pts)
		       (memq t ots))))
	      (there-exists? sts
		(lambda (t)
		  (memq t pts))))
	  (if ots
	      (there-exists? sts
		(lambda (t)
		  (memq t ots)))
	      (pair? sts)))
      (if pts
	  (if ots
	      (there-exists? pts
		(lambda (t)
		  (memq t ots)))
	      (pair? pts))
	  (pair? ots))))

(define (triples-with-subject subject index)
  (hash-table/get (rdf-index-subjects index) subject '()))

(define (triples-with-predicate predicate index)
  (hash-table/get (rdf-index-predicates index) predicate '()))

(define (triples-with-object object index)
  (hash-table/get (rdf-index-objects index) object '()))

;;;; RDF/N3 dump

(define (write-ns-index-as-n3 pathname)
  (call-with-output-file pathname
    (lambda (port)
      (port/set-coding port 'UTF-8)
      (let ((prefix-alist
	     (map (lambda (p)
		    (cons (uri->string (car p))
			  (cadr p)))
		  %ns-prefixes)))
	(for-each (lambda (p)
		    (write-string "@prefix " port)
		    (write-string (cdr p) port)
		    (write-string " <" port)
		    (write-string (car p) port)
		    (write-string "> ." port)
		    (newline port))
		  prefix-alist)
	(newline port)
	(let ((write-uri
	       (lambda (uri port)
		 (let ((s (uri->string uri)))
		   (let ((p
			  (find-matching-item prefix-alist
			    (lambda (p)
			      (string-prefix? (car p) s)))))
		     (if p
			 (begin
			   (write-string (cdr p) port)
			   (write-substring s
					    (string-length (car p))
					    (string-length s)
					    port))
			 (begin
			   (write-string "<" port)
			   (write-string s port)
			   (write-string ">" port))))))))
	  (for-each (lambda (p)
		      (let ((subject (car p))
			    (triples (cdr p)))
			(if (rdf-bnode? subject)
			    (write-bnode subject port)
			    (write-uri subject port))
			(newline port)
			(let ((write-arc
			       (lambda (t suffix)
				 (write-string "    " port)
				 (write-uri (rdf-triple-predicate t) port)
				 (write-string " " port)
				 (let ((o (rdf-triple-object t)))
				   (cond ((rdf-bnode? o)
					  (write-bnode o port))
					 ((rdf-literal? o)
					  (write-literal o port))
					 (else
					  (write-uri o port))))
				 (write-string suffix port)
				 (newline port))))
			  (do ((triples triples (cdr triples)))
			      ((not (pair? triples)))
			    (write-arc (car triples)
				       (if (pair? (cdr triples))
					   " ;"
					   " ."))))
			(newline port)))
		    (hash-table->alist (rdf-index-subjects ns-index))))))))

(define (write-bnode bnode port)
  (write-string "_:" port)
  (write-string (rdf-bnode-name bnode) port))

(define (write-literal literal port)
  (write-char #\" port)
  (write-literal-text (rdf-literal-text literal) port)
  (write-char #\" port)
  (cond ((rdf-literal-type literal)
	 => (lambda (uri)
	      (write-string "^^" port)
	      (write-uri-ref uri port)))
	((rdf-literal-language literal)
	 => (lambda (lang)
	      (write-char #\@ port)
	      (write-string (symbol-name lang) port)))))

(define (write-literal-text text port)
  (let ((text (open-input-string text)))
    (port/set-coding text 'UTF-8)
    (let loop ()
      (let ((char (read-char text)))
	(if (not (eof-object? char))
	    (begin
	      (write-literal-char char port)
	      (loop)))))))

(define (write-literal-char char port)
  (if (char-set-member? char-set:unescaped char)
      (write-char char port)
      (begin
	(write-char #\\ port)
	(if (or (char=? char #\")
		(char=? char #\\))
	    (write-char char port)
	    (let ((n (char->integer char)))
	      (cond ((fix:= n #x9) (write-char #\t port))
		    ((fix:= n #xA) (write-char #\n port))
		    ((fix:= n #xD) (write-char #\r port))
		    ((fix:< n #x10000) (write-hex n 4 port))
		    (else (write-hex n 8 port))))))))

(define (write-hex n digits port)
  (let loop ((n n) (m (expt 16 digits)))
    (if (> m 1)
	(begin
	  (write-char (string-ref "0123456789ABCDEF" (quotient n m)) port)
	  (loop (remainder n m) (quotient m 16))))))

(define char-set:character
  (ascii-range->char-set #x20 #x7F))

(define char-set:unescaped
  (char-set-difference char-set:character (char-set #\" #\\)))

(define (ns-uri->qname uri)
  (let ((uri (->absolute-uri uri)))
    (let ((s (uri->string uri)))
      (let loop ((alist %ns-prefixes))
	(if (pair? alist)
	    (let ((prefix (uri->string (caar alist))))
	      (if (string-prefix? prefix s)
		  (symbol (cadar alist)
			  (string-tail s (string-length prefix)))
		  (loop (cdr alist))))
	    uri)))))

(define (ns-qname->uri qname)
  (if (uri? qname)
      qname
      (let ((entry
	     (let ((prefix
		    (string-append (symbol-name (xml-qname-prefix qname))
				   ":")))
	       (find-matching-item %ns-prefixes
		 (lambda (entry)
		   (member prefix (cdr entry)))))))
	(if (not entry)
	    (error "Unknown name:" qname))
	(string->uri
	 (string-append (uri->string (car entry))
			(symbol-name (xml-qname-local qname)))))))