/usr/share/common-lisp/source/spatial-trees/spatial-tree-viz.lisp is in cl-spatial-trees 0.2-6.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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")))
|