(in-package :clim-internals)(defun presentc (object &optional stream) (present object (presentation-type-of object) :stream stream))(defclass tree-implicit-node () ((child-area :initform nil :reader child-area)))(defclass tree-gadget (tree-implicit-node application-pane standard-gadget) ((printer :initform #'presentc :accessor printer) (inferior-generator :initarg :inferior-generator :accessor inferior-generator) (expander-tester :initarg :expander-tester :accessor expander-tester)) (:default-initargs :display-time nil :text-style (make-text-style :sans-serif nil nil) :end-of-page-action :allow :end-of-line-action :allow) (:documentation "A tree gadget."))(defclass tree-area (standard-tree-output-record) ((area-owner :initform nil :reader owner)))(defclass tree-node (tree-implicit-node standard-sequence-output-record) ((object :initform nil :initarg :object :accessor object) (gizmo :initform nil :initarg :gizmo :accessor gizmo) (tree :initform nil :initarg :tree :accessor tree) (node-parent :initform nil :initarg :node-parent :accessor node-parent)))(defclass tree-gizmo (standard-sequence-output-record) ((node :initform nil :accessor node)))(defgeneric expandable (node))(defgeneric tree-add-item (node item))(defgeneric tree-add-items (node items))(defgeneric tree-node-child-destination (node))(defgeneric tree-node-history (node))(defmethod tree ((node tree-gadget)) node) (defmethod expandable ((node tree-gadget)) nil)(defparameter *tree-gizmo-spacing* 18)(defparameter *tree-vertical-spacing* 1)(defmethod compose-space ((gadget tree-gadget) &key width height) (declare (ignore gadget)) (make-space-requirement :width (or width 160) :height (or height 160)))(defmethod tree-node-child-destination ((node tree-gadget)) (if (child-area node) (values 0 (+ *tree-vertical-spacing* (bounding-rectangle-max-y (child-area node)))) (values 0 0)))(defmethod tree-node-child-destination ((node tree-node)) (with-bounding-rectangle* (x0 y0 x1 y1) node (declare (ignore y0 x1)) (values (+ x0 *tree-gizmo-spacing*) (+ y1 *tree-vertical-spacing*))))(defmethod tree-node-history ((node tree-node)) node)(defmethod tree-node-history ((node tree-gadget)) (stream-output-history node))(defun ensure-node-area (node) (with-slots (child-area) node (when (null child-area) (setf child-area (make-instance 'tree-area)) (setf (slot-value child-area 'area-owner) node) (add-output-record child-area (tree-node-history node)) )))(defun generate-gizmo (stream opened) (let ((fill-ink (make-rgb-color 0.96 0.96 0.96)) (outline-ink (make-rgb-color 0.3 0.3 0.3)) (inner-ink (make-rgb-color 0.2 0.2 0.2))) (with-output-to-output-record (stream 'tree-gizmo) (draw-rectangle* stream 0 0 8 8 :filled t :ink fill-ink) (draw-rectangle* stream 0 0 8 8 :filled nil :ink outline-ink) (draw-line* stream 2 4 6 4 :ink inner-ink) (when (null opened) (draw-line* stream 4 2 4 6 :ink inner-ink)))))(defun construct-node (stream parent object printer x y) (with-output-recording-options (stream :record t :draw nil) (let* ((node (make-instance 'tree-node :object object :tree stream :node-parent parent :gizmo (when (funcall (expander-tester stream) object) (generate-gizmo stream nil)))) (content (with-output-to-output-record (stream) (funcall printer object stream))) (gizmo (gizmo node))) (when gizmo (setf (node gizmo) node (output-record-position gizmo) (values (+ x (/ (- *tree-gizmo-spacing* (bounding-rectangle-width gizmo)) 2)) (max 0 (+ -1 (floor y) (floor (/ (- (bounding-rectangle-height content) (bounding-rectangle-height gizmo)) 2)))))) (add-output-record gizmo node)) (setf (output-record-position content) (values (floor (+ x *tree-gizmo-spacing*)) (floor y))) (add-output-record content node))))(defmethod tree-add-item ((node tree-implicit-node) item) (tree-add-items node (list item)))(defun tree-add-items (node items) (ensure-node-area node) (let* ((tree (tree node)) (area (child-area node))) (dolist (item items) (let ((child (multiple-value-bind (x y) (tree-node-child-destination node) (construct-node tree node item (printer (tree node)) x y)))) (add-output-record child area) (replay child tree)))))(defun tree-switch-gizmo (tree node opened) (let ((new-gizmo (generate-gizmo tree opened))) (delete-output-record (gizmo node) node) (setf (output-record-position new-gizmo) (values (bounding-rectangle-min-x (gizmo node)) (bounding-rectangle-min-y (gizmo node)))) (setf (gizmo node) new-gizmo) (add-output-record new-gizmo node) (replay new-gizmo tree)))(defun tree-find-moving-records (node y) (let (moving-records) (labels ((func (record) (with-bounding-rectangle* (x0 y0 x1 y1) record (declare (ignore x0 x1)) (cond ((>= y0 y) (push record moving-records)) ((> y1 y) (map-over-output-records #'func record)) (T nil))))) (func (stream-output-history (tree node)))) moving-records))(defun tree-move-records (stream records upper-y delta-y) (declare (optimize (debug 3))) (dolist (record records) (setf (output-record-position record) (values (bounding-rectangle-min-x record) (+ (bounding-rectangle-min-y record) delta-y)))) (with-bounding-rectangle* (x0 y0 x1 y1) (or (pane-viewport-region stream) (sheet-region stream)) (repaint-sheet stream (make-rectangle* x0 upper-y