1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(in-package :clim-user)
;;;; spatial-tree Visualization Toy. Mostly by Andy Hefner; some
;;;; modifications by Christophe Rhodes
;; For best results, use a McCLIM newer than Nov.11, 2004 :)
(define-presentation-type spatial-tree-node ())
(define-presentation-type entry ())
(define-application-frame spatial-tree-viz ()
((tree :initarg :tree :reader tree)
(scale :initarg :scale :initform 200 :accessor scale)
(expanded-nodes :initform (make-hash-table) :reader expanded-nodes))
(:panes (hierarchy-pane (make-pane 'application-pane
:display-time t
:end-of-page-action :allow
:end-of-line-action :allow
:text-style (make-text-style :sans-serif :roman :normal)
:display-function 'print-tree-hierarchy))
(inspect (make-pane 'application-pane :display-time nil
:end-of-page-action :allow
:end-of-line-action :allow))
(viz (make-pane 'application-pane :display-time t
:display-function 'draw-layout))
(zoom-in (make-pane 'push-button :label "Zoom In"
:activate-callback 'zoom-in))
(zoom-out (make-pane 'push-button :label "Zoom Out"
:activate-callback 'zoom-out)))
(:command-table (spatial-tree-viz))
(:pointer-documentation t)
(:layouts
(default
(vertically ()
(horizontally ()
(labelling (:label "Hierarchy")
(scrolling (:scroll-bars :vertical)
hierarchy-pane))
(make-pane 'clim-extensions:box-adjuster-gadget)
(labelling (:label "Layout" :width +fill+)
(vertically ()
(scrolling (:suggested-width 500 :suggested-height 500)
viz)
(horizontally () zoom-in zoom-out))))
(make-pane 'clim-extensions:box-adjuster-gadget)
(labelling (:label "Details")
(scrolling (:suggested-width 600)
inspect))))))
;;; Display Code
(defun print-tree-node (frame pane node &key (indent 0))
(indenting-output (pane indent)
(etypecase node
(spatial-trees-protocol:spatial-tree-node
(with-output-as-presentation (pane node 'spatial-tree-node)
(format pane "~A (~A children)~%" (type-of node) (length (spatial-trees-protocol:children node)))))
(spatial-trees-impl::leaf-node-entry
;; FIXME: this should also be presented as the object in the
;; LEAF-NODE-ENTRY-DATUM slot
(with-output-as-presentation (pane node 'entry)
(multiple-value-call #'format pane
"Rectangle (~1,2F,~1,2F)-(~1,2F,~1,2F)~%"
(rect* (spatial-trees-impl::leaf-node-entry-rectangle node))))))
(when (gethash node (expanded-nodes frame))
(dolist (child (spatial-trees-protocol:children node))
(print-tree-node frame pane child :indent (+ indent 16))))))
(defun print-tree-hierarchy (frame pane)
(print-tree-node frame pane (spatial-trees-protocol:root-node (tree frame))))
(defun rect* (rectangle)
(values
(first (rectangles:lows rectangle)) (second (rectangles:lows rectangle))
(first (rectangles:highs rectangle)) (second (rectangles:highs rectangle))))
(defun draw-layout (frame pane &optional (node (tree frame)))
(etypecase node
(spatial-trees-protocol:spatial-tree
(with-room-for-graphics (pane :first-quadrant nil)
(with-scaling (pane (scale frame))
(draw-layout frame pane (spatial-trees-protocol:root-node node))))
(change-space-requirements pane ;; FIXME: McCLIM should do this itself.
:width (bounding-rectangle-width (stream-output-history pane))
:height (bounding-rectangle-height (stream-output-history pane))))
(spatial-trees-protocol:spatial-tree-leaf-node
(dolist (child (spatial-trees-protocol:records node))
(draw-layout frame pane child))
(when (slot-boundp node 'spatial-trees-impl::mbr)
(multiple-value-call #'draw-rectangle*
pane (rect* (slot-value node 'spatial-trees-impl::mbr))
:ink +red+ :filled nil)))
(spatial-trees-protocol:spatial-tree-node
(dolist (child (spatial-trees-protocol:children node))
(draw-layout frame pane child))
(when (slot-boundp node 'spatial-trees-impl::mbr)
(multiple-value-call #'draw-rectangle*
pane (rect* (slot-value node 'spatial-trees-impl::mbr))
:ink +black+ :filled nil)))
(spatial-trees-impl::leaf-node-entry
(with-output-as-presentation (pane node 'entry)
(multiple-value-call #'draw-rectangle*
pane (rect* (spatial-trees-impl::leaf-node-entry-rectangle node))
:ink +blue+ :filled nil :line-dashes #(1 1))))))
;;; Callbacks
(defun zoom-in (pane)
(declare (ignore pane))
(setf (scale *application-frame*)
(* 2 (scale *application-frame*)))
(redisplay-frame-pane *application-frame* (get-frame-pane *application-frame* 'viz) :force-p t))
(defun zoom-out (pane)
(declare (ignore pane))
(setf (scale *application-frame*)
(/ (scale *application-frame*) 2))
(redisplay-frame-pane *application-frame* (get-frame-pane *application-frame* 'viz) :force-p t))
;;; Commands
(define-spatial-tree-viz-command (com-toggle-node :name "Toggle Expand Node")
((node 'spatial-tree-node :prompt :node :gesture :select))
(if (gethash node (expanded-nodes *application-frame*))
(remhash node (expanded-nodes *application-frame*))
(setf (gethash node (expanded-nodes *application-frame*)) t))
(setf (pane-needs-redisplay (get-frame-pane *application-frame* 'hierarchy-pane)) t))
(define-spatial-tree-viz-command (com-describe-node :name "Describe Node")
((node 'spatial-tree-node :prompt :node :gesture :describe))
(describe node (get-frame-pane *application-frame* 'inspect)))
(define-spatial-tree-viz-command (com-describe-entry :name "Describe Entry")
((node 'entry :prompt :node :gesture :describe))
(describe node (get-frame-pane *application-frame* 'inspect)))
;;; Foo
(defun inspect-spatial-tree (tree)
(run-frame-top-level
(make-application-frame 'spatial-tree-viz
:tree tree :pretty-name "Spatial Tree Visualizer")))
|
