;;; There are events.  
;;; An event may be the transfer of data

;;; The data carries purposes for which
;;; it may be used.

;;; Given an event this procedure produces
;;; the purposes of the data associated with
;;; the event, and the chain of reasoning
;;; that led to this result.

(define (my-uri symbol)
  (->uri
   (string-append "http://dig.csail.mit.edu/TAMI/cph/v2/deduce#"
		  (symbol-name symbol))))

(define (rdf-set-accessor predicate)
  (let ((access (required-rdf-object-accessor predicate)))
    (lambda (node)
      (decode-set (access node)))))

(define (encode-set set)
  (if (universal-set? set)
      set
      (list->rdf-list set)))

(define (decode-set set)
  (if (universal-set? set)
      set
      (rdf-list->list set)))

(define (build-tami-argument event)
  (let ((context (make-context)))
    (accumulate-over-antecedents (rdf-subject-node event)
      (lambda (event antecedents)
	(if (arrest? event)
	    (new-arrest-item context event antecedents)
	    (new-event-item context event antecedents))))))

(define (new-arrest-item context arrest antecedents)
  (let ((charges (arrest:arrest-charge arrest))
	(data (antecedents-data context antecedents)))
    (make-arrest-item context
		      arrest
		      (not (empty-set?
			    (eqv-intersection
			     charges
			     (eqv-big-union
			      (eqv-big-intersection data datum-purposes)
			      authorized-purpose:statute))))
		      data
		      (cons (make-charges context arrest charges ())
			    antecedents))))

;;; Given an event and the chain of reasoning
;;; up to that event, produce the purposes of
;;; the data associated with the event.

(define (new-event-item context event antecedents)
  (cond ((sor-transfer? event)
	 (new-transfer-item context event antecedents))
	((pair? antecedents)
	 (car antecedents))
	(else
	 (make-event-item context
			  event
			  (antecedents-data context antecedents)
			  antecedents))))

(define (new-transfer-item context transfer antecedents)
  (let ((restriction (transfer-restriction context transfer)))
    (make-event-item
     context
     transfer
     (set-map (lambda (datum)
		(new-transfer-purposes context restriction datum))
	      (antecedents-data context antecedents))
     (cons restriction antecedents))))

