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

KindCoveredAll%
expression124385 32.2
branch812 66.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package #:geb-gui.core)
2
 
3
 (defgeneric representation (object))
4
 (defgeneric children (object))
5
 (defgeneric value (object))
6
 
7
 (deftype note ()
8
   "A note is a note about a new node in the graph or a note about a
9
 NODE which should be merged into an upcoming NODE.
10
 
11
 An example of a [NODE-NOTE][class] would be in the case of pair
12
 
13
 ```lisp
14
 (pair g f)
15
 ```
16
 
17
 ```
18
                Π₁
19
      --f--> Y------
20
 X----|            |-----> [Y × Z]
21
      --g--> Z-----
22
                Π₂
23
 ```
24
 
25
 
26
 
27
 An example of a [MERGE-NOTE][class]
28
 
29
 ```lisp
30
 (Case f g)
31
 (COMP g f)
32
 ```
33
 
34
 ```
35
            χ₁
36
          -------> X --f---\
37
 [X + Y]--|                ---> A
38
          -------> Y --g---/
39
            χ₂
40
 
41
 X -f-> Y --> Y -g-> Z
42
 ```
43
 
44
 Notice that in the pair case, we have a note and a shared node to
45
 place down, where as in both of the [MERGE-NOTE][class] examples, the
46
 Note at the end is not pre-pended by any special information"
47
   `(or node-note squash-note))
48
 
49
 (defclass node-note ()
50
   ((value :initarg :value
51
           :accessor value
52
           :type node
53
           :documentation "The value")
54
    (note :initarg :note
55
          :accessor note
56
          :documentation "A note on where the node came from")
57
    (from :initarg :from
58
          :accessor from
59
          :type (or <substobj> <substmorph>)
60
          :documentation "The representation value that made the note")))
61
 
62
 (defclass squash-note ()
63
   ((value :initarg :value
64
           :accessor value
65
           :type node
66
           :documentation "The value"))
67
   (:documentation "This note should be squashed into another note and or node."))
68
 
69
 (defclass node (meta-mixin)
70
   ;; this is the data we end up showing
71
   (;; this is the real data this is representing
72
    (value :initarg :value
73
           :accessor value
74
           :documentation "The value to display")
75
    (representation :initarg :representation
76
                    :accessor representation
77
                    :documentation "The real data backing the presentation")
78
    (children :initarg :children
79
              :type list
80
              :initform nil
81
              :accessor children
82
              :documentation "The children "))
83
   (:documentation "I represent a graphical node structure. I contain my children and a
84
 value to display, along with the representation for which the node really stands for.
85
 
86
 Further, we derive the meta-mixin, as it's important for arrow drawing
87
 to know if we are the left or the right or the nth child of a
88
 particular node. This information is tracked, by storing the object
89
 that goes to it in the meta table and recovering the note."))
90
 
91
 
92
 (defgeneric graphize (morph notes)
93
   (:documentation
94
    "Turns a morphism into a node graph.
95
 
96
 The NOTES serve as a way of sharing and continuing computation.
97
 
98
 If the NOTE is a :SHARED NOTE then it represents a [NODE][class]
99
 without children, along with saying where it came from. This is to be
100
 stored in parent of the NOTE
101
 
102
 If the NOTE is a :CONTINUE NOTE, then the computation is continued at
103
 the spot.
104
 
105
 The parent field is to set the note on the parent if the NOTE is going
106
 to be merged"))
107
 
108
 (-> continue-graphizing (node list) node)
109
 (defun continue-graphizing (node notes)
110
   "Continues the computation, applying the NOTES as appropriate"
111
   (apply-notes node notes))
112
 
113
 (defmethod graphize ((morph <substmorph>) notes)
114
   (assure node
115
     (cond
116
       ((and (has-aliasp morph)
117
             (typep morph '<substobj>))
118
        (let ((node (continue-graphizing
119
                     (make-instance 'node :representation morph :value morph)
120
                     notes))
121
              (name (meta-lookup morph :alias)))
122
          (name-node node name)))
123
       ((has-aliasp morph)
124
        (alias-moprh morph notes))
125
       (t
126
        (typecase-of substmorph morph
127
          ((or terminal init distribute inject-left inject-right project-left project-right)
128
           (dom-codom-graph morph notes))
129
          (substobj
130
           (continue-graphizing (make-instance 'node :representation morph :value morph)
131
                                notes))
132
          ;; (comp g f)
133
          ;; X --f--> Y --g--> Z
134
          (comp
135
           (graphize (mcadr morph)
136
                     (list (make-squash :value (graphize (mcar morph) notes)))))
137
          ;; (case g f)
138
          ;;             χ₁
139
          ;;           ------> X ----g----
140
          ;; [X × Y]--|                  |---> A
141
          ;;           ------> Y ----f----
142
          ;;             χ₂
143
          (case
144
              (let ((goal (make-squash :value (graphize (codom morph) nil))))
145
                (flet ((make-child (node)
146
                         (graphize node (cons-note goal notes))))
147
                  (notorize-children-with-index-schema
148
                   "χ"
149
                   (make-instance 'node
150
                                  :representation morph
151
                                  :value (dom morph)
152
                                  :children (list (make-child (mcar morph))
153
                                                  (make-child (mcadr morph))))))))
154
          ;; (pair g f)
155
          ;;                Π₁
156
          ;;      ---g--> Y ------
157
          ;;     /                \
158
          ;; X---                  ---> [Y × Z]
159
          ;;     \                /
160
          ;;      ---f--> Z ------
161
          ;;                Π₂
162
          (pair
163
           (let ((goal (graphize (codom morph) nil)))
164
             (flet ((make-child (node note)
165
                      (graphize node
166
                                (cons-note (make-note :from morph
167
                                                      :note note
168
                                                      :value goal)
169
                                           notes))))
170
               (cut-children
171
                (make-instance 'node
172
                               :value (dom morph)
173
                               :representation morph
174
                               :children (list (make-child (mcar morph) "Π₁")
175
                                               (make-child (mcdr morph) "Π₂")))))))
176
          (otherwise
177
           (geb.utils:subclass-responsibility morph)))))))
178
 
179
 (defmethod graphize ((ref geb.common:reference) notes)
180
   (name-node (continue-graphizing
181
               (make-instance 'node :representation ref :value ref)
182
               notes)
183
              (name ref)))
184
 
185
 (defmethod graphize ((opaque geb.common:opaque-morph) notes)
186
   (if (has-aliasp opaque)
187
       (alias-moprh opaque notes)
188
       (dom-codom-graph opaque notes)))
189
 
190
 (defmethod graphize ((opaque geb.common:opaque) notes)
191
   (continue-graphizing (make-instance 'node :representation opaque :value opaque)
192
                        notes))
193
 
194
 (defun alias-moprh (morph notes)
195
   (let ((node-codom (make-note :from morph
196
                                :note (symbol-name (meta-lookup morph :alias))
197
                                :value (graphize (codom morph) notes)))
198
         ;; TODO :: Replace me with the full (obj morph) instead.
199
         (node (make-squash :value (graphize (dom morph) nil))))
200
     (apply-note node node-codom)
201
     (value node)))
202
 
203
 (defun dom-codom-graph (morph notes)
204
   "We simply take the dom and codom and graph it"
205
   ;; Since there is no note in this case, this
206
   ;; representation will serve as the note as to
207
   ;; how we should annotate the arrow.
208
   (make-instance 'node :representation morph
209
                        :value (dom morph)
210
                        :children (list (graphize (codom morph) notes))))
211
 
212
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
213
 ;; cutting a node
214
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
215
 
216
 (-> cut-node (node) list)
217
 (defun cut-node (node)
218
   "removes a node from the graph preserving the NOTEs between the node
219
 and it's children.
220
 
221
 Creates a list of notes that preserve the original intent of the link"
222
   (mapcar (lambda (x)
223
             (let ((note (determine-text-and-object-from-node node x)))
224
               (make-note :from (cadr note)
225
                          :note (car note)
226
                          :value x)))
227
           (children node)))
228
 
229
 (-> cut-children (node) node)
230
 (defun cut-children (node)
231
   "Removes the direct CHILDREN from the graph, connecting the grand
232
 CHILDREN to the current node, preserving any notes that may have exited"
233
   (let* ((noted-node (make-squash :value node))
234
          (grand-kids (mapcan #'cut-node (children node))))
235
     (setf (children node) nil)
236
     (dolist (c (reverse grand-kids) node)
237
       (apply-note noted-node c))))
238
 
239
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240
 ;; Noterizing Children
241
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242
 
243
 (-> notorize-children-with-index-schema (string node) node)
244
 (defun notorize-children-with-index-schema (prefix node)
245
   "Notorizes the node with a prefix appended with the subscripted number"
246
   (noterize-children
247
    node
248
    (lambda (x index)
249
      (declare (ignore x))
250
      (format nil "~A~A" prefix (number-to-under index)))))
251
 
252
 (-> noterize-children (node (-> (node fixnum) string)) node)
253
 (defun noterize-children (node func)
254
   "Applies a specified note to the CHILDREN of the NODE.
255
 
256
 It does this by applying FUNC on all the CHILDREN and the index of the
257
 child in the list"
258
   (let* ((note-node (make-squash :value node))
259
          (children  (children node))
260
          (len       (length children)))
261
     (setf (children node) nil)
262
     (mapc (lambda (x index)
263
             (apply-note note-node
264
                         (make-note :from (value x)
265
                                    :note (funcall func x index)
266
                                    :value x)))
267
      (reverse children)
268
      (alexandria:iota len :step -1 :start len))
269
     node))
270
 
271
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
272
 ;; Note Helpers
273
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
274
 
275
 (defun make-note (&rest initargs &key from note value &allow-other-keys)
276
   (declare (ignore from note value))
277
   (apply #'make-instance 'node-note initargs))
278
 
279
 (defun make-squash (&rest initargs &key value &allow-other-keys)
280
   (declare (ignore value))
281
   (apply #'make-instance 'squash-note initargs))
282
 
283
 (defmethod print-object ((note node-note) stream)
284
   (print-unreadable-object (note stream :type nil)
285
     (with-slots (value note) note
286
       (format stream "NOTE: ~A ~@_VALUE: ~A" note value))))
287
 
288
 (defmethod print-object ((note squash-note) stream)
289
   (print-unreadable-object (note stream :type nil)
290
     (with-slots (value) note
291
       (format stream "VALUE: ~A" value))))
292
 
293
 (-> update-meta-data-with-note (node node-note) t)
294
 (defun update-meta-data-with-note (node note)
295
   "Inserts the NOTE into the NODE"
296
   (with-slots (value note from) note
297
     (meta-insert node value (list note from))))
298
 
299
 (-> cons-note (note list) list)
300
 (defun cons-note (note notes)
301
   "Adds a note to the notes list."
302
   (if (null notes)
303
       (list note)
304
       (etypecase-of note (car notes)
305
         (node-note
306
          (cons note notes))
307
         (squash-note
308
          (etypecase-of note note
309
            (node-note   (cons (make-note :from (from note)
310
                                          :note (note note)
311
                                          :value (value (car notes)))
312
                               (cdr notes)))
313
            (squash-note notes))))))
314
 
315
 ;; node, squash
316
 
317
 (-> apply-note (note note) node)
318
 (defun apply-note (note-to-be-on note)
319
   "Here we apply the NOTE to the NODE.
320
 
321
 In the case of a new node, we record down the information in the note,
322
 and set the note as the child of the current NODE. The NODE is
323
 returned.
324
 
325
 In the case of a squash-note, we instead just return the squash-note
326
 as that is the proper NODE to continue from"
327
   (assure node
328
     (etypecase-of note note
329
       (node-note (let ((node (value note-to-be-on)))
330
                    (update-meta-data-with-note node note)
331
                    (push (value note) (children node))
332
                    node))
333
       (squash-note
334
        (etypecase-of note note-to-be-on
335
          (node-note
336
           (push (value note)
337
                 (children (value note-to-be-on)))
338
           (value note-to-be-on))
339
          (squash-note
340
           (value note)))))))
341
 
342
 (-> apply-notes (node list) node)
343
 (defun apply-notes (node notes)
344
   "apply the NOTES onto the current NODE."
345
   (let* ((notes-with-node (cons-note (make-squash :value node) notes)))
346
     ;; collapse the nodes, these should all be nodes, due to how we
347
     ;; constructed it
348
     (mvfold (lambda (note child-note)
349
               (apply-note note child-note)
350
               child-note)
351
             (cdr notes-with-node)
352
             (car notes-with-node))
353
     (assure node
354
       (value (car notes-with-node)))))
355
 
356
 (defun determine-text-and-object-from-node (from to)
357
   "Helps lookup the text from the node"
358
   (or (meta-lookup from to)
359
       (list (geb:text-name (representation from))
360
             (representation from))))
361
 
362
 (defun name-node (node name)
363
   (with-slots (value) node
364
     (if (eql nil name)
365
         ;; hack
366
         (setf value (make-alias :name (intern (symbol-name name) 'keyword)
367
                                 :obj (shallow-copy-object value)))
368
         (setf value (make-alias :name name :obj (shallow-copy-object value))))
369
     node))
370
 ����������������������������������