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

Dragging nodes of a formatting graph

   Date: Wed, 4 Nov 92 15:15:20 PST
   From: Brian Anderson <bha@atc.boeing.com>

   I want to use clim:formatting-graph-from-root to layout an *initial*
   version of a graph.  Then, I want the user to be able to drag graph
   nodes to a desired position, and redraw the node and connecting
   links at the new position.  I also want to be able to capture the
   position of each graph node so that I can write an external
   representation of the graph and redraw it at a later time (possibly in
   another Lisp session).

   Has anyone done anything like this beast?  Does anyone have any
   suggestions on how to approach this?  Is this going to be mega-hard?

(in-package :clim)

(defun move-graph-node (stream node new-x new-y)
  (let* ((graph (output-record-parent node))
	 (orientation (slot-value graph 'orientation)))
    (draw-related-edges stream node +background+ orientation)
    (with-bounding-rectangle* (left top right bottom) node
      (with-output-recording-options (stream :record-p nil)
	(draw-rectangle* stream left top right bottom :ink +background+)))
    (output-record-set-position* node new-x new-y)
    (replay node stream)
    (draw-related-edges stream node +foreground+ orientation)))

(defun draw-related-edges (stream node ink orientation)
  (labels ((parent-attachment-position (node)
	     (with-bounding-rectangle* (left top right bottom) node
	       (case orientation
		 ((:horizontal :right)
		  (values (1+ right) (the fixnum (+ top (floor (- bottom top) 2)))))
		 ((:vertical :down)
		  (values (the fixnum (+ left (floor (- right left) 2))) (1+ bottom))))))
	   (child-attachment-position (node)
	     (with-bounding-rectangle* (left top right bottom) node
	       (case orientation
		 ((:horizontal :right)
		  (values (1- left) (the fixnum (+ top (floor (- bottom top) 2)))))
		 ((:vertical :down)
		  (values (the fixnum (+ left (floor (- right left) 2))) (1- top))))))
	   (draw-edge (parent child)
	     (multiple-value-bind (parent-x parent-y)
		 (parent-attachment-position parent)
	       (multiple-value-bind (child-x child-y)
		   (child-attachment-position child)
		 (draw-line* stream parent-x parent-y child-x child-y
			     :ink ink)))))
    (declare (dynamic-extent #'parent-attachment-position
			     #'child-attachment-position))
    ;; Assuming a tree for simplicity
    (let ((parent (first (graph-node-parents node)))
	  (children (graph-node-children node)))
      (when parent
	(draw-edge parent node))
      (dolist (child children)
	(draw-edge node child)))))

0,,
References:
Main Index | Thread Index