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

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

@ -121,8 +121,8 @@ parent keys for that child."
(->> (ht-get adjlist key) (->> (ht-get adjlist key)
(dag-relation-get-parents))) (dag-relation-get-parents)))
(defun dag--new-relationship (p c) (defun dag--new-relationship (p c n)
(list :parents p :children c)) (list :parents p :children c :node-meta n))
(defmacro dag--each-key (h &rest body) (defmacro dag--each-key (h &rest body)
(declare (indent 1)) (declare (indent 1))
@ -162,7 +162,7 @@ parent keys for that child."
(nreverse ordered-nodes)))) (nreverse ordered-nodes))))
(defun dag--alist-to-ht (parent-adjlist) (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)) (broken-edges (dag--ht-create nil))
(parents) (parents)
(relations) (relations)
@ -174,7 +174,11 @@ parent keys for that child."
;; O(N) ;; O(N)
(while parent-adjlist (while parent-adjlist
(setq cur (car 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)) (!cdr parent-adjlist))
;; Add child relationships: For each node key, get the parent relation keys, ;; 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 ;; 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) (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 (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 (while to-insert
(setq i (car to-insert) (setq i (car to-insert)
i-key (car i) i-key (plist-get i :id)
edges-to-add (cdr i)) edges-to-add (plist-get i :parents)
meta-to-add (plist-get i :node-meta))
;; Add new node: ;; Add new node:
;; ;;
;; If the node does not exist, add an empty relationship (it will be ;; 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. ;; table, transfer it to the adjacency list.
(if (not (setq i-rel (ht-get adjlist i-key))) (if (not (setq i-rel (ht-get adjlist i-key)))
(progn (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)) (dag--mend-edge adjlist broken-ht i-key))
;; If the node does exist, get the edges that shouldn't be changed ;; If the node does exist, get the edges that shouldn't be changed
;; (added & current), the edges that are to be added (added - current) ;; (added & current), the edges that are to be added (added - current)
@ -347,16 +352,17 @@ ZS."
;; added for later. ;; added for later.
(setq parent-edges (plist-get i-rel :parents)) (setq parent-edges (plist-get i-rel :parents))
(dag--intersection-difference parent-edges edges-to-add edges-to-remove) (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 (--each edges-to-remove
(dag--adjlist-remove-child-edge it i-key adjlist)) (dag--adjlist-remove-child-edge it i-key adjlist))
;; Similar to above, get the edges to be added and the nodes that are to ;; 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. ;; remain, and set the broken edges hash table to the latter.
(setq broken-edges (ht-get broken-ht i-key)) (setq broken-edges (ht-get broken-ht i-key))
(dag--intersection-difference broken-edges edges-to-add) (dag--intersection-difference broken-edges edges-to-add)
(ht-set broken-ht i-key broken-edges) (ht-set broken-ht i-key broken-edges))
(!cons (cons i-key edges-to-add) to-insert*) (!cons (cons i-key edges-to-add) to-insert*)
(!cdr to-insert))) (!cdr to-insert))
;; Add edges in a separate loop since we need all the inserted nodes to be ;; Add edges in a separate loop since we need all the inserted nodes to be
;; present before testing if an edge is broken ;; present before testing if an edge is broken
(while to-insert* (while to-insert*

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

@ -113,53 +113,55 @@
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 ((:id a))
((a :children nil :parents nil)) ((a :children nil :parents nil))
nil nil
(a))) (a)))
(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 ((:id a :parents (a)))
((a :children (a) :parents (a))) ((a :children (a) :parents (a)))
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 ((:id a :parents (b)))
((a :children nil :parents nil)) ((a :children nil :parents nil))
((a b)) ((a b))
(a))) (a)))
(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 ((:id a) (:id b :parents (a)))
((a :children (b) :parents nil) ((a :children (b) :parents nil)
(b :children nil :parents (a))) (b :children nil :parents (a)))
nil nil
(a b))) (a b)))
(ert-deftest dag-test-two-cycle () (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)) ((a :children (b) :parents (b))
(b :children (a) :parents (a))) (b :children (a) :parents (a)))
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 ((:id a) (:id b))
((a :children nil :parents nil) ((a :children nil :parents nil)
(b :children nil :parents nil)) (b :children nil :parents nil))
nil nil
(b a))) (a b)))
(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 ((:id a) (:id b :parents (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))
(a b))) (a b)))
(ert-deftest dag-test-three-linear () (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) ((a :children (b) :parents nil)
(b :children (c) :parents (a)) (b :children (c) :parents (a))
(c :children nil :parents (b))) (c :children nil :parents (b)))
@ -167,21 +169,23 @@
(a b c))) (a b c)))
(ert-deftest dag-test-three-tree () (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) ((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)))
nil nil
(a c b))) (a b c)))
(ert-deftest dag-test-complicated () (ert-deftest dag-test-complicated ()
(dag-test-alist-is-valid-p ((a) (dag-test-alist-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d c b) (:id d :parents (c b))
(e c b) (:id e :parents (c b))
(x y) (:id x :parents (y))
(z)) (:id z))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children (d e) :parents (a)) (b :children (d e) :parents (a))
(c :children (d e) :parents (a)) (c :children (d e) :parents (a))
@ -190,28 +194,28 @@
(x :children nil :parents nil) (x :children nil :parents nil)
(z :children nil :parents nil)) (z :children nil :parents nil))
((x y)) ((x y))
(z x a c b e d))) (a x z b c d e)))
(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 ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d c b) (:id d :parents (c b))
(e c b)) (:id e :parents (c b)))
(e) (e)
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children (d) :parents (a)) (b :children (d) :parents (a))
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (b c))) (d :children nil :parents (b c)))
nil nil
(a c b d))) (a b c d)))
(ert-deftest dag-test-remove-break () (ert-deftest dag-test-remove-break ()
(dag-test-alist-remove-is-valid-p ((a) (dag-test-alist-remove-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d c b) (:id d :parents (c b))
(e c b)) (:id e :parents (c b)))
(e c) (e c)
((a :children (b) :parents nil) ((a :children (b) :parents nil)
(b :children (d) :parents (a)) (b :children (d) :parents (a))
@ -220,73 +224,73 @@
(a b d))) (a b d)))
(ert-deftest dag-test-remove-break-float () (ert-deftest dag-test-remove-break-float ()
(dag-test-alist-remove-is-valid-p ((a) (dag-test-alist-remove-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c b) (:id c :parents (b))
(d c)) (:id d :parents (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)) (a :children nil :parents nil))
((c b)) ((c b))
(c a d))) (a 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 ((:id a)
(b a) (:id b :parents (a))
(c a)) (:id c :parents (a)))
((d c b) ((:id d :parents (c b))
(e c b)) (:id e :parents (c b)))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(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)))
nil nil
(a c b d e))) (a b c d e)))
(ert-deftest dag-test-insert-overwrite () (ert-deftest dag-test-insert-overwrite ()
(dag-test-alist-insert-is-valid-p ((a) (dag-test-alist-insert-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d b)) (:id d :parents (b)))
((d b c x)) ((:id d :parents (b c x)))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children (d) :parents (a)) (b :children (d) :parents (a))
(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))
(a c b d))) (a b c d)))
(ert-deftest dag-test-insert-floating () (ert-deftest dag-test-insert-floating ()
(dag-test-alist-insert-is-valid-p ((a) (dag-test-alist-insert-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a)) (:id c :parents (a)))
((d)) ((:id 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)) (d :children nil :parents nil))
nil nil
(a d c b))) (a d b c)))
(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 ((:id a)
(b a) (:id b :parents (a))
(c a)) (:id c :parents (a)))
((d c x)) ((:id d :parents (c x)))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children nil :parents (a)) (b :children nil :parents (a))
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (c))) (d :children nil :parents (c)))
((d x)) ((d x))
(a c b d))) (a b c d)))
(ert-deftest dag-test-insert-fix-broken () (ert-deftest dag-test-insert-fix-broken ()
(dag-test-alist-insert-is-valid-p ((a) (dag-test-alist-insert-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(d c)) (:id d :parents (c)))
((c b)) ((:id c :parents (b)))
((a :children (b) :parents nil) ((a :children (b) :parents nil)
(b :children (c) :parents (a)) (b :children (c) :parents (a))
(c :children (d) :parents (b)) (c :children (d) :parents (b))
@ -295,28 +299,28 @@
(a b c d))) (a b c d)))
(ert-deftest dag-test-edit () (ert-deftest dag-test-edit ()
(dag-test-alist-edit-is-valid-p ((a) (dag-test-alist-edit-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d b c) (:id d :parents (b c))
(e b c)) (:id e :parents (b c)))
(b) (b)
((c) ((:id c)
(d c) (:id d :parents (c))
(a c)) (:id a :parents (c)))
((a :children nil :parents (c)) ((a :children nil :parents (c))
(c :children (a d e) :parents nil) (c :children (a d e) :parents nil)
(d :children nil :parents (c)) (d :children nil :parents (c))
(e :children nil :parents (c))) (e :children nil :parents (c)))
((e b)) ((e b))
(c a e d))) (c a d e)))
(ert-deftest dag-test-edit-remove () (ert-deftest dag-test-edit-remove ()
(dag-test-alist-edit-is-valid-p ((a) (dag-test-alist-edit-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d b c) (:id d :parents (b c))
(e b c)) (:id e :parents (b c)))
(e) (e)
nil nil
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
@ -324,29 +328,29 @@
(c :children (d) :parents (a)) (c :children (d) :parents (a))
(d :children nil :parents (b c))) (d :children nil :parents (b c)))
nil nil
(a c b d))) (a b c d)))
(ert-deftest dag-test-edit-insert () (ert-deftest dag-test-edit-insert ()
(dag-test-alist-edit-is-valid-p ((a) (dag-test-alist-edit-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a)) (:id c :parents (a)))
nil nil
((d c b) ((:id d :parents (c b))
(e c b)) (:id e :parents (c b)))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(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)))
nil nil
(a c b d e))) (a b c d e)))
(ert-deftest dag-test-edit-null () (ert-deftest dag-test-edit-null ()
(dag-test-alist-edit-is-valid-p ((a) (dag-test-alist-edit-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d b c) (:id d :parents (b c))
(e b c)) (:id e :parents (b c)))
nil nil
nil nil
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
@ -355,24 +359,24 @@
(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
(a c b e d))) (a b c d e)))
(ert-deftest dag-test-edit-cancel () (ert-deftest dag-test-edit-cancel ()
(dag-test-alist-edit-is-valid-p ((a) (dag-test-alist-edit-is-valid-p ((:id a)
(b a) (:id b :parents (a))
(c a) (:id c :parents (a))
(d b c) (:id d :parents (b c))
(e b c)) (:id e :parents (b c)))
(b d) (b d)
((b a) ((:id b :parents (a))
(d b c)) (:id d :parents (b c)))
((a :children (b c) :parents nil) ((a :children (b c) :parents nil)
(b :children (e d) :parents (a)) (b :children (e d) :parents (a))
(c :children (e d) :parents (a)) (c :children (e d) :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)))
nil nil
(a c b e d))) (a b c d e)))
;; TODO add test for transitive reduction ;; TODO add test for transitive reduction