test/tests.lisp @ 884333cfb6fb v1.3.2

Detect *all* cycles during topological sort

Previously the cycle detection was limited to detecting when we hit
a currently-being-visited node during a traversal.  So something like this would
be correctly found:

    A --> B --> C
          ^     |
          |     |
          +-----+

We start at the root (A), go to B, then to C, then to B, and detect that we're
still working on B and signal the error.

But this doesn't find all cycles, because we *start* at the root nodes, and if
a cycle doesn't have any outcropping branches we'll never reach it at all.  For
example:

    A --> B
    ^     |
    |     |
    +-----+

This graph has no roots, so we incorrectly ignore the cycle.

This patch fixes the problem by keeping a count of visited nodes and and making
sure it matches the digraph's size at the end.

Fixes https://github.com/sjl/cl-digraph/issues/4
author Steve Losh <steve@stevelosh.com>
date Mon, 14 Dec 2020 20:13:51 -0500
parents 0434eb58dde3
children 7e80eda84170
(in-package :digraph.test)


;;;; Utils --------------------------------------------------------------------
(defmacro define-test (name &body body)
  `(test ,(symb 'test- name)
    (let ((*package* ,*package*))
      ,@body)))


(defun same (a b)
  (null (set-exclusive-or a b :test #'equal)))

(defun run-tests ()
  (1am:run))


;;;; Tests --------------------------------------------------------------------
(define-test make-digraph
  (let ((g (make-digraph)))
    (is (zerop (count-vertices g)))
    (is (same () (vertices g)))
    (is (same () (edges g)))
    (is (emptyp g)))
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (is (= 3 (count-vertices g)))
    (is (same '(a b c) (vertices g)))
    (is (same () (edges g)))
    (is (not (emptyp g))))
  (let ((g (make-digraph :initial-vertices '(a b a c a a))))
    (is (= 3 (count-vertices g)))
    (is (same '(a b c) (vertices g)))
    (is (same () (edges g)))
    (is (not (emptyp g)))))

(define-test copy-digraph
  (let ((g (make-digraph :initial-vertices '(a b c)))
        (h nil))
    (insert-edge g 'a 'b)
    (is (same '(a b c) (vertices g)))
    (is (same '((a . b)) (edges g)))
    (setf h (copy-digraph g))
    (is (same '(a b c) (vertices h)))
    (is (same '((a . b)) (edges h)))
    (remove-edge h 'a 'b)
    (remove-vertex h 'c)
    (is (same '(a b) (vertices h)))
    (is (same '() (edges h)))
    ;; make sure the original didn't change
    (is (same '(a b c) (vertices g)))
    (is (same '((a . b)) (edges g)))))


(define-test roots-and-leafs
  (let ((g (make-digraph)))
    (is (same () (roots g)))
    (is (same () (leafs g)))
    (insert-vertex g 'a)
    (insert-vertex g 'b)
    (is (same '(a b) (roots g)))
    (is (same '(a b) (leafs g)))
    (insert-edge g 'a 'b)
    (is (same '(a) (roots g)))
    (is (same '(b) (leafs g)))
    (insert-edge g 'b 'a)
    (is (same () (roots g)))
    (is (same () (leafs g)))))


(define-test insert-vertex
  (let ((g (make-digraph)))
    (is (= 0 (count-vertices g)))
    (is (same '() (vertices g)))

    (insert-vertex g 'a)
    (is (= 1 (count-vertices g)))
    (is (same '(a) (vertices g)))

    (insert-vertex g 'b)
    (is (= 2 (count-vertices g)))
    (is (same '(a b) (vertices g)))

    (insert-vertex g 'a) ; dup
    (is (= 2 (count-vertices g)))
    (is (same '(a b) (vertices g)))))

(define-test insert-edge
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (insert-edge g 'a 'b)
    (is (same '((a . b))
              (edges g)))

    (insert-edge g 'b 'c)
    (is (same '((a . b) (b . c))
              (edges g)))))


(define-test remove-vertex
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (insert-edge g 'a 'b)
    (insert-edge g 'b 'c)
    (is (same '(a b c) (vertices g)))
    (is (same '((a . b) (b . c)) (edges g)))

    (remove-vertex g 'c)
    (is (same '(a b) (vertices g)))
    (is (same '((a . b)) (edges g)))

    (remove-vertex g 'c)
    (is (same '(a b) (vertices g)))
    (is (same '((a . b)) (edges g)))

    (remove-vertex g 'b)
    (is (same '(a) (vertices g)))
    (is (same '() (edges g)))))

(define-test remove-edge
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (insert-edge g 'a 'b)
    (insert-edge g 'b 'c)
    (is (same '((a . b) (b . c)) (edges g)))

    (remove-edge g 'a 'b)
    (is (same '((b . c)) (edges g)))

    (remove-edge g 'a 'b)
    (is (same '((b . c)) (edges g)))

    (remove-edge g 'b 'c)
    (is (same '() (edges g)))))


(defun make-simple-digraph ()
  ;; a ---->  middle  ----> z <-+     orphan
  ;; ^          ^           |   |
  ;; |          |           +---+
  ;; b ---------+
  (let ((g (make-digraph :initial-vertices '(a b middle z orphan))))
    (insert-edge g 'a 'middle)
    (insert-edge g 'b 'middle)
    (insert-edge g 'b 'a)
    (insert-edge g 'middle 'z)
    (insert-edge g 'z 'z)
    g))


(define-test neighbors
  (let ((g (make-simple-digraph)))
    (is (same '(b middle) (neighbors g 'a)))
    (is (same '(a middle) (neighbors g 'b)))
    (is (same '(a b z) (neighbors g 'middle)))
    (is (same '(middle z) (neighbors g 'z)))
    (is (same '() (neighbors g 'orphan)))))

(define-test predecessors
  (let ((g (make-simple-digraph)))
    (is (same '(b) (predecessors g 'a)))
    (is (same '() (predecessors g 'b)))
    (is (same '(a b) (predecessors g 'middle)))
    (is (same '(middle z) (predecessors g 'z)))
    (is (same '() (predecessors g 'orphan)))))

(define-test successors
  (let ((g (make-simple-digraph)))
    (is (same '(middle) (successors g 'a)))
    (is (same '(a middle) (successors g 'b)))
    (is (same '(z) (successors g 'middle)))
    (is (same '(z) (successors g 'z)))
    (is (same '() (successors g 'orphan)))))


(define-test contains-vertex-p ()
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (is (contains-vertex-p g 'a))
    (is (contains-vertex-p g 'b))
    (is (contains-vertex-p g 'c))

    (is (null (contains-vertex-p g 'd)))
    (insert-vertex g 'd)
    (is (contains-vertex-p g 'd))
    (remove-vertex g 'd)
    (is (null (contains-vertex-p g 'd)))))

(define-test contains-edge-p ()
  (let ((g (make-digraph :initial-vertices '(a b c))))
    (is (null (contains-edge-p g 'a 'b)))
    (is (null (contains-edge-p g 'c 'c)))

    (insert-edge g 'a 'b)
    (is (contains-edge-p g 'a 'b))
    (is (null (contains-edge-p g 'c 'c)))

    (insert-edge g 'c 'c)
    (is (contains-edge-p g 'a 'b))
    (is (contains-edge-p g 'c 'c))

    (remove-edge g 'a 'b)
    (is (null (contains-edge-p g 'a 'b)))
    (is (contains-edge-p g 'c 'c))

    (remove-edge g 'c 'c)
    (is (null (contains-edge-p g 'a 'b)))
    (is (null (contains-edge-p g 'c 'c)))))


(define-test degree
  (let ((g (make-simple-digraph)))
    (is (= 2 (degree g 'a)))
    (is (= 2 (degree g 'b)))
    (is (= 3 (degree g 'middle)))
    (is (= 2 (degree g 'z)))
    (is (= 0 (degree g 'orphan)))))

(define-test degree-in
  (let ((g (make-simple-digraph)))
    (is (= 1 (degree-in g 'a)))
    (is (= 0 (degree-in g 'b)))
    (is (= 2 (degree-in g 'middle)))
    (is (= 2 (degree-in g 'z)))
    (is (= 0 (degree g 'orphan)))))

(define-test degree-out
  (let ((g (make-simple-digraph)))
    (is (= 1 (degree-out g 'a)))
    (is (= 2 (degree-out g 'b)))
    (is (= 1 (degree-out g 'middle)))
    (is (= 1 (degree-out g 'z)))
    (is (= 0 (degree g 'orphan)))))


(define-test reachablep
  (let ((g (make-simple-digraph)))
    (is (reachablep g 'orphan 'orphan))
    (is (reachablep g 'b 'a))
    (is (reachablep g 'b 'z))
    (is (not (reachablep g 'a 'b)))
    (is (not (reachablep g 'z 'orphan)))))


(define-test abitrary-vertex
  (let ((g (make-simple-digraph)))
    (is (member (arbitrary-vertex g) '(a b middle z orphan)))
    (remove-vertex g 'b)
    (is (member (arbitrary-vertex g) '(a middle z orphan)))
    (remove-vertex g 'middle)
    (is (member (arbitrary-vertex g) '(a z orphan)))
    (remove-vertex g 'z)
    (is (member (arbitrary-vertex g) '(a orphan)))
    (remove-vertex g 'a)
    (is (member (arbitrary-vertex g) '(orphan)))
    (remove-vertex g 'orphan)
    (is (null (arbitrary-vertex g)))
    (insert-vertex g 'new)
    (is (member (arbitrary-vertex g) '(new)))))


(define-test topological-sort-cycle-detection
  (let ((g (make-digraph :initial-vertices '(a b c d))))
    (is (= 4 (length (topological-sort g))))
    (insert-edge g 'a 'b)
    (is (= 4 (length (topological-sort g))))
    (insert-edge g 'b 'c)
    (is (= 4 (length (topological-sort g))))
    (insert-edge g 'c 'a)
    (signals error (topological-sort g))
    (remove-edge g 'c 'a)
    (insert-edge g 'd 'd)
    (signals error (topological-sort g))
    (remove-edge g 'd 'd)
    (insert-edge g 'c 'd)
    (is (= 4 (length (topological-sort g))))
    (insert-edge g 'd 'b)
    (signals error (topological-sort g))))