;;;; tsort.lisp ;;;; Copyright (c) 2012 Robert Smith ;;; A directed acyclic graph should be specified as follows: ;;; ;;; (( ...) ;;; ... ;;; ) (defun list-sinks (dag) "Find the sinks in DAG." (loop :for (node . deps) :in dag :when (null deps) :collect node)) (defun tsort (dag) "Find the topological sort of GRAPH destructively. An error is signalled if it is not a directed acyclic graph." (let* ((sorted nil) ; Final sorted list. (sinks (list-sinks dag))) ; Sinks in the graph. (loop :while (not (null sinks)) :do (progn ;; Remove the sinks. (setf dag (delete-if (lambda (x) (null (cdr x))) dag)) ;; Get the next sink. (let ((sink (pop sinks))) ;; Add it to the sorted list. (push sink sorted) ;; For every node/neighborhood... (dolist (node dag) ;; Remove the sink from the dependencies if any ;; exist. (setf (cdr node) (delete sink (cdr node))) ;; If we have no more dependencies, add it to the ;; sinks. (when (null (cdr node)) (push (car node) sinks))))) :finally (return (if (null dag) ;; Our DAG is empty. We're good! (nreverse sorted) ;; Our DAG isn't empty but has no ;; sinks. It must be cyclic! (error "Cannot sort a cyclic graph. ~ The cycles are ~S." dag)))))) (defun tsort-copy (graph) "Topologically sort GRAPH. An error is signalled if it is not a directed acyclic graph." (tsort (copy-tree graph))) ;;; Much of the functions in LABELS are taken from QTILITY. (defun random-dag (size) "Generate a random directed acyclic graph with SIZE number of nodes." (labels ((random-between (a b) "Generate a random integer between A and B, inclusive." (assert (>= b a)) (if (= a b) a (+ a (random (- (1+ b) a))))) (nshuffle (seq) "Destructively shuffle SEQ." (let ((n (length seq))) (loop :for i :below n :for r := (random-between i (1- n)) :when (/= i r) :do (rotatef (elt seq i) (elt seq r)) :finally (return seq)))) (random-bool () "Generate a random boolean." (zerop (random 2))) (random-deps (n) "Generate a random list of dependencies up to SIZE." (loop :for i :below n :when (random-bool) :collect i :into deps :finally (return deps)))) (loop :for n :below size :collect (cons n (nshuffle (random-deps n))) :into nodes :finally (return (nshuffle nodes))))) (defun test-timing (size) (let ((dag (random-dag size))) (time (tsort dag)) (values)))