From 1516ad0fbc28e182629d7e9739ce81e56e6a539e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 25 Mar 2022 23:31:41 -0400 Subject: [PATCH] ENH update dag to take plist-based input --- local/lib/dag/dag.el | 30 +++-- local/lib/dag/test/dag-test.el | 196 +++++++++++++++++---------------- 2 files changed, 118 insertions(+), 108 deletions(-) diff --git a/local/lib/dag/dag.el b/local/lib/dag/dag.el index aebb30a..144d5a8 100644 --- a/local/lib/dag/dag.el +++ b/local/lib/dag/dag.el @@ -121,8 +121,8 @@ parent keys for that child." (->> (ht-get adjlist key) (dag-relation-get-parents))) -(defun dag--new-relationship (p c) - (list :parents p :children c)) +(defun dag--new-relationship (p c n) + (list :parents p :children c :node-meta n)) (defmacro dag--each-key (h &rest body) (declare (indent 1)) @@ -162,7 +162,7 @@ parent keys for that child." (nreverse ordered-nodes)))) (defun dag--alist-to-ht (parent-adjlist) - (let ((h (dag--ht-create parent-adjlist)) + (let ((h (dag--ht-create nil)) (broken-edges (dag--ht-create nil)) (parents) (relations) @@ -174,7 +174,11 @@ parent keys for that child." ;; O(N) (while parent-adjlist (setq cur (car parent-adjlist)) - (ht-set h (car cur) (dag--new-relationship (cdr cur) nil)) + (ht-set h + (plist-get cur :id) + (dag--new-relationship (plist-get cur :parents) + nil + (plist-get cur :node-meta))) (!cdr parent-adjlist)) ;; Add child relationships: For each node key, get the parent relation keys, ;; and for each of these, lookup the key in the hash table and add the @@ -324,11 +328,12 @@ ZS." (defun dag--adjlist-insert-nodes (to-insert adjlist broken-ht) (let (i i-key i-rel edges-to-add parent-edges broken-edges edges-to-remove - parent-rel to-insert*) + parent-rel to-insert* meta-to-add) (while to-insert (setq i (car to-insert) - i-key (car i) - edges-to-add (cdr i)) + i-key (plist-get i :id) + edges-to-add (plist-get i :parents) + meta-to-add (plist-get i :node-meta)) ;; Add new node: ;; ;; If the node does not exist, add an empty relationship (it will be @@ -336,7 +341,7 @@ ZS." ;; table, transfer it to the adjacency list. (if (not (setq i-rel (ht-get adjlist i-key))) (progn - (ht-set adjlist i-key (dag--new-relationship nil nil)) + (ht-set adjlist i-key (dag--new-relationship nil nil meta-to-add)) (dag--mend-edge adjlist broken-ht i-key)) ;; If the node does exist, get the edges that shouldn't be changed ;; (added & current), the edges that are to be added (added - current) @@ -347,16 +352,17 @@ ZS." ;; added for later. (setq parent-edges (plist-get i-rel :parents)) (dag--intersection-difference parent-edges edges-to-add edges-to-remove) - (ht-set adjlist i-key (plist-put i-rel :parents parent-edges)) + (ht-set adjlist i-key (-> (plist-put i-rel :parents parent-edges) + (plist-put :node-meta meta-to-add))) (--each edges-to-remove (dag--adjlist-remove-child-edge it i-key adjlist)) ;; Similar to above, get the edges to be added and the nodes that are to ;; remain, and set the broken edges hash table to the latter. (setq broken-edges (ht-get broken-ht i-key)) (dag--intersection-difference broken-edges edges-to-add) - (ht-set broken-ht i-key broken-edges) - (!cons (cons i-key edges-to-add) to-insert*) - (!cdr to-insert))) + (ht-set broken-ht i-key broken-edges)) + (!cons (cons i-key edges-to-add) to-insert*) + (!cdr to-insert)) ;; Add edges in a separate loop since we need all the inserted nodes to be ;; present before testing if an edge is broken (while to-insert* diff --git a/local/lib/dag/test/dag-test.el b/local/lib/dag/test/dag-test.el index 468c38e..11ba2c1 100644 --- a/local/lib/dag/test/dag-test.el +++ b/local/lib/dag/test/dag-test.el @@ -113,53 +113,55 @@ nil)) (ert-deftest dag-test-one () - (dag-test-alist-is-valid-p ((a)) + (dag-test-alist-is-valid-p ((:id a)) ((a :children nil :parents nil)) nil (a))) (ert-deftest dag-test-one-cycle () - (dag-test-alist-is-valid-p ((a a)) + (dag-test-alist-is-valid-p ((:id a :parents (a))) ((a :children (a) :parents (a))) nil nil)) (ert-deftest dag-test-one-broken () - (dag-test-alist-is-valid-p ((a b)) + (dag-test-alist-is-valid-p ((:id a :parents (b))) ((a :children nil :parents nil)) ((a b)) (a))) (ert-deftest dag-test-two () - (dag-test-alist-is-valid-p ((a) (b a)) + (dag-test-alist-is-valid-p ((:id a) (:id b :parents (a))) ((a :children (b) :parents nil) (b :children nil :parents (a))) nil (a b))) (ert-deftest dag-test-two-cycle () - (dag-test-alist-is-valid-p ((a b) (b a)) + (dag-test-alist-is-valid-p ((:id a :parents (b)) (:id b :parents (a))) ((a :children (b) :parents (b)) (b :children (a) :parents (a))) nil nil)) (ert-deftest dag-test-two-floating () - (dag-test-alist-is-valid-p ((a) (b)) + (dag-test-alist-is-valid-p ((:id a) (:id b)) ((a :children nil :parents nil) (b :children nil :parents nil)) nil - (b a))) + (a b))) (ert-deftest dag-test-two-broken () - (dag-test-alist-is-valid-p ((a) (b a c)) + (dag-test-alist-is-valid-p ((:id a) (:id b :parents (a c))) ((a :children (b) :parents nil) (b :children nil :parents (a))) ((b c)) (a b))) (ert-deftest dag-test-three-linear () - (dag-test-alist-is-valid-p ((a) (b a) (c b)) + (dag-test-alist-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (b))) ((a :children (b) :parents nil) (b :children (c) :parents (a)) (c :children nil :parents (b))) @@ -167,21 +169,23 @@ (a b c))) (ert-deftest dag-test-three-tree () - (dag-test-alist-is-valid-p ((a) (b a) (c a)) + (dag-test-alist-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a))) ((a :children (b c) :parents nil) (b :children nil :parents (a)) (c :children nil :parents (a))) nil - (a c b))) + (a b c))) (ert-deftest dag-test-complicated () - (dag-test-alist-is-valid-p ((a) - (b a) - (c a) - (d c b) - (e c b) - (x y) - (z)) + (dag-test-alist-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (c b)) + (:id e :parents (c b)) + (:id x :parents (y)) + (:id z)) ((a :children (b c) :parents nil) (b :children (d e) :parents (a)) (c :children (d e) :parents (a)) @@ -190,28 +194,28 @@ (x :children nil :parents nil) (z :children nil :parents nil)) ((x y)) - (z x a c b e d))) + (a x z b c d e))) (ert-deftest dag-test-remove () - (dag-test-alist-remove-is-valid-p ((a) - (b a) - (c a) - (d c b) - (e c b)) + (dag-test-alist-remove-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (c b)) + (:id e :parents (c b))) (e) ((a :children (b c) :parents nil) (b :children (d) :parents (a)) (c :children (d) :parents (a)) (d :children nil :parents (b c))) nil - (a c b d))) + (a b c d))) (ert-deftest dag-test-remove-break () - (dag-test-alist-remove-is-valid-p ((a) - (b a) - (c a) - (d c b) - (e c b)) + (dag-test-alist-remove-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (c b)) + (:id e :parents (c b))) (e c) ((a :children (b) :parents nil) (b :children (d) :parents (a)) @@ -220,73 +224,73 @@ (a b d))) (ert-deftest dag-test-remove-break-float () - (dag-test-alist-remove-is-valid-p ((a) - (b a) - (c b) - (d c)) + (dag-test-alist-remove-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (b)) + (:id d :parents (c))) (b) ((c :children (d) :parents nil) (d :children nil :parents (c)) (a :children nil :parents nil)) ((c b)) - (c a d))) + (a c d))) (ert-deftest dag-test-insert () - (dag-test-alist-insert-is-valid-p ((a) - (b a) - (c a)) - ((d c b) - (e c b)) + (dag-test-alist-insert-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a))) + ((:id d :parents (c b)) + (:id e :parents (c b))) ((a :children (b c) :parents nil) (b :children (d e) :parents (a)) (c :children (d e) :parents (a)) (d :children nil :parents (b c)) (e :children nil :parents (b c))) nil - (a c b d e))) + (a b c d e))) (ert-deftest dag-test-insert-overwrite () - (dag-test-alist-insert-is-valid-p ((a) - (b a) - (c a) - (d b)) - ((d b c x)) + (dag-test-alist-insert-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (b))) + ((:id d :parents (b c x))) ((a :children (b c) :parents nil) (b :children (d) :parents (a)) (c :children (d) :parents (a)) (d :children nil :parents (b c))) ((d x)) - (a c b d))) + (a b c d))) (ert-deftest dag-test-insert-floating () - (dag-test-alist-insert-is-valid-p ((a) - (b a) - (c a)) - ((d)) + (dag-test-alist-insert-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a))) + ((:id d)) ((a :children (b c) :parents nil) (b :children nil :parents (a)) (c :children nil :parents (a)) (d :children nil :parents nil)) nil - (a d c b))) + (a d b c))) (ert-deftest dag-test-insert-broken () - (dag-test-alist-insert-is-valid-p ((a) - (b a) - (c a)) - ((d c x)) + (dag-test-alist-insert-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a))) + ((:id d :parents (c x))) ((a :children (b c) :parents nil) (b :children nil :parents (a)) (c :children (d) :parents (a)) (d :children nil :parents (c))) ((d x)) - (a c b d))) + (a b c d))) (ert-deftest dag-test-insert-fix-broken () - (dag-test-alist-insert-is-valid-p ((a) - (b a) - (d c)) - ((c b)) + (dag-test-alist-insert-is-valid-p ((:id a) + (:id b :parents (a)) + (:id d :parents (c))) + ((:id c :parents (b))) ((a :children (b) :parents nil) (b :children (c) :parents (a)) (c :children (d) :parents (b)) @@ -295,28 +299,28 @@ (a b c d))) (ert-deftest dag-test-edit () - (dag-test-alist-edit-is-valid-p ((a) - (b a) - (c a) - (d b c) - (e b c)) + (dag-test-alist-edit-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (b c)) + (:id e :parents (b c))) (b) - ((c) - (d c) - (a c)) + ((:id c) + (:id d :parents (c)) + (:id a :parents (c))) ((a :children nil :parents (c)) (c :children (a d e) :parents nil) (d :children nil :parents (c)) (e :children nil :parents (c))) ((e b)) - (c a e d))) + (c a d e))) (ert-deftest dag-test-edit-remove () - (dag-test-alist-edit-is-valid-p ((a) - (b a) - (c a) - (d b c) - (e b c)) + (dag-test-alist-edit-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (b c)) + (:id e :parents (b c))) (e) nil ((a :children (b c) :parents nil) @@ -324,29 +328,29 @@ (c :children (d) :parents (a)) (d :children nil :parents (b c))) nil - (a c b d))) + (a b c d))) (ert-deftest dag-test-edit-insert () - (dag-test-alist-edit-is-valid-p ((a) - (b a) - (c a)) + (dag-test-alist-edit-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a))) nil - ((d c b) - (e c b)) + ((:id d :parents (c b)) + (:id e :parents (c b))) ((a :children (b c) :parents nil) (b :children (d e) :parents (a)) (c :children (d e) :parents (a)) (d :children nil :parents (b c)) (e :children nil :parents (b c))) nil - (a c b d e))) + (a b c d e))) (ert-deftest dag-test-edit-null () - (dag-test-alist-edit-is-valid-p ((a) - (b a) - (c a) - (d b c) - (e b c)) + (dag-test-alist-edit-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (b c)) + (:id e :parents (b c))) nil nil ((a :children (b c) :parents nil) @@ -355,24 +359,24 @@ (d :children nil :parents (b c)) (e :children nil :parents (b c))) nil - (a c b e d))) + (a b c d e))) (ert-deftest dag-test-edit-cancel () - (dag-test-alist-edit-is-valid-p ((a) - (b a) - (c a) - (d b c) - (e b c)) + (dag-test-alist-edit-is-valid-p ((:id a) + (:id b :parents (a)) + (:id c :parents (a)) + (:id d :parents (b c)) + (:id e :parents (b c))) (b d) - ((b a) - (d b c)) + ((:id b :parents (a)) + (:id d :parents (b c))) ((a :children (b c) :parents nil) (b :children (e d) :parents (a)) (c :children (e d) :parents (a)) (d :children nil :parents (b c)) (e :children nil :parents (b c))) nil - (a c b e d))) + (a b c d e))) ;; TODO add test for transitive reduction