;; R(s,r)
(define (transfer-restriction context transfer)
  (let ((source (data-flow:source transfer))
	(recipient (transfer:recipient transfer)))
    (make-restriction
     context
     source
     (eqv-big-union (applicable-routine-uses source recipient)
		    data-flow:purposes)
     '())))

;; Z(R(s,r),i)
(define (new-transfer-purposes context restriction datum)
  (make-datum context
	      (datum-record datum)
	      (eqv-intersection (restriction-purposes restriction)
				(datum-purposes datum))
	      (list restriction datum)))

;; A(s,r)
(define (applicable-routine-uses source recipient)
  (subset (sorn:routine-use (sor:notice source))
	  (lambda (ru)
	    (eqv-there-exists? (data-flow:recipient ru)
	      (lambda (organization)
		(organization<=? recipient organization))))))

(define (antecedents-data context antecedents)
  (if (null? antecedents)
      (eqv-set (make-datum context dummy-record universal-set antecedents))
      (data-union* (set-map event-item-data antecedents))))

(define dummy-record
  (my-uri 'dummy-record))

(define (data-union* datas)
  ;; This breaks the set abstraction.
  (reduce (lambda (data1 data2)
	    (let loop
		((data1 data1)
		 (data2 (list-copy data2)))
	      (if (pair? data1)
		  (let ((datum1 (car data1)))
		    (let ((datum2
			   (find-matching-item data2
			     (lambda (datum2)
			       (record=? (datum-record datum2)
					 (datum-record datum1))))))
		      (if datum2
			  (cons (make-datum (item-context datum1)
					    (datum-record datum1)
					    (eqv-union (datum-purposes datum1)
						       (datum-purposes datum2))
					    (list datum1 datum2))
				(loop (cdr data1)
				      (delq! datum2 data2)))
			  (cons datum1
				(loop (cdr data1) data2)))))
		  data2)))
	  (eqv-set)
	  datas))

(define (record=? r1 r2)		;???
  (eqv? r1 r2))

(define (data-flow:purposes flow)
  (let ((purposes
	 (subset (data-flow:purpose flow)
		 (lambda (purpose)
		   (not (eq? purpose tb:any-purpose))))))
    (if (empty-set? purposes)
	universal-set
	purposes)))

(define tb:any-purpose
  (rdf-subject-node 'tb:any-purpose))

;;; Call procedure for each event in the antecedent chain, starting
;;; with the earliest event, and carrying forward the result of the
;;; previous call.

(define (accumulate-over-antecedents event procedure)
  (let loop ((event event))
    (procedure event
	       (let ((antecedent (event:antecedent event)))
		 (if (eq? antecedent tb:no-antecedent)
		     (eqv-set)
		     (eqv-set (loop antecedent)))))))

(define tb:no-antecedent
  (rdf-subject-node '|tb:no-antecedent|))

(define prop/item-antecedents (my-uri 'item-antecedents))
(rdf-link prop/item-antecedents 'rdf:type <rdf:property>)
(define item-antecedents
  (optional-rdf-object-list-accessor prop/item-antecedents))

(define (justify-node node antecedents)
  (let ((just (rdf-subject-node (make-rdf-bnode))))
    (rdf-link just 'rdf:type <justification>)
    (rdf-link just prop/justification-antecedents (encode-set antecedents))
    (rdf-link node prop/item-antecedents just)))

(define <justification> (my-uri 'justification))
(rdf-link <justification> 'rdf:type <rdfs:class>)
(define justification? (rdf-type-predicate <justification>))

(define prop/justification-antecedents (my-uri 'justification-antecedents))
(rdf-link prop/justification-antecedents 'rdf:type <rdf:property>)
(define justification-antecedents
  (rdf-set-accessor prop/justification-antecedents))

;; data is a set
(define (make-event-item context event data antecedents)
  (rdf-link event 'rdf:type <event-item>)
  (rdf-replace-object event prop/event-item-data (encode-set data))
  (justify-node event antecedents)
  event)

(define <event-item> (my-uri 'event-item))
(rdf-link <event-item> 'rdf:type <rdfs:class>)
(define event-item? (rdf-type-predicate <event-item>))

(define prop/event-item-data (my-uri 'event-item-data))
(rdf-link prop/event-item-data 'rdf:type <rdf:property>)
(define event-item-data
  (rdf-set-accessor prop/event-item-data))

;; data is a set
(define (make-arrest-item context arrest justified? data antecedents)
  (rdf-link arrest 'rdf:type <arrest-item>)
  (rdf-replace-object arrest prop/arrest-item-justified
		      (make-rdf-literal (if justified? "true" "false")
					<xsd:boolean>))
  (rdf-replace-object arrest prop/arrest-item-data (encode-set data))
  (justify-node arrest antecedents)
  arrest)

(define <xsd:boolean>
  (->uri '|xsd:Boolean|))

(define <arrest-item> (my-uri 'arrest-item))
(rdf-link <arrest-item> 'rdf:type <rdfs:class>)
(define arrest-item? (rdf-type-predicate <arrest-item>))

(define prop/arrest-item-justified (my-uri 'arrest-item-justified))
(rdf-link prop/arrest-item-justified 'rdf:type <rdf:property>)

(define arrest-item-justified?
  (let ((access (required-rdf-object-accessor prop/arrest-item-justified)))
    (lambda (node)
      (let ((literal (access node))
	    (lose
	     (lambda ()
	       (error:bad-range-argument node 'arrest-item-justified?))))
	(let ((text (rdf-literal-text literal)))
	  (if (not (eq? (rdf-literal-type literal) <xsd:boolean>))
	      (lose))
	  (cond ((string=? text "true") #t)
		((string=? text "false") #f)
		(else (lose))))))))

(define prop/arrest-item-data (my-uri 'arrest-item-data))
(rdf-link prop/arrest-item-data 'rdf:type <rdf:property>)
(define arrest-item-data
  (rdf-set-accessor prop/arrest-item-data))

;; record is an individual
;; purposes is a set
(define (make-datum context record purposes antecedents)
  (let ((node (rdf-subject-node (make-rdf-bnode))))
    (rdf-link node 'rdf:type <datum>)
    (rdf-link node prop/datum-record record)
    (rdf-link node prop/datum-purposes (encode-set purposes))
    (justify-node node antecedents)
    node))

(define <datum> (my-uri 'datum))
(rdf-link <datum> 'rdf:type <rdfs:class>)
(define datum? (rdf-type-predicate <datum>))

(define prop/datum-record (my-uri 'datum-record))
(rdf-link prop/datum-record 'rdf:type <rdf:property>)
(define datum-record
  (required-rdf-object-accessor prop/datum-record))

(define prop/datum-purposes (my-uri 'datum-purposes))
(rdf-link prop/datum-purposes 'rdf:type <rdf:property>)
(define datum-purposes
  (rdf-set-accessor prop/datum-purposes))

(define (make-charges context arrest charges antecedents)
  (let ((node (rdf-subject-node (make-rdf-bnode))))
    (rdf-link node 'rdf:type <charges>)
    (rdf-link node prop/charges-arrest arrest)
    (rdf-link node prop/charges-charges (encode-set charges))
    (justify-node node antecedents)
    node))

(define <charges> (my-uri 'charges))
(rdf-link <charges> 'rdf:type <rdfs:class>)
(define charges? (rdf-type-predicate <charges>))

(define prop/charges-arrest (my-uri 'charges-arrest))
(rdf-link prop/charges-arrest 'rdf:type <rdf:property>)
(define charges-arrest
  (required-rdf-object-accessor prop/charges-arrest))

(define prop/charges-charges (my-uri 'charges-charges))
(rdf-link prop/charges-charges 'rdf:type <rdf:property>)
(define charges-charges
  (rdf-set-accessor prop/charges-charges))

(define (make-restriction context sor purposes antecedents)
  (let ((node (rdf-subject-node (make-rdf-bnode))))
    (rdf-link node 'rdf:type <restriction>)
    (rdf-link node prop/restriction-sor sor)
    (rdf-link node prop/restriction-purposes (encode-set purposes))
    (justify-node node antecedents)
    node))

(define <restriction> (my-uri 'restriction))
(rdf-link <restriction> 'rdf:type <rdfs:class>)
(define restriction? (rdf-type-predicate <restriction>))

(define prop/restriction-sor (my-uri 'restriction-sor))
(rdf-link prop/restriction-sor 'rdf:type <rdf:property>)
(define restriction-sor
  (required-rdf-object-accessor prop/restriction-sor))

(define prop/restriction-purposes (my-uri 'restriction-purposes))
(rdf-link prop/restriction-purposes 'rdf:type <rdf:property>)
(define restriction-purposes
  (rdf-set-accessor prop/restriction-purposes))

(define (make-context)
  unspecific)

(define (item-context item)
  unspecific)

(define (make-item-association)
  (list 'item-association))

(define ((item-association-definer association) predicate datum)
  (let ((p (assq predicate (cdr association))))
    (if p
	(set-cdr! p datum)
	(set-cdr! association
		  (cons (cons predicate datum)
			(cdr association))))))

(define ((item-association-accessor association) item)
  (let loop ((ps (cdr association)))
    (if (not (pair? ps))
	(error "Unable to find related datum:" item))
    (if ((caar ps) item)
	(cdar ps)
	(loop (cdr ps)))))

(define (write-tami-argument node #!optional port)
  (tms:walk-node-support node
    (lambda (node just antecedents support)
      (fresh-line port)
      (newline port)
      (write-string "; " port)
      (write-item-name node port)
      (newline port)
      ((get-item-printer node) node antecedents port)
      (write-line-prefix "supported by" port)
      (write-char #\{ port)
      (if (pair? support)
	  (begin
	    (write-item-name (car support) port)
	    (for-each (lambda (node)
			(write-char #\space port)
			(write-item-name node port))
		      (cdr support))))
      (write-char #\} port)
      (newline port))))

(define (write-line-prefix key port)
  (write-string ";    " port)
  (write-string key port)
  (write-string ": " port))

(define (event-item-purposes item)
  (eqv-big-intersection (event-item-data item)
			datum-purposes))

(define item-printers
  (make-item-association))

(define define-item-printer
  (item-association-definer item-printers))

(define get-item-printer
  (item-association-accessor item-printers))

(define-item-printer event-item?
  (lambda (item antecedents port)
    (let ((event (event-item-event item)))
      (if (sor-transfer? event)
	  (begin
	    (write-line-prefix "data source" port)
	    (write-rdf-node (data-flow:source event) port)
	    (newline port)
	    (write-line-prefix "data recipient" port)
	    (write-rdf-node (transfer:recipient event) port)
	    (newline port)))
      (write-line-prefix "authorized purposes" port)
      (let ((purposes (event-item-purposes item)))
	(if (universal-set? purposes)
	    (write-string "ANY" port)
	    (write-rdf-nodes purposes port)))
      (newline port)
      (if (pair? antecedents)
	  (begin
	    (write-line-prefix "because" port)
	    (write-string "the authorized purposes of data from" port)
	    (for-each (lambda (antecedent)
			(if (not (restriction? antecedent))
			    (begin
			      (write-char #\space port)
			      (write-item-name antecedent port))))
		      antecedents)
	    (write-string " restricted by the purposes specified in " port)
	    (write-rdf-node (data-flow:source event) port)
	    (newline port))))))

(define-item-printer arrest-item?
  (lambda (item antecedents port)
    (write-line-prefix "justified?" port)
    (write-string (if (arrest-item-justified? item)
		      "justified"
		      "not-justified")
		  port)
    (newline port)
    (write-line-prefix "because" port)
    (write-string "the authorized purposes of data from" port)
    (for-each (lambda (antecedent)
		(if (not (charges? antecedent))
		    (begin
		      (write-char #\space port)
		      (write-item-name antecedent port))))
	      antecedents)
    (write-string " do not include the charges of " port)
    (write-rdf-node (arrest:arrest-warrant (arrest-item-arrest item)) port)
    (newline port)))

(define-item-printer charges?
  (lambda (item antecedents port)
    (write-line-prefix "charges" port)
    (write-rdf-nodes (charges-charges item) port)
    (newline port)))

(define-item-printer restriction?
  (lambda (item antecedents port)
    (let ((sor (restriction-sor item)))
      (write-line-prefix "Name" port)
      (write-rdf/nt-literal (dc:title sor) port)
      (newline port)
      (write-line-prefix "SORN" port)
      (write-rdf-node (sor:notice sor) port)
      (newline port))
    (write-line-prefix "authorized purposes" port)
    (write-rdf-nodes (restriction-purposes item) port)
    (newline port)))

(define item-namers
  (make-item-association))

(define define-item-namer
  (item-association-definer item-namers))

(define get-item-namer
  (item-association-accessor item-namers))

(define (write-item-name item port)
  ((get-item-namer item) item port))

(define-item-namer event-item?
  (lambda (item port)
    (write-rdf-node (event-item-event item) port)))

(define-item-namer arrest-item?
  (lambda (item port)
    (write-rdf-node (arrest-item-arrest item) port)))

(define-item-namer charges?
  (lambda (item port)
    (write-rdf-node (arrest:arrest-warrant (charges-arrest item)) port)))

(define-item-namer restriction?
  (lambda (item port)
    (write-rdf-node (restriction-sor item) port)))

(define (write-rdf-nodes nodes port)
  (write-char #\{ port)
  (let ((nodes (set-members nodes)))
    (if (pair? nodes)
	(begin
	  (write-rdf-node (car nodes) port)
	  (for-each (lambda (node)
		      (write-char #\space port)
		      (write-rdf-node node port))
		    (cdr nodes)))))
  (write-char #\} port))

(define dc:title
  (optional-rdf-object-accessor 'dc:title))

(define transfer?
  (rdf-type-predicate '|ts:Transfer|))

(define (sor-transfer? resource)
  (and (transfer? resource)
       (sor? (data-flow:source resource))))

(define official?
  (rdf-type-predicate '|ts:Official|))

(define office?
  (rdf-type-predicate '|ts:Office|))

(define organization?
  (rdf-type-predicate '|ts:Organization|))

(define sor?
  (rdf-type-predicate '|ts:SOR|))

(define arrest?
  (rdf-type-predicate '|j:Arrest|))

(define (organization<=? a b)
  (cond ((eq? a b) #t)
	((organization? a)
	 (let ((c (organization:part-of a)))
	   (and c
		(organization<=? c b))))
	((official? a)
	 (there-exists? (person:employment)
	   (lambda (e)
	     (let ((c
		    (or (employment:office e)
			(employment:organization e))))
	       (and c
		    (organization<=? c b))))))
	(else #f)))

(define (statute<=? s1 s2)
  (let ((s1 (uri->string (rdf-node-name s1)))
	(s2 (uri->string (rdf-node-name s2))))
    (let ((i (string-match-forward s1 s2))
	  (n (string-length s1)))
      (and (> i 0)
	   (if (< i n)
	       (memq (string-ref s1 i) '(#\/ #\# #\_))
	       #t)))))

#|

(ge (make-top-level-environment))
;Value 27: #[environment 27]

(load "~cph/dig/dig/TAMI/cph/v2/load")
;Loading "dig/dig/TAMI/cph/v2/load.scm"
;Loading "graph.scm" -- done
;Loading "simple-schema.scm" -- done
;Loading "data-accessors.scm" -- done
;Loading "tms-accessors.scm" -- done
;Loading "../eqv-sets.scm" -- done
;Loading "../tms.scm" -- done
;Loading "deduce.scm" -- done
 -- done
;Value: statute<=?

(write-tami-argument (build-tami-argument 's3:arrest-1))

; s3:arrest-1
;    justified?: not-justified
;    because: the authorized purposes of data from s3:transfer-1b do not include the charges of s3:ny-warrant
;    supported by: {s3:ny-warrant tb:SFDB tb:SFDB s3:receive-pnr-1}

; s3:ny-warrant
;    charges: {law:USC-18-228}
;    supported by: {s3:ny-warrant}

; s3:transfer-1b
;    data source: tb:SFDB
;    data recipient: tb:FBI-NYC
;    authorized purposes: {tb:ct-criminal-law-enforcement tb:ct-intelligence}
;    because: the authorized purposes of data from s3:transfer-1a restricted by the purposes specified in tb:SFDB
;    supported by: {tb:SFDB tb:SFDB s3:receive-pnr-1}

; tb:SFDB
;    Name: "Secure Flight Test Records System"
;    SORN: tb:SFDB-SORN
;    authorized purposes: {tb:ct-criminal-law-enforcement tb:ct-intelligence}
;    supported by: {tb:SFDB}

; s3:transfer-1a
;    data source: tb:SFDB
;    data recipient: tb:FBI-NYC
;    authorized purposes: {tb:ct-criminal-law-enforcement tb:ct-intelligence}
;    because: the authorized purposes of data from s3:receive-pnr-1 restricted by the purposes specified in tb:SFDB
;    supported by: {tb:SFDB s3:receive-pnr-1}

; tb:SFDB
;    Name: "Secure Flight Test Records System"
;    SORN: tb:SFDB-SORN
;    authorized purposes: {tb:ct-criminal-law-enforcement tb:ct-intelligence}
;    supported by: {tb:SFDB}

; s3:receive-pnr-1
;    authorized purposes: ANY
;    supported by: {s3:receive-pnr-1}
;Unspecified return value

|#