Depth-first topological sort in Common Lisp

topo-sort-dfs.lisp

;; some graphs for testing
(setq g1 '((b a d)
           (d e)
           (e a)
           (f d)
           (g d a e c)))

(setq g2 '((c a)
           (d a)
           (b d z)))

(setq g3 '((a b e g)
           (b)
           (e d g)
           (d f g)
           (c g)))

(defun collector ()
  "Maintains the head of a list and returns a function that appends an
item to the list. When the returned function is called with no
arguments, returns the head."
  (let ((tail nil)
        (head nil))
    (lambda (&optional (item nil item?))
      (cond
        ((not item?) head)
        ((null tail) (setq tail (cons item nil)
                           head tail))
        (t (let ((new-tail (cons item nil)))
             (rplacd tail new-tail)
             (setq tail new-tail)))))))

(defun topo-sort-dfs (g &aux (walked ()) (append (collector)))
  "Proposes a topological ordering of the vertices in directed graph g
using a depth-first algorithm. g should be a list of lists of
symbols. The head of each list is a vertex, and the tail is the list
of other vertices with edges to the head (its
'dependencies'). Currently, cycles go undetected and result in an
ordering that's missing vertices."
  (labels ((dfs* (v)
             (push v walked)
             (let ((from (rest (assoc v g))))
               (loop for f in from
                     when (not (member f walked))
                     do (dfs* f)))
             (funcall append v)))
    (loop for node in g
          do (loop for v in node
                   when (not (member v walked))
                   do (dfs* v))))
    (funcall append))