; implements various low-level transformations on the IR

(in-package "VERRAZANO-COMMON")

; macro to ensure a node is visited only once
(defmacro once-only (node &rest body)
  `(when (and ,node (not (node-mark ,node)))
     (mark-node ,node)
     ,@body))

; unmark a graph
(defun unmark-graph (node)
  (let ((seen (make-hash-table)))
    (labels ((helper (n)
    	       (when (not (gethash n seen))
		 (unmark-node n)
		 (setf (gethash n seen) t)
		 (apply-to-adjacent #'helper n))))
      (helper node))))

; apply given function to each adjacent node
(defun apply-to-adjacent (fun node &optional etp)
  (mapc #'(lambda (e)
	    (when (or (not etp) (member (type-of e) etp))
	      (funcall fun (edge-target e))))
	(node-edges node)))

; apply a given function to each outgoing edge
(defun apply-to-outgoing (fun node &optional etp)
  (mapc #'(lambda (e)
	    (when (or (not etp) (member (type-of e) etp))
	      (funcall fun e)))
	(node-edges node)))

; traverse the IR (nodes only)
(defun apply-to-nodes (fun node &optional etp)
  (apply-to-nodes-prepost nil fun node etp))

; traverse the IR with pre and post order
(defun apply-to-nodes-prepost (pre post node &optional etp)
  (labels ((helper (n)
             (once-only n
	       (when pre (funcall pre n))
	       (apply-to-adjacent #'helper n etp)
	       (when post (funcall post n)))))
    (helper node)
    (unmark-graph node)))

; traverse the IR (edges only)
(defun apply-to-edges (fun node &optional etp)
  (labels ((helper (n)
	     (once-only n
	       (apply-to-adjacent #'helper n etp)
	       (mapc fun (node-edges n)))))
    (helper node)
    (unmark-graph node)))

; apply to elements (edges and nodes)
(defun apply-to-elements (fun node &optional etp)
  (apply-to-edges fun node etp)
  (apply-to-nodes fun node etp))

; apply to every parent/child pair in subgraph on definition edges
(defun apply-to-pairs (fun node &optional etp)
  (labels ((helper (p c)
             (dolist (e (node-edges c))
	       (when (or (not etp) (member (type-of e) etp))
		 (helper c (edge-target e))))
	     (when p
	       (funcall fun p c))))
    (helper nil node)
    (unmark-graph node)))

; list all the edges in ir pointing to this node
(defun find-incoming-edges (node ir)
  (let ((edges nil))
    (apply-to-edges #'(lambda (e)
			(when (eq (edge-target e) node)
			  (push e edges))) ir)
    edges))

; return the first adjacent node to this node
(defun first-adjacent-node (node)
  (edge-target (car (node-edges node))))

; return all nodes adjacent to this node
(defun all-adjacent-nodes (node &optional etp)
  (mapcar #'edge-target
	  (remove-if-not #'(lambda (e)
			     (or (not etp) (member (type-of e) etp)))
			 (node-edges node))))