CLIM mail archive
[Prev][Next][Index][Thread]

updating-output and format-graph-from-root


I'm using CLIM 1.1 under Genera 8.1 and CLIM 1.0 beta under MCL 2.0bp3.

I want to display a hierarchy of objects in form of a tree, where
the user can collapse nodes with children or expand collapsed nodes.

It would be nice if updating-output could be used. However, my first
naive test program showed, that in principle the nodes are "re-layeouted"
correctly during redisplay as can be seen from the bounding rectangles
when the nodes are highlighted. However, the display gets messed up by 
either erasing too much or too less of the output.

A complete redisplay (Function-Refresh on the Symbolics) builds up the
display correctly.

Is there an easy solution for this problem using updating-output? I've
appended short example code after this message.

Thanks - Stefan B.

Mail: Stefan Bernemann        ! Phone:  +49-231-9743-139
      c/o FhG IML Dortmund    ! Fax:    +49-231-9743-234
      Emil-Figge-Str. 75      ! Email:  berni@iml.fhg.de
      D-4600 Dortmund 50, FRG !         

;;; -*- Package: CLIM-USER; Syntax: Common-Lisp; Mode: LISP; Base: 10 -*-

(in-package :clim-user)

;;; Some Tree stuff

(defclass tree-node ()
    ((node-value :accessor tree-node-value :initarg :node-value)
     (node-children :accessor tree-node-children :initarg :node-children
		    :initform nil)
     (expanded :accessor tree-node-expanded :initarg :expanded :initform t)
     (tick-mark :accessor tree-node-tick-mark :initform 0)
     (node-parent :accessor tree-node-parent :initarg :node-parent :initform nil)))

(defun make-tree-from-list (tree-in-list-form &optional (parent nil))
  (if (atom tree-in-list-form)
      (make-instance 'tree-node :node-value tree-in-list-form
		     :node-parent parent)
      (let ((tree (make-instance 'tree-node :node-value (car tree-in-list-form)
				 :node-parent parent)))
	(setf (tree-node-children tree) 
	      (mapcar #'(lambda (child)
			  (make-tree-from-list child tree))
		      (cdr tree-in-list-form)))
	tree)))

;;; The Application Frame

(define-application-frame tree1 ()
  ((tree :initform (make-tree-from-list
		       '(root (node1 (node1-1 leaf1-1-1 leaf1-1-2)
				     (node1-2 leaf1-2-1 leaf1-2-2))
			      (node2 (node2-1 leaf2-1-1 leaf2-1-2)
				     (node2-2 leaf2-2-1 leaf2-2-2))
			      (node3 (node3-1 leaf3-1-1 leaf3-1-2)
				     (node3-1 leaf3-2-1 leaf3-2-2))))
	   :accessor tree1-tree))
  (:panes ((title :title)
	   (menu :command-menu)
	   (display-tree :application
			 :default-text-style '(:fix :bold :normal)
			 :incremental-redisplay T
			 :scroll-bars :both
			 :display-function 'draw-tree-as-tree)
           (doc :pointer-documentation))))



(define-tree1-command (com-exit-tree :menu "Exit")
    ()
  (frame-exit *application-frame*))


(define-presentation-type tree ()
  )

;;; *** THE DISPLAY FUNCTION ***

(defmethod draw-tree-as-tree ((frame tree1) stream)
  (let ((tree (tree1-tree frame))
        (node-printer 
	  #'(lambda (node stream)
	      (let ((text-face (cond ((null (tree-node-children node)) :italic)
                                     ((tree-node-expanded node) :roman)
                                     (t :bold))))
                (updating-output (stream :unique-id node
					 :cache-value (tree-node-tick-mark node)
					 :cache-test #'=)
                  (with-output-as-presentation (:stream stream
						:object node
						:type 'tree)
                    (with-drawing-options (stream :text-face text-face)
                      (format stream "~A" (tree-node-value node)))
		    ))))))
    (format-graph-from-root tree
			      node-printer
			      #'(lambda (node)
				  (and (tree-node-expanded node)
				       (tree-node-children node)))
			      :stream stream 
			      :orientation ':horizontal)))

(define-tree1-command  com-toggle-expand
    ((tree 'tree))
  (setf (tree-node-expanded tree)
        (not (tree-node-expanded tree)))
  ;; Mark all parent nodes as invalid
  (loop for node = tree then (tree-node-parent node)
        while node do
    (incf (tree-node-tick-mark node))))
        
(define-presentation-to-command-translator toggle-expand-status
    (tree com-toggle-expand tree1
	  :pointer-documentation ((object stream)
				  (format stream "~A ~A"
					  (if (tree-node-expanded object)
					      "Collapse" "Expand")
					  (tree-node-value object)))
	  :tester ((object)
		   (tree-node-children object)))
    (object)
  (list object))


#||
t

(defvar *clim-root* (open-root-window #+:mcl :mcl
                                      #+:genera :sheet)
(defvar *my-window*)
(setf *my-window* (make-application-frame 'tree1 :parent *clim-root*))
(run-frame-top-level *my-window*)
||#
Main Index | Thread Index