scheme48/ps-compiler/util/transitive.scm

; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey

; General transitive closure

; (make-graph-from-predecessors nodes node-parents node-temp set-node-temp!)
;            -> graph
; (make-graph-from-successors nodes node-kids node-temp set-node-temp!)
;            -> graph
;
; (transitive-or! graph elements set-elements! element-temp set-element-temp!)
; (transitive-or-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
; (transitive-or-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
;
; (transitive-and! graph elements set-elements! element-temp set-element-temp!)
; (transitive-and-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
; (transitive-and-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)

;----------------

(define (make-graph-from-predecessors user-nodes user-node-parents node-temp set-node-temp!)
  (let ((nodes (make-nodes user-nodes set-node-temp!)))
    (connect-nodes-using-parents! nodes user-node-parents node-temp)
    (for-each (lambda (node)
		(set-node-temp! (node-data node) #f))
	      nodes)
    (make-graph nodes)))

(define (make-graph-from-successors user-nodes user-node-kids node-temp set-node-temp!)
  (let ((nodes (make-nodes user-nodes set-node-temp!)))
    (connect-nodes-using-children! nodes user-node-kids node-temp)
    (for-each (lambda (node)
		(set-node-temp! (node-data node) #f))
	      nodes)
    (make-graph nodes)))

(define (make-nodes user-nodes set-node-temp!)    
  (map (lambda (data)
	 (let ((node (node-maker data '() '())))
	   (set-node-temp! data node)
	   node))
       user-nodes))

(define-record-type graph
  (nodes         ; list of nodes
   )
  ())

(define make-graph graph-maker)
  
(define-record-type node
  (data          ; user's data
   (parents)     ; predecessors
   (kids))       ; successors
  (elt-set       ; elements
   kill-set      ; elements that are not passed
   changed?      ; change flag for iteration
   ))

;------------------------------
; Six false fronts for the real procedure.

(define (transitive-or! graph elts set-elts! elt-hash set-elt-hash!)
  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
	 (transitive-or-closure! or-update-node)))

(define (transitive-or-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
	 (transitive-or-closure! or-update-node-with-kill)))

(define (transitive-or-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
	 (transitive-or-closure! or-update-node-with-kill)))

(define (transitive-and! graph elts set-elts! elt-hash set-elt-hash!)
  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
	 (transitive-and-closure! and-update-node)))

(define (transitive-and-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
	 (transitive-and-closure! and-update-node-with-kill)))

(define (transitive-and-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
	 (transitive-and-closure! and-update-node-with-kill)))

(define (do-it graph elts set-elts! kill-elts pass? elt-hash set-elt-hash! op)
  (let* ((nodes (graph-nodes graph))
	 (elt-unhash-vec (add-elements! nodes elts kill-elts pass?
					elt-hash set-elt-hash!)))
    (op nodes)
    (record-results! nodes elt-unhash-vec set-elts!)
    (do ((i 0 (+ i 1)))
	((= i (vector-length elt-unhash-vec)))
      (set-elt-hash! (vector-ref elt-unhash-vec i) #f))
    (values)))

;----------------
; Setting the kids field of the nodes

(define (connect-nodes-using-children! nodes children node-slot)
  (for-each
   (lambda (node)
     (set-node-kids! node
		      (map (lambda (kid)
			     (let ((t (node-slot kid)))
			       (if (not (node? t))
				   (missing-node-error kid "child" node))
			       (set-node-parents! t
						   (cons node
							 (node-parents t)))
			       t))
			   (children (node-data node)))))
   nodes))

(define (connect-nodes-using-parents! nodes parents node-slot)
  (for-each
   (lambda (node)
     (set-node-parents! node
			 (map (lambda (parent)
				(let ((t (node-slot parent)))
				  (if (not (node? t))
				      (missing-node-error t "parent" node))
				  (set-node-kids! t
						   (cons node
							 (node-kids t)))
				  t))
			      (parents (node-data node)))))
   nodes))

(define (missing-node-error node relationship relation)
  (error (format #f "Transitive - ~S, ~A of ~S, not in list of nodes"
		 node relationship (node-data relation))))

;----------------

(define (add-elements! nodes node-elements node-kills pass?
		       element-temp set-element-temp!)
  (let ((unhash-vec (element-hasher nodes node-elements element-temp set-element-temp!))
	(element-hash (make-element-hash element-temp)))
    (for-each (lambda (node)
		(set-node-elt-set! node
				   (make-element-set (node-elements (node-data node))
						     element-hash)))
	      nodes)
    (if node-kills
	(for-each (lambda (node)
		    (let ((kill-set (make-element-set (node-kills (node-data node))
						      element-hash)))
		      (set-node-kill-set! node (if pass?
						   (integer-set-not kill-set)
						   kill-set))))
		  nodes))
    unhash-vec))

(define (make-element-set elts elt-hash)
  (let loop ((elts elts) (set (make-empty-integer-set)))
    (if (null? elts)
	set
	(loop (cdr elts)
	      (cond ((elt-hash (car elts))
		     => (lambda (hash)
			  (add-to-integer-set set hash)))
		    (else set))))))

;----------------
; Counting the elements and assigning numbers to them

(define-record-type element-hash
  (number  ; the element-hash record is just a way of tagging this number
   )       ; with a unique predicate
  ())

(define (element-hasher nodes elts elt-hash set-elt-hash!)
  (let loop ((to-do '()) (ts nodes) (all-elts '()) (count 0))
    (cond ((null? to-do)
	   (if (null? ts)
	       (real-element-hasher all-elts count)
	       (loop (elts (node-data (car ts))) (cdr ts) all-elts count)))
	  ((element-hash? (elt-hash (car to-do)))
	   (loop (cdr to-do) ts all-elts count))
	  (else
	   (set-elt-hash! (car to-do) (element-hash-maker count))
	   (loop (cdr to-do) ts (cons (car to-do) all-elts) (+ count 1))))))

(define (real-element-hasher elts count)
  (let ((unhash-vec (make-vector count)))
    (do ((i (- count 1) (- i 1))
	 (elts elts (cdr elts)))
	((null? elts))
      (vector-set! unhash-vec i (car elts)))
    unhash-vec))

(define (make-element-hash elt-hash)
  (lambda (elt)
    (let ((hash (elt-hash elt)))
      (if (element-hash? hash)
	  (element-hash-number hash)
	  #f))))

;----------------
; Turn the element sets into lists of elements and clean up stray pointers
; at the same time.

(define (record-results! nodes elt-unhash-vec set-elts!)
  (for-each (lambda (node)
	      (set-elts! (node-data node)
			 (map-over-integer-set
			  (lambda (i) (vector-ref elt-unhash-vec i))
			  (node-elt-set node)))
	      (set-node-elt-set! node #f)
	      (set-node-kill-set! node #f))
	    nodes))

;----------------
; The OR algorithm - keeps passing elements around until the changes stop.

(define (transitive-or-closure! op)
  (lambda (nodes)
    (for-each (lambda (node)
		(set-node-changed?! node #t))
	      nodes)
    (let loop ((to-do nodes))
      (if (not (null? to-do))
	  (let* ((node (car to-do))
		 (elt-set (node-elt-set node)))
	    (set-node-changed?! node #f)
	    (let kids-loop ((ts (node-kids node))
			    (to-do (cdr to-do)))
	      (cond ((null? ts)
		     (loop to-do))
		    ((and (op (car ts) elt-set)
			  (not (node-changed? (car ts))))
		     (set-node-changed?! (car ts) #t)
		     (kids-loop (cdr ts) (cons (car ts) to-do)))
		    (else
		     (kids-loop (cdr ts) to-do)))))))))

; The weird function INTEGER-SET-SUBTRACT&IOR-WITH-TEST! takes three integer
; sets, subtracts the second from the first and inclusive OR's the result
; with the third.  It returns the resulting set and a flag which is #T if
; the result is not the same as the original third set.  The inclusive OR
; may be destructive.

(define (or-update-node-with-kill node elt-set)
  (receive (set change?)
      (integer-set-subtract&ior-with-test! elt-set
					   (node-kill-set node)
					   (node-elt-set node))
    (set-node-elt-set! node set)
    change?))

(define (or-update-node node elt-set)
  (receive (set change?)
      (integer-set-ior-with-test! elt-set
				  (node-elt-set node))
    (set-node-elt-set! node set)
    change?))

; Implementations using simpler, nondestructive operations (these might be
; done more efficiently if they had access to the underlying representation
; of integer sets).

(define (integer-set-subtract&ior-with-test! set1 set2 set3)
  (let ((result (integer-set-ior set3 (integer-set-subtract set1 set2))))
    (values result (not (integer-set-equal? set3 result)))))

(define (integer-set-ior-with-test! set1 set3)
  (let ((result (integer-set-ior set3 set1)))
    (values result (not (integer-set-equal? set3 result)))))

;----------------
; The AND algorithm - keeps a to-do list of nodes whose parents' elements
; have changed, instead of a list of nodes whose elements have changed.

(define (transitive-and-closure! op)
  (lambda (nodes)
    (let loop ((to-do (filter (lambda (node)
				(if (not (null? (node-parents node)))
				    (begin
				      (set-node-changed?! node #t)
				      #t)
				    #f))
			      nodes)))
      (if (not (null? to-do))
	  (let ((node (car to-do)))
	    (set-node-changed?! node #f)
	    (if (op node)
		(let kids-loop ((ts (node-kids node))
				(to-do (cdr to-do)))
		  (cond ((null? ts)
			 (loop to-do))
			((node-changed? (car ts))
			 (kids-loop (cdr ts) to-do))
			(else
			 (set-node-changed?! (car ts) #t)
			 (kids-loop (cdr ts) (cons (car ts) to-do)))))
		(loop (cdr to-do))))))))
  
; These are the same as for OR except that we AND together the parents'
; elt-sets instead of using the one provided.

(define (and-update-node-with-kill node)
  (receive (set change?)
      (integer-set-subtract&ior-with-test! (parents-elt-set node)
					   (node-kill-set node)
					   (node-elt-set node))
    (set-node-elt-set! node set)
    change?))
  
(define (and-update-node node)
  (receive (set change?)
      (integer-set-ior-with-test! (parents-elt-set node)
				  (node-elt-set node))
    (set-node-elt-set! node set)
    change?))

(define (parents-elt-set node)
  (do ((parents (cdr (node-parents node))
		(cdr parents))
       (elts (node-elt-set (car (node-parents node)))
	     (integer-set-and elts (node-elt-set (car parents)))))
      ((null? parents)
       elts)))

;------------------------------------------------------------
; Testing

; GRAPH is ((<symbol>           name
;            (element*)         elements
;            (element*)         kills
;            . <symbol*>)*)     children
;
'((node1 (elt1 elt2) ()     node2)
  (node2 (elt3)      (elt2) node1 node3)
  (node3 ()          ()     ))

'((a (1) () b)
  (b ()  () ))

'((a (1 2 3 4) (1) b)
  (b ()        (2) c)
  (c ()        (3) d)
  (d (5)       (4) a))
             
(define (test-transitive graph down? or? pass?)
  (let* ((elts '())
	 (get-elt (lambda (sym)
		    (cond ((first (lambda (v)
				    (eq? sym (vector-ref v 0)))
				  elts)
			   => identity)
			  (else
			   (let ((new (vector sym #f)))
			     (set! elts (cons new elts))
			     new)))))
	 (vertices (map (lambda (n)
			  (vector (car n)
				  (map get-elt (cadr n))
				  (map get-elt (caddr n))
				  #f #f))
			graph)))
    (for-each (lambda (data vertex)
		(vector-set! vertex 3 (map (lambda (s)
					     (first (lambda (v)
						      (eq? s (vector-ref v 0)))
						    vertices))
					   (cdddr data))))
	      graph
	      vertices)
    (let ((the-graph ((if down?
			  make-graph-from-successors
			  make-graph-from-predecessors)
		      vertices
		      (lambda (x) (vector-ref x 3))
		      (lambda (x) (vector-ref x 4))
		      (lambda (x v) (vector-set! x 4 v)))))
      (if (every? (lambda (n) (null? (caddr n))) graph)
	  ((if or? transitive-or! transitive-and!)
	   the-graph
	   (lambda (v) (vector-ref v 1))        ; elts
	   (lambda (v x) (vector-set! v 1 x))   ; set-elts!
	   (lambda (e) (vector-ref e 1))        ; elt-hash
	   (lambda (e x) (vector-set! e 1 x)))  ; set-elt-hash!
          ((if or?					    
	       (if pass?
		   transitive-or-with-pass!
		   transitive-or-with-kill!)
	       (if pass?
		   transitive-and-with-pass!
		   transitive-and-with-kill!))
	   the-graph
	   (lambda (v) (vector-ref v 1))         ; elts
	   (lambda (v x) (vector-set! v 1 x))    ; set-elts!
	   (lambda (v) (vector-ref v 2))         ; kills
	   (lambda (e) (vector-ref e 1))         ; elt-hash
	   (lambda (e x) (vector-set! e 1 x))))) ; set-elt-hash!
    (map (lambda (v)
	   (list (vector-ref v 0)
		 (map (lambda (e) (vector-ref e 0))
		      (vector-ref v 1))))
	 vertices)))