;;; -*-Scheme-*-

;;; Make sure that "officials" can be distinguished from other people
;;; in the transaction data.

;;; Restructure transaction data so that is organized as a partial
;;; time order, showing only the data that is available at any
;;; particular event in the sequence.

;;; Always use URI for source/recipient, purpose, and category,
;;; allocated automatically on demand.

;;; Authorized purposes might be parameterized on the source/recipient
;;; or category of the data-flow.  Maybe the other things are
;;; parameterized too?

;;; Many SORNs do not fully specify the data-flow information.  These
;;; need to be detected and flagged.

(ns-prefix s3: "http://dig.csail.mit.edu/TAMI/scenario3#")
(ns-prefix ts: "http://dig.csail.mit.edu/TAMI/tami-schema#")
(ns-prefix te: "http://dig.csail.mit.edu/TAMI/tami-entities#")
(ns-prefix sorn: "http://dig.csail.mit.edu/TAMI/sorn-schema#")
(ns-prefix sf: "http://dig.csail.mit.edu/TAMI/sorn#")
(ns-prefix j: "http://www.niem.gov/niem/domains/justice/0.1#")

(define (get subject predicate)
  (let ((objects (get-all subject predicate)))
    (if (pair? objects)
	(begin
	  (if (pair? (cdr objects))
	      (error "Multiple property values:" objects))
	  (car objects))
	#f)))

(define (get! subject predicate)
  (let ((object (get subject predicate)))
    (if (not object)
	(error "Missing required predicate:" predicate subject))
    object))

(define (get-all subject predicate)
  (map rdf-triple-object (search-index subject predicate #f)))

(define (subject-properties subject)
  (map (lambda (t)
	 (list (rdf-triple-predicate t)
	       (rdf-triple-object t)))
       (search-index subject #f #f)))

(define (resources-of-type type)
  (map rdf-triple-subject
       (keep-matching-items (search-index #f rdfs:type #f)
	 (lambda (t)
	   (subclass? (rdf-triple-object t) type)))))

(define (resource-of-type? subject type)
  (there-exists? (resource-types subject)
    (lambda (o)
      (subclass? o type))))

(define (resource-types subject)
  (get-all subject rdfs:type))

(define (subclass? c1 c2)
  (let ((c1 (canonicalize-rdf-subject c1))
	(c2 (canonicalize-rdf-subject c2)))
    (if (eq? c1 c2)
	#t
	(let loop ((c1 c1))
	  (let ((superclasses (get-all c1 rdfs:subClassOf)))
	    (if (memq c2 superclasses)
		#t
		(there-exists? superclasses
		  loop)))))))

(define (transfer? resource)
  (resource-of-type? resource ts:Transfer))

(define (official? resource)
  (resource-of-type? resource ts:Official))

(define (office? resource)
  (resource-of-type? resource ts:Office))

(define (organization? resource)
  (resource-of-type? resource ts:Organization))

(define (sor? resource)
  (resource-of-type? resource sorn:SOR))

(define (employer-of subject)
  (get! (get! subject ts:work) ts:employer))

(define (transfer-source transfer)
  (get! transfer sorn:source))

(define (transfer-recipient transfer)
  (get! transfer sorn:recipient))

(define (transfer-purposes transfer)
  (let ((purposes (get-all transfer sorn:purpose)))
    (if (pair? purposes)
	purposes
	(all-purposes))))

(define (purpose? resource)
  (resource-of-type? resource sorn:Authorized-purpose))

(define (purpose-statutes purpose)
  (get-all purpose ts:statute))

(define (event-date event)
  (get! event dc:date))

(define (event-antecedent event)
  (get event ts:antecedent))

(define (arrest? resource)
  (resource-of-type? resource j:Arrest))

(define (arrest-charge arrest)
  (get! arrest j:arrestCharge))

(define (sor-notice sor)
  (get! sor sorn:notice))

(define (sorn-sources sorn)
  (get-all sorn sorn:source))

(define (sorn-recipients sorn)
  (get-all sorn sorn:recipient))

(define (sorn-purposes sorn)
  (get-all sorn sorn:purpose))

(define (sorn-uses sorn)
  (get-all sorn sorn:routine-use))

(define (organization<=? a b)
  (cond ((eq? a b) #t)
	((office? a)
	 (let ((c (get a ts:organization)))
	   (and c
		(organization<=? c b))))
	((organization? a)
	 (let ((c (get a ts:partOf)))
	   (and c
		(organization<=? c b))))
	((official? a)
	 (let ((e (get a ts:employment)))
	   (and e
		(let ((c
		       (or (get e ts:office)
			   (get e ts:organization))))
		  (and c
		       (organization<=? c b))))))
	(else #f)))

(define (antecedent-chain event)
  (let ((event (canonicalize-rdf-subject event)))
    (cons event
	  (let ((event* (event-antecedent event)))
	    (if event*
		(antecedent-chain event*)
		'())))))

(define (show-sorn-data event)
  (if (transfer? event)
      (let ((write-prop
	     (lambda (keyword property)
	       (let ((objects (get-all event property)))
		 (if (pair? objects)
		     (write-line (cons keyword objects)))))))
	(newline)
	(write-line event)
	(write-prop 'sources sorn:source)
	(write-prop 'recipients sorn:recipient)
	(write-prop 'categories sorn:category)
	(write-prop 'purposes sorn:purpose))))

(define (check-antecedent-chain event)
  (let ((purposes
	 (check-transfers
	  (reverse
	   (keep-matching-items (antecedent-chain event) transfer?)))))
    (if (resource-of-type? event j:Arrest)
	(let ((statute (get! event j:arrestCharge)))
	  (if (not (there-exists? purposes
		     (lambda (purpose)
		       (there-exists? (get-all purpose ts:statute)
			 (lambda (statute*)
			   (statute<=? statute statute*))))))
	      (pp (cons* event 'not-justified-by purposes)))))))

(define (check-transfers transfers)
  (let loop ((transfers transfers) (purposes '()))
    (if (pair? transfers)
	(loop (cdr transfers)
	      (check-transfer (car transfers) purposes))
	purposes)))

(define (check-transfer transfer purposes)
  (let ((source (transfer-source transfer))
	(recipient (transfer-recipient transfer))
	(tf-purposes (transfer-purposes transfer)))
    (cond ((sor? source)
	   (append-map (lambda (use)
			 (get-all use sorn:purpose))
		       (keep-matching-items
			   (get-all (get! source sorn:notice) sorn:routine-use)
			 (lambda (use)
			   (organization<=? recipient
					    (get! use sorn:recipient))))))
	  (else purposes))))