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

KindCoveredAll%
expression1102 1.0
branch08 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-gui)
2
 
3
 ;; My first horrible gui attempt, lets go!
4
 
5
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
 ;; Main Data
7
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8
 
9
 (defparameter *the-data* nil)
10
 
11
 (defvar *running* nil)
12
 
13
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14
 ;; Running the application
15
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16
 
17
 (defun visualize (object &optional (async t))
18
   "Visualizes both GEB:@GEB-SUBSTMU and GEB:@GEB-SUBSTMORPH objects"
19
   (flet ((run ()
20
            (let ((*the-data* object))
21
              (run-frame-top-level (make-application-frame 'display-clim)))))
22
     (if async
23
         (push (bt:make-thread #'run) *running*)
24
         (funcall #'run))))
25
 
26
 (defun svg (object path &key (default-view (make-instance 'show-view)))
27
   "Runs the visualizer, outputting a static SVG image at the directory of choice.
28
 
29
 You can customize the view. By default it uses the show-view, which is
30
 the default of the visualizer.
31
 
32
 A good example usage is
33
 
34
 ```lisp
35
 GEB-TEST> (geb-gui:svg (shallow-copy-object geb-bool:and) \"/tmp/foo.svg\")
36
 ```"
37
   (clime:with-output-to-drawing-stream (stream :svg path :preview nil)
38
     (setf (clim:stream-default-view stream) default-view)
39
     (display-graph-dot object stream)))
40
 
41
 (defun kill-running ()
42
   "Kills all threads and open gui objects created by VISUALIZE"
43
   (flet ((destroy-alive (x)
44
            (when (bt:thread-alive-p x)
45
              (bt:destroy-thread x))))
46
     (mapcar #'destroy-alive *running*)
47
     (setf *running* nil)))
48
 
49
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
50
 ;; Application Frame and drawing
51
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52
 
53
 (define-application-frame display-clim ()
54
   ;; please me refactor this out, Ι hate it
55
   ((%top-task :initform *the-data* :accessor root)
56
    (%original :initform *the-data* :accessor orig)
57
    (%graph-p  :initform t :accessor graph-p)
58
    (%dot-p    :initform t :accessor dot-p)
59
    (counter :initform 0 :initarg :counter :accessor counter))
60
   (:panes
61
    (make-pane :application
62
               :width 600
63
               :height 800
64
               :display-function #'display-app
65
               :display-time t
66
               :default-view (make-instance 'show-view))
67
    (interactor :interactor :height 100 :width 100))
68
   (:layouts
69
    (default (vertically ()
70
               (9/10 make-pane)
71
               (1/10 interactor)))))
72
 
73
 (defun display-app (frame pane)
74
   (cond ((typep (root frame) 'graph:node)
75
          (graph-dot (root frame) pane))
76
         ((graph-p frame)
77
          (display-graph-frame frame pane))
78
         (t
79
          (handler-case (present-object (root frame) pane)
80
            (error (c)
81
              (declare (ignore c))
82
              (format pane "issue displaying, please call swap to get it back into a graph~%")
83
              (display-graph-frame frame pane))))))
84
 
85
 (defun display-graph-frame (frame pane)
86
   (funcall (if (dot-p frame)
87
                #'display-graph-dot
88
                #'display-graph-node)
89
            (root frame) pane))
90
 
91
 (defun display-graph-dot (object pane)
92
   (graph-dot (pass-graph object) pane))
93
 
94
 (defun display-graph-node (object pane)
95
   (graph-node (pass-graph object) pane))
96
 
97
 (defun pass-graph (object)
98
   (graph:passes (graph:graphize object nil)))
99
 