Autor: Hugo Marcelo Barbosa | Publicado: 2010-02-08T14:02:00-08:00

(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)))))