; implements various low-level transformations on the IR

(in-package "VERRAZANO")

; 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))))

; move all edges matching predicate up one level
(defun lift-edges (parent node edges)
  (dolist (edge edges) (combine-name node edge (edge-target edge)))
  (setf (node-edges parent) (append edges (node-edges parent)))
  (setf (node-edges node)
	(remove-if #'(lambda (e) (member e edges)) (node-edges node))))

; homogenize the types in a list
(defun homogenize-node-types (lst ir to-type)
  (dolist (node lst)
    (when (not (eq (type-of node) to-type))
      (change-node-type node ir to-type))))

; change the type of an node
(defun change-node-type (node ir new-type)
  (let ((irn (make-instance new-type)))
    (copy-class-or-struct node irn)
    (dolist (edge (find-incoming-edges node ir))
      (setf (edge-target edge) irn))))

; copy the members of a class or struct to another object
(defun copy-class-or-struct (from to)
  (setf (annotable-notes to) (annotable-notes from))
  (setf (node-edges to) (node-edges from))
  (setf (node-mark to) (node-mark from))
  (setf (node-order to) (node-order from))
  (setf (named-name to) (named-name from)))