(in-package #:cleavir-graph)

(defun depth-first-preorder-thunk (start-node map-successors-fun)
  (declare (type node-mapper map-successors-fun))
  (lambda (function)
    (declare (type (function (t)) function))
    (let ((table (make-hash-table :test #'eq)))
      (labels ((traverse (node)
                 (unless (gethash node table)
                   (setf (gethash node table) t)
                   (funcall function node)
                   (funcall map-successors-fun #'traverse node))))
        (traverse start-node)))
    (values)))

(defun depth-first-reverse-postorder-thunk (start-node map-successors-fun)
  (declare (type node-mapper map-successors-fun))
  (lambda (function)
    (declare (type (function (t)) function))
    (let ((table (make-hash-table :test #'eq)))
      (labels ((traverse (node)
                 (unless (gethash node table)
                   (setf (gethash node table) t)
                   (funcall map-successors-fun #'traverse node)
                   (funcall function node))))
        (traverse start-node)))
    (values)))

;;; Construct a predecessors mapping from a graph that doesn't have it built in
;;; by exhaustively iterating through with the successor function, filling a
;;; table of predecessor relationships, to use for future reference.
(defun map-predecessors-thunk (start-node map-successors-fun)
  (declare (type node-mapper map-successors-fun))
  (let ((pred-table (make-hash-table :test #'eq))
        (traversal-table (make-hash-table :test #'eq)))
    (labels ((predecessors (node) (gethash node pred-table))
             ((setf predecessors) (preds node)
               (setf (gethash node pred-table) preds))
             (traverse (node)
               (unless (gethash node traversal-table)
                 (setf (gethash node traversal-table) t)
                 (funcall map-successors-fun
                          (lambda (succ) (push node (predecessors succ)))
                          node)
                 (funcall map-successors-fun #'traverse node))))
      (traverse start-node))
    (lambda (function node)
      (mapc function (gethash node pred-table))
      (values))))

(defun size-thunk (start-node map-successors-fun)
  (declare (type node-mapper map-successors-fun))
  (lambda ()
    (let ((table (make-hash-table :test #'eq))
          (size 0))
      (labels ((traverse (node)
                 (unless (gethash node table)
                   (setf (gethash node table) t)
                   (incf size)
                   (funcall map-successors-fun #'traverse node))))
        (traverse start-node))
      size)))
