(define (set-up-justifications event)
  (let ((chain (map associated-tms-node (reversed-antecedent-chain event))))
    (tms:assume-node (car chain))
    (set-node-datum! (car chain) (all-purposes))
    (let loop ((nodes (cdr chain)) (antecedent (car chain)))
      (if (pair? nodes)
	  (let ((consequent (car nodes))
		(nodes (cdr nodes)))
	    (cond ((transfer? (node-resource consequent))
		   (justify-transfer consequent antecedent))
		  ((arrest? (node-resource consequent))
		   (justify-arrest consequent antecedent))
		  (else
		   (set-node-datum! consequent (node-datum antecedent))
		   (tms:justify-node consequent 'EVENT (list antecedent))))
	    (loop nodes consequent))
	  antecedent))))

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

(define (justify-transfer consequent antecedent)
  (set-node-datum!
   consequent
   (let ((transfer (node-resource consequent)))
     (purpose-intersection
      (node-datum antecedent)
      (transfer-purposes transfer)
      (let ((source (transfer-source transfer))
	    (recipient (transfer-recipient transfer)))
	(if (sor? source)
	    (purpose-union*
	     (map sorn-purposes
		  (keep-matching-items (sorn-uses (sor-notice source))
		    (lambda (use)
		      (there-exists? (sorn-recipients use)
			(lambda (recipient*)
			  (organization<=? recipient recipient*)))))))
	    (all-purposes))))))
  (tms:justify-node consequent 'TRANSFER (list antecedent)))

(define (justify-arrest consequent antecedent)
  (set-node-datum!
   consequent
   (if (let ((purposes (node-datum antecedent)))
	 (if (all-purposes? purposes)
	     #t
	     (let ((charge (arrest-charge (node-resource consequent))))
	       (there-exists? purposes
		 (lambda (purpose)
		   (there-exists? (purpose-statutes purpose)
		     (lambda (statute)
		       (statute<=? charge statute))))))))
       'justified
       'unjustified))
  (tms:justify-node consequent 'ARREST (list antecedent)))

(define (purpose-intersection . psets)
  (purpose-intersection* psets))

(define (purpose-intersection* psets)
  (let ((psets (delete-matching-items psets all-purposes?)))
    (if (pair? psets)
	(eqv-intersection* psets)
	(all-purposes))))

(define (purpose-union* psets)
  (if (there-exists? psets all-purposes?)
      (all-purposes)
      (eqv-union* psets)))

(define (member-of-purposes? purpose pset)
  (if (all-purposes? pset)
      #t
      (memv purpose pset)))

(define (all-purposes? pset)
  (eq? pset 'all-purposes))

(define (all-purposes)
  'all-purposes)

(define tami-tms
  (tms:make 'tami-tms
	    (lambda (node justification)
	      node justification
	      unspecific)))

(define (associated-tms-node object)
  (hash-table/intern! associated-tms-nodes object
    (lambda ()
      (tms:make-node tami-tms (cons object 'UNKNOWN)))))

(define (node-resource node)
  (car (tms:node-datum node)))

(define (node-datum node)
  (cdr (tms:node-datum node)))

(define (set-node-datum! node datum)
  (set-cdr! (tms:node-datum node) datum))

(define associated-tms-nodes
  (make-eq-hash-table))

(define (write-tami-proof node #!optional port)
  (tms:walk-node-support node
    (lambda (node just antecedents support)
      (fresh-line port)
      (newline port)
      (write-string "; " port)
      (write (node-name node) port)
      (newline port)
      (write-string ";    has value:      " port)
      (write (node-datum node) port)
      (newline port)
      (write-string ";    because:        " port)
      (write (or (tms:justification-rule just) just) port)
      (for-each (lambda (node)
		  (write-char #\space port)
		  (write (node-name node) port))
		antecedents)
      (newline port)
      (write-string ";    supported by:  " port)
      (for-each (lambda (node)
		  (write-char #\space port)
		  (write (node-name node) port))
		support)
      (newline port))))

(define (node-name node)
  (let ((name (ns-uri->qname (node-resource node))))
    (if (uri? name)
	(uri->symbol name)
	name)))

#|

(define foo
  (set-up-justifications "http://dig.csail.mit.edu/TAMI/scenario3#arrest-1"))
;Value: foo

(write-tami-proof foo)

; s3:arrest-1
;    has value:      unjustified
;    because:        arrest s3:open-source-search-2-result-1
;    supported by:   s3:receive-pnr-1

; s3:open-source-search-2-result-1
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        transfer s3:open-source-search-2
;    supported by:   s3:receive-pnr-1

; s3:open-source-search-2
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        event s3:assignment-2
;    supported by:   s3:receive-pnr-1

; s3:assignment-2
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        event s3:open-investigation-1
;    supported by:   s3:receive-pnr-1

; s3:open-investigation-1
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        event s3:transfer-1b
;    supported by:   s3:receive-pnr-1

; s3:transfer-1b
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        transfer s3:transfer-1a
;    supported by:   s3:receive-pnr-1

; s3:transfer-1a
;    has value:      (#[uri 49 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-criminal-law-enforcement"] #[uri 50 "http://dig.csail.mit.edu/TAMI/tami-entities#ct-intelligence"])
;    because:        transfer s3:flight-test-search-1-result-1
;    supported by:   s3:receive-pnr-1

; s3:flight-test-search-1-result-1
;    has value:      all-purposes
;    because:        transfer s3:flight-test-search-1
;    supported by:   s3:receive-pnr-1

; s3:flight-test-search-1
;    has value:      all-purposes
;    because:        event s3:receive-pnr-1
;    supported by:   s3:receive-pnr-1

; s3:receive-pnr-1
;    has value:      all-purposes
;    because:        premise
;    supported by:   s3:receive-pnr-1
;Unspecified return value

|#