Teste
RPG Mago: Cap. 08 - Miragem
RPG Mago: Cap. 08 - Miragem: "(...) e não cometeis suicídio, porque Deus é Misericordioso para convosco. (Corão 4:29) Um homem, mesmo na mais escura das prisões, é livr..."
(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 x1 y1))))
(defun tree-calc-delta (record movers)
(+ *tree-vertical-spacing*
(bounding-rectangle-max-y record)
(- (bounding-rectangle-min-y (car (last movers))))))
(defun tree-update-space-requirements (tree)
(let ((history (stream-output-history tree)))
(change-space-requirements tree
:min-width (bounding-rectangle-width history)
:min-height (bounding-rectangle-height history)))
(let ((a (sheet-region tree))
(b (pane-viewport-region tree)))
(unless (region-contains-region-p a b)
(let ((ix (region-intersection a b)))
(multiple-value-bind (x y)
(cond ((eq ix +nowhere+)
(values 0 0))
((regionp ix)
(values
(min (bounding-rectangle-min-x b)
(- (bounding-rectangle-max-x a)
(bounding-rectangle-width b)))
(min (bounding-rectangle-min-y b)
(- (bounding-rectangle-max-y a)
(bounding-rectangle-height b)))))
(T (error "I am confused.")))
(scroll-extent tree x y))))))
(defun tree-expand-node (tree node)
(let ((movers (tree-find-moving-records node (bounding-rectangle-max-y node))))
(tree-add-items node (funcall (inferior-generator tree) (object node)))
(tree-switch-gizmo tree node t)
(when (and movers (not (null-bounding-rectangle-p (child-area node))))
(tree-move-records tree movers
(bounding-rectangle-min-y (child-area node))
(tree-calc-delta (child-area node) movers))))
(tree-update-space-requirements tree))
(defun tree-contract-node (tree node)
(let ((region (bounding-rectangle (child-area node)))
(movers (tree-find-moving-records node (bounding-rectangle-max-y node))))
(delete-output-record (child-area node) node)
(tree-recompute-extent node)
(setf (slot-value node 'child-area) nil)
(repaint-sheet tree region)
(when movers
(tree-move-records tree movers
(nth-value 1 (tree-node-child-destination node))
(tree-calc-delta node movers))))
(tree-switch-gizmo tree node nil)
(tree-update-space-requirements tree))
(defun tree-gizmo-clicked (tree node)
(if (child-area node)
(tree-contract-node tree node)
(tree-expand-node tree node)))
(defmethod handle-event ((gadget tree-gadget)
(event pointer-button-press-event))
(let ((x (pointer-event-x event))
(y (pointer-event-y event)))
(labels ((func (record)
(map-over-output-records-containing-position
(lambda (child)
(typecase child
(tree-gizmo
(progn (tree-gizmo-clicked gadget (output-record-parent child))
(return-from handle-event)))
((or tree-area tree-node) (func child))))
record x y)))
(func (stream-output-history gadget)))))
URl Embed
[url=https://spreadsheets.google.com/ccc?key=0AtetewiZXVlAdHRaRy0xWjQ4dEM4RWtfOEJDMDE0VkE&hl=en]Article[/url]