ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH update dag to take plist-based input

This commit is contained in:
Nathan Dwarshuis 2022-03-25 23:31:41 -04:00
parent 42758a7f43
commit 1516ad0fbc
2 changed files with 118 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
local/lib/dag/dag.el
View File

@ -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*

196
local/lib/dag/test/dag-test.el
View File

@ -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