Coverage report: /home/runner/work/geb/geb/src/gui/present-graph.lisp

KindCoveredAll%
expression0159 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-gui)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
 ;; Main graphing entry points
5
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
 
7
 (defun graph-dot (object pane)
8
   "Graphing using dot"
9
   (format-graph-from-roots
10
    (list object) #'present-object #'graph::children
11
    :stream      pane
12
    :arc-drawer  (dot-arc-drawer)
13
    :graph-type  :dot-digraph
14
    :orientation :vertical
15
    :center-nodes          t
16
    :merge-duplicates      t
17
    :maximize-generations  t
18
    :generation-separation 50
19
    :within-generation-separation 20))
20
 
21
 (defun graph-node (object pane)
22
   "Graphing using the normal digraph"
23
   (format-graph-from-roots
24
    (list object) #'present-object #'graph::children
25
    :stream pane
26
    :maximize-generations t
27
    :center-nodes t
28
    :merge-duplicates t
29
    :generation-separation 50
30
    :within-generation-separation 20
31
    :arc-drawer #'digraph-arc-drawer
32
    :graph-type :digraph
33
    :arc-drawing-options (list :line-thickness 1.4 :head-width 5)))
34
 
35
 (defun stick-graph (object pane)
36
   (format-graph-from-roots
37
    (list object)
38
    #'present-object
39
    #'visual-children
40
    :stream pane
41
    :maximize-generations t
42
    :center-nodes t
43
    ;; :orientation :vertical
44
    :generation-separation 20
45
    :within-generation-separation 20
46
    :arc-drawing-options (list :line-thickness 1.4 :head-width 5)))
47
 
48
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49
 ;; Arc Drawers for the graphs
50
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51
 
52
 (defun dot-arc-drawer ()
53
   (make-instance
54
    'mcclim-dot:dot-arc-drawer
55
    :edge-label-printer
56
    (lambda (drawer stream from to)
57
      (declare (ignore drawer))
58
      (let ((obj (graph:determine-text-and-object-from-node from to)))
59
        (with-output-as-presentation (stream (cadr obj) (type-of (cadr obj)))
60
          (format stream (car obj)))))))
61
 
62
 (defun digraph-arc-drawer (pane from-node to-node x1 y1 x2 y2
63
                            &rest drawing-options
64
                            &key &allow-other-keys)
65
   (with-drawing-options (pane
66
                          :transform (clim:make-rotation-transformation
67
                                      (atan (- y2 y1) (- x2 x1)))
68
                          :text-style (make-text-style nil nil 12))
69
     (apply #'draw-arrow* pane x1 y1 x2 y2 drawing-options)
70
     (let ((obj (graph:determine-text-and-object-from-node
71
                 (clim:graph-node-object from-node)
72
                 (clim:graph-node-object to-node))))
73
       (with-output-as-presentation (pane (cadr obj) (type-of (cadr obj)))
74
         (draw-text* pane (car obj)
75
                     (/ (+ x1 x2) 2)
76
                     (/ (+ y1 y2) 2)
77
                     :toward-y (* 2 y2)
78
                     :toward-x (* 2 x2)
79
                     :align-y :top
80
                     :align-y :bottom
81
                     :align-x :center
82
                     :transform-glyphs t)))))
83
 
84
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
85
 ;; Children API
86
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87
 
88
 (defgeneric visual-children (obj)
89
   (:documentation "The visual-children of the given node"))
90
 
91
 (defmethod visual-children ((obj geb.mixins:pointwise-mixin))
92
   (mapcar #'cdr (geb.mixins:to-pointwise-list obj)))
93
 
94
 ;; we want to visualize it in the presentation not in the graph
95
 (defmethod visual-children ((obj geb:prod))
96
   (geb:same-type-to-list obj 'geb:prod))
97
 
98
 (defmethod visual-children ((obj t))
99
   nil)