ENH make all tests work without floating nodes

This commit is contained in:
Nathan Dwarshuis 2022-03-06 22:41:12 -05:00
parent 2fa40b763f
commit 346e41776b
1 changed files with 30 additions and 51 deletions

View File

@ -57,9 +57,9 @@
(dag-test-sets-equal-p (-map #'car broken-edges-alist) (dag-test-sets-equal-p (-map #'car broken-edges-alist)
(dag-test-ht-keys b)))) (dag-test-ht-keys b))))
(defun dag-test-has-valid-floating-nodes-p (dag floating-nodes) ;; (defun dag-test-has-valid-floating-nodes-p (dag floating-nodes)
(-let (((&plist :floating-nodes f) dag)) ;; (-let (((&plist :floating-nodes f) dag))
(dag-test-sets-equal-p floating-nodes (dag-test-ht-keys f)))) ;; (dag-test-sets-equal-p floating-nodes (dag-test-ht-keys f))))
(defun dag-test-has-valid-order-p (dag order) (defun dag-test-has-valid-order-p (dag order)
(-let (((&plist :order o) dag)) (-let (((&plist :order o) dag))
@ -67,81 +67,74 @@
;; test macros ;; test macros
(defmacro dag-test-dag-is-valid-p (dag adjlist broken-edges floating-nodes order) (defmacro dag-test-dag-is-valid-p (dag adjlist broken-edges order)
(declare (indent 1)) (declare (indent 1))
`(progn `(progn
(dag-test-has-valid-adjlist-p ,dag ',adjlist) (dag-test-has-valid-adjlist-p ,dag ',adjlist)
(dag-test-has-valid-broken-edges-p ,dag ',broken-edges) (dag-test-has-valid-broken-edges-p ,dag ',broken-edges)
(dag-test-has-valid-floating-nodes-p ,dag ',floating-nodes)
(dag-test-has-valid-order-p ,dag ',order))) (dag-test-has-valid-order-p ,dag ',order)))
(defmacro dag-test-alist-is-valid-p (alist adjlist broken-edges floating-nodes order) (defmacro dag-test-alist-is-valid-p (alist adjlist broken-edges order)
(declare (indent 1)) (declare (indent 1))
`(let ((dag (dag-alist-to-dag ',alist))) `(let ((dag (dag-alist-to-dag ',alist)))
(dag-test-dag-is-valid-p dag (dag-test-dag-is-valid-p dag
,adjlist ,broken-edges ,floating-nodes ,order))) ,adjlist ,broken-edges ,order)))
(defmacro dag-test-alist-remove-is-valid-p (alist to-remove adjlist broken-edges (defmacro dag-test-alist-remove-is-valid-p (alist to-remove adjlist broken-edges
floating-nodes order) order)
(declare (indent 2)) (declare (indent 2))
`(let ((dag (->> (dag-alist-to-dag ',alist) `(let ((dag (->> (dag-alist-to-dag ',alist)
(dag-remove-nodes ',to-remove)))) (dag-remove-nodes ',to-remove))))
(dag-test-dag-is-valid-p dag (dag-test-dag-is-valid-p dag
,adjlist ,broken-edges ,floating-nodes ,order))) ,adjlist ,broken-edges ,order)))
(defmacro dag-test-alist-insert-is-valid-p (alist to-insert adjlist broken-edges (defmacro dag-test-alist-insert-is-valid-p (alist to-insert adjlist broken-edges
floating-nodes order) order)
(declare (indent 2)) (declare (indent 2))
`(let ((dag (->> (dag-alist-to-dag ',alist) `(let ((dag (->> (dag-alist-to-dag ',alist)
(dag-insert-nodes ',to-insert)))) (dag-insert-nodes ',to-insert))))
(dag-test-dag-is-valid-p dag (dag-test-dag-is-valid-p dag
,adjlist ,broken-edges ,floating-nodes ,order))) ,adjlist ,broken-edges ,order)))
(defmacro dag-test-alist-edit-is-valid-p (alist to-remove to-insert adjlist (defmacro dag-test-alist-edit-is-valid-p (alist to-remove to-insert adjlist
broken-edges floating-nodes broken-edges order)
order)
(declare (indent 3)) (declare (indent 3))
`(let ((dag (->> (dag-alist-to-dag ',alist) `(let ((dag (->> (dag-alist-to-dag ',alist)
(dag-edit-nodes ',to-remove ',to-insert)))) (dag-edit-nodes ',to-remove ',to-insert))))
(dag-test-dag-is-valid-p dag (dag-test-dag-is-valid-p dag
,adjlist ,broken-edges ,floating-nodes ,order))) ,adjlist ,broken-edges ,order)))
;; tests ;; tests
(ert-deftest dag-test-null () (ert-deftest dag-test-null ()
(dag-test-alist-is-valid-p nil (dag-test-alist-is-valid-p nil
nil
nil nil
nil nil
nil)) nil))
(ert-deftest dag-test-one () (ert-deftest dag-test-one ()
(dag-test-alist-is-valid-p ((a)) (dag-test-alist-is-valid-p ((a))
((a :children nil :parents nil))
nil nil
nil (a)))
(a)
nil))
(ert-deftest dag-test-one-cycle () (ert-deftest dag-test-one-cycle ()
(dag-test-alist-is-valid-p ((a a)) (dag-test-alist-is-valid-p ((a a))
((a :children (a) :parents (a))) ((a :children (a) :parents (a)))
nil nil
nil
nil)) nil))
(ert-deftest dag-test-one-broken () (ert-deftest dag-test-one-broken ()
(dag-test-alist-is-valid-p ((a b)) (dag-test-alist-is-valid-p ((a b))
nil ((a :children nil :parents nil))
((a b)) ((a b))
(a) (a)))
nil))
(ert-deftest dag-test-two () (ert-deftest dag-test-two ()
(dag-test-alist-is-valid-p ((a) (b a)) (dag-test-alist-is-valid-p ((a) (b a))
((a :children (b) :parents nil) ((a :children (b) :parents nil)
(b :children nil :parents (a))) (b :children nil :parents (a)))
nil nil
nil
(a b))) (a b)))
(ert-deftest dag-test-two-cycle () (ert-deftest dag-test-two-cycle ()
@ -149,22 +142,20 @@
((a :children (b) :parents (b)) ((a :children (b) :parents (b))
(b :children (a) :parents (a))) (b :children (a) :parents (a)))
nil nil
nil
nil)) nil))
(ert-deftest dag-test-two-floating () (ert-deftest dag-test-two-floating ()
(dag-test-alist-is-valid-p ((a) (b)) (dag-test-alist-is-valid-p ((a) (b))
((a :children nil :parents nil)
(b :children nil :parents nil))
nil nil
nil (b a)))
(a b)
nil))
(ert-deftest dag-test-two-broken () (ert-deftest dag-test-two-broken ()
(dag-test-alist-is-valid-p ((a) (b a c)) (dag-test-alist-is-valid-p ((a) (b a c))
((a :children (b) :parents nil) ((a :children (b) :parents nil)
(b :children nil :parents (a))) (b :children nil :parents (a)))
((b c)) ((b c))
nil
(a b))) (a b)))
(ert-deftest dag-test-three-linear () (ert-deftest dag-test-three-linear ()
@ -173,7 +164,6 @@
(b :children (c) :parents (a)) (b :children (c) :parents (a))
(c :children nil :parents (b))) (c :children nil :parents (b)))
nil nil
nil
(a b c))) (a b c)))
(ert-deftest dag-test-three-tree () (ert-deftest dag-test-three-tree ()
@ -182,7 +172,6 @@
(b :children nil :parents (a)) (b :children nil :parents (a))
(c :children nil :parents (a))) (c :children nil :parents (a)))
nil nil
nil
(a c b))) (a c b)))
(ert-deftest dag-test-complicated () (ert-deftest dag-test-complicated ()
@ -197,10 +186,11 @@
(b :children (d e) :parents (a)) (b :children (d e) :parents (a))
(c :children (d e) :parents (a)) (c :children (d e) :parents (a))
(d :children nil :parents (b c)) (d :children nil :parents (b c))
(e :children nil :parents (b c))) (e :children nil :parents (b c))
(x :children nil :parents nil)
(z :children nil :parents nil))
((x y)) ((x y))
(x z) (z x a c b e d)))
(a c b e d)))
(ert-deftest dag-test-remove () (ert-deftest dag-test-remove ()
(dag-test-alist-remove-is-valid-p ((a) (dag-test-alist-remove-is-valid-p ((a)
@ -214,7 +204,6 @@
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (b c))) (d :children nil :parents (b c)))
nil nil
nil
(a c b d))) (a c b d)))
(ert-deftest dag-test-remove-break () (ert-deftest dag-test-remove-break ()
@ -228,7 +217,6 @@
(b :children (d) :parents (a)) (b :children (d) :parents (a))
(d :children nil :parents (b))) (d :children nil :parents (b)))
((d c)) ((d c))
nil
(a b d))) (a b d)))
(ert-deftest dag-test-remove-break-float () (ert-deftest dag-test-remove-break-float ()
@ -238,10 +226,10 @@
(d c)) (d c))
(b) (b)
((c :children (d) :parents nil) ((c :children (d) :parents nil)
(d :children nil :parents (c))) (d :children nil :parents (c))
(a :children nil :parents nil))
((c b)) ((c b))
(a) (c a d)))
(c d)))
(ert-deftest dag-test-insert () (ert-deftest dag-test-insert ()
(dag-test-alist-insert-is-valid-p ((a) (dag-test-alist-insert-is-valid-p ((a)
@ -255,7 +243,6 @@
(d :children nil :parents (b c)) (d :children nil :parents (b c))
(e :children nil :parents (b c))) (e :children nil :parents (b c)))
nil nil
nil
(a c b d e))) (a c b d e)))
(ert-deftest dag-test-insert-overwrite () (ert-deftest dag-test-insert-overwrite ()
@ -269,7 +256,6 @@
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (b c))) (d :children nil :parents (b c)))
((d x)) ((d x))
nil
(a c b d))) (a c b d)))
(ert-deftest dag-test-insert-floating () (ert-deftest dag-test-insert-floating ()
@ -279,10 +265,10 @@
((d)) ((d))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children nil :parents (a)) (b :children nil :parents (a))
(c :children nil :parents (a))) (c :children nil :parents (a))
(d :children nil :parents nil))
nil nil
(d) (a d c b)))
(a c b)))
(ert-deftest dag-test-insert-broken () (ert-deftest dag-test-insert-broken ()
(dag-test-alist-insert-is-valid-p ((a) (dag-test-alist-insert-is-valid-p ((a)
@ -294,7 +280,6 @@
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (c))) (d :children nil :parents (c)))
((d x)) ((d x))
nil
(a c b d))) (a c b d)))
(ert-deftest dag-test-insert-fix-broken () (ert-deftest dag-test-insert-fix-broken ()
@ -307,7 +292,6 @@
(c :children (d) :parents (b)) (c :children (d) :parents (b))
(d :children nil :parents (c))) (d :children nil :parents (c)))
nil nil
nil
(a b c d))) (a b c d)))
(ert-deftest dag-test-edit () (ert-deftest dag-test-edit ()
@ -325,7 +309,6 @@
(d :children nil :parents (c)) (d :children nil :parents (c))
(e :children nil :parents (c))) (e :children nil :parents (c)))
((e b)) ((e b))
nil
(c a e d))) (c a e d)))
(ert-deftest dag-test-edit-remove () (ert-deftest dag-test-edit-remove ()
@ -341,7 +324,6 @@
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (b c))) (d :children nil :parents (b c)))
nil nil
nil
(a c b d))) (a c b d)))
(ert-deftest dag-test-edit-insert () (ert-deftest dag-test-edit-insert ()
@ -357,7 +339,6 @@
(d :children nil :parents (b c)) (d :children nil :parents (b c))
(e :children nil :parents (b c))) (e :children nil :parents (b c)))
nil nil
nil
(a c b d e))) (a c b d e)))
(ert-deftest dag-test-edit-null () (ert-deftest dag-test-edit-null ()
@ -374,7 +355,6 @@
(d :children nil :parents (b c)) (d :children nil :parents (b c))
(e :children nil :parents (b c))) (e :children nil :parents (b c)))
nil nil
nil
(a c b e d))) (a c b e d)))
(ert-deftest dag-test-edit-cancel () (ert-deftest dag-test-edit-cancel ()
@ -392,8 +372,7 @@
(d :children nil :parents (b c)) (d :children nil :parents (b c))
(e :children nil :parents (b c))) (e :children nil :parents (b c)))
nil nil
nil (a c b e d)))
(a b c d e)))
;; TODO add test for transitive reduction ;; TODO add test for transitive reduction