a dfs macro

dfs.lisp

(defmacro dfs (graph start visitor) ;; graph is an adjacency vector
  "(initialize-vertex visitor vertex) is invoked on every vertex of the graph before the start of the graph search.
(start-vertex visitor vertex) is invoked on the source vertex once before the start of the search.
(discover-vertex visitor vertex)  is invoked when a vertex is encountered for the first time.
(examine-edge visitor edge) is invoked on every out-edge of each vertex after it is discovered.
(tree-edge visitor edge) is invoked on each edge as it becomes a member of the edges that form the search tree. If you wish to record predecessors, do so at this event point.
(back-edge visitor edge is invoked on the back edges in the graph.
(cross-edge visitor edge) is invoked on cross edges in the graph. In an undirected graph this method is never called.
I have no idea about what to do with forward edges.
(finish-edge visitor edge) is invoked on the non-tree edges in the graph as well as on each tree edge after its target vertex is finished.
(finish-vertex visitor vertex) is invoked on a vertex after all of its out edges have been added to the search tree
and all of the adjacent vertices have been discovered (but before their out-edges have been examined)"
  `(macrolet ((vector-back (vector)
                `(aref ,vector (1- (length vector)))))
     (let ((colormap (make-array (length graph) :element-type 'keyword :initial-element :white)))
       (loop :initially :do () ;;I start at the ,start, then do for everything else
             :for vertex :across ,graph
             :when (eq :white vertex)
               :do (initialize-vertex ,visitor vertex)
                   (loop :initially (setf (aref colormap vertex) :grey)
                                    (start-vertex ,visitor vertex)
                         :with stack := (make-array 1 :element-type '(cons t fixnum) :initial-element (cons start 0) :adjustable t :fill-pointer 1)
                         :until (zerop (length stack))
                         :for ((weight . to) . next) := (vector-back dfs-stack)
                         :for children := (aref graph to)
                         :do (loop :for (next-weight . next-to) :across children
                                   :do (incf (cdr (vector-back dfs-stack)))
                                       (examine-edge ,visitor next-weight to next-to) ;;not sure how to call it on edge here
                                   :when (eq :white (aref colormap next-to))
                                     :do (discover-vertex ,visitor next-edge)
                                         (tree-edge ,visitor next-weight to next-to) ;; same edge becomes member of a tree
                                         (setf (aref colormap next-edge) :grey)
                                         (vector-push-extend (cons (cons next-weight next-to) 0) dfs-stack)
                                         (return)
                                   :when (eq :grey (aref colormap next-to))
                                     :do (back-edge ,visitor next-weight to next-to)
                                   :when (eq :black (aref colormap next-to))
                                     :do (cross-edge ,visitor next-weight to next-to))
                         :when (= next (length ver))
                           :do (let ((leaving (car (vector-pop dfs-stack))))
                                 (setf (aref colormap (cdr leaving)) :black)
                                 (finish-edge ,visitor weight (cdar (vector-back dfs-stack)) (cdr leaving))
                                 (finish-vertex ,visitor (cdr leaving))))))))