Coverage report: /home/runner/work/geb/geb/src/gui/graphing/passes.lisp

KindCoveredAll%
expression093 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-gui.graphing.passes)
2
 
3
 (-> passes (node) node)
4
 (defun passes (node)
5
   "Runs all the passes that simplify viewing the graph.
6
 These simplifications should not change the semantics of the graph,
7
 only display it in a more bearable way"
8
   (~> node
9
       fold-right-case-dists
10
       fold-right-cases))
11
 
12
 (-> fold-right-cases (node) (values node &optional))
13
 (defun fold-right-cases (node)
14
   (when (typep (representation node) 'case)
15
     (setf (children node) (linearize-right-case node))
16
     (notorize-children-with-index-schema "χ" node))
17
   (recurse node #'fold-right-cases))
18
 
19
 (-> fold-right-case-dists (node) (values node &optional))
20
 (defun fold-right-case-dists (node)
21
   (when (linear-distp node)
22
     (setf (children node) (linearize-right-dist-case node))
23
     (notorize-children-with-index-schema "δχ" node))
24
   (recurse node #'fold-right-case-dists))
25
 
26
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
 ;; Pass helpers
28
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29
 
30
 (-> recruse (node (-> (node) t)) node)
31
 (defun recurse (node func)
32
   "Recuses on the child of the node given the pass function"
33
   (setf (children node)
34
         (mapcar func (children node)))
35
   node)
36
 
37
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38
 ;; Linearize Helpers
39
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40
 
41
 (-> linearize-right-case (node) list)
42
 (defun linearize-right-case (node)
43
   "Lineraizes out all the right cases into a proper node list"
44
   (if (typep (representation node) 'case)
45
       (let ((children (children node)))
46
         (append (butlast children)
47
                 (linearize-right-case (car (last children)))))
48
       (list node)))
49
 
50
 (-> linear-distp (node) boolean)
51
 (defun linear-distp (node)
52
   (let ((child (car (children node))))
53
     (and (typep (representation node)  'distribute)
54
          (typep (representation child) 'case)
55
          (= 1 (length (children node))))))
56
 
57
 (-> linearize-right-dist-case (node) list)
58
 (defun linearize-right-dist-case (node)
59
   (let ((grand-kids (children (car (children node)))))
60
     (if (linear-distp node)
61
         (append (butlast grand-kids)
62
                 (linearize-right-dist-case (car (last grand-kids))))
63
         (list node))))
64
 ���