Update of /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges In directory clnet:/tmp/cvs-serv24198

Added Files: mcclim-tree-with-cross-edges.asd tree-with-cross-edges.lisp Log Message: First draft version of an experimental extension to the graph-formatting protocol.

--- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 1.1 ;;;; -*- Lisp -*-

;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; A system that adds a new type of graph to the ;;; format-graph-from-roots protocol for McCLIM. ;;; ;;; ;;;---------------------------------------------------------------------------

(defpackage :mcclim-tree-with-cross-edges-system (:use :cl :asdf)) (in-package :mcclim-tree-with-cross-edges-system)

(defsystem :mcclim-tree-with-cross-edges :depends-on (:mcclim) :serial t :components ((:file "tree-with-cross-edges")))

--- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-

;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; File for definitions of a new graph type that should allow tree ;;; style layouts with edges across in a level. [2005/05/05:rpg] ;;; ;;; History/Bugs/Notes: ;;; ;;; [2005/05/05:rpg] Created. ;;; ;;;---------------------------------------------------------------------------

(in-package "CLIM-INTERNALS")

;;;--------------------------------------------------------------------------- ;;; A graph with cross trees will have an additional type option: a ;;; cross-edge-producer ;;;---------------------------------------------------------------------------

(eval-when (:compile-toplevel :load-toplevel :execute) (define-graph-type :tree-with-cross-edges cross-tree-output-record))

(defun standard-cross-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key edge-type &allow-other-keys) "The standard cross-arc-drawer simply ignores the edge-type keyword argument." (declare (ignore edge-type)) (remf drawing-options :edge-type) (apply #'standard-arc-drawer stream from-node to-node x1 y1 x2 y2 drawing-options))

(defclass cross-tree-output-record (tree-graph-output-record) ((cross-arc-drawer :initarg :cross-arc-drawer :reader cross-arc-drawer :documentation "This slot should be bound to a function that takes all the arguments accepted by a normal arc-drawer, but also an edge-type keyword argument, which it is free to ignore." :initform #'standard-cross-arc-drawer ) (cross-arc-producer :initarg :cross-arc-producer ;; by default, this just acts like a tree... :initform nil :reader cross-arc-producer :documentation "This should be bound to a function that takes a graph-node as argument, like inferior-producer, but that returns two values: a list of destination nodes and (optionally) a list of type-designators, that can be passed to the cross-arc-drawer, as the value of the :edge-type keyword argument." ) (cross-arc-drawing-options :reader cross-arc-drawing-options ) ) )

;;;--------------------------------------------------------------------------- ;;; This is very yucky. It will be expensive on large graphs (perhaps ;;; a mixin for using a hash-table would be better), and needs some ;;; kind of good way of specifying the test in your graph class, which ;;; will be difficult... [2005/05/06:rpg] ;;;---------------------------------------------------------------------------

(defmethod lookup-node (source-node (graph graph-output-record) &key (test #'eql) (default :error)) (let ((hash-table (make-hash-table :test #'eq))) (flet ((visitedp (node) (gethash node hash-table nil)) (mark (node) (setf (gethash node hash-table) t))) (or (loop with openlist = (graph-root-nodes graph) for node = (pop openlist) while node unless (visitedp node) when (funcall test source-node (graph-node-object node)) return node end and do (mark node) (setf openlist (append openlist (graph-node-children node)))) (when (eq default :error) (error "Unable to find graph node for ~S in ~S" source-node graph)) default)))) (defmethod initialize-instance :after ((obj cross-tree-output-record) &key cross-arc-drawing-options arc-drawing-options) "A possibly reasonable default is to draw cross-arcs as if they were normal tree edge arcs." (unless cross-arc-drawing-options (setf (slot-value obj 'cross-arc-drawing-options) arc-drawing-options)))

;;; note that this could later be made into a function argument, so ;;; that programmers could customize [2005/05/06:rpg] (defgeneric cross-arc-routing (from to orientation) (:documentation "Return four values, x1, y1, x2, y2 for the arc-drawing for a cross-arc. More complex than for the tree case."))

(defun middle (dim1 dim2) (/ (+ dim1 dim2) 2))

(defmethod cross-arc-routing (from to (orientation (eql :horizontal))) (with-bounding-rectangle* (x1 y1 x2 y2) from (with-bounding-rectangle* (u1 v1 u2 v2) to (cond ((< x2 u1) ;; node entirely to the left of k (values x2 (middle y1 y2) u1 (middle v1 v2))) ((< u2 x1) ;; node entirely to the right of k ;; draw from the top or bottom to make distinguishable... (if (<= v1 y1) ;; draw from the top to the x middle of TO on the ;; bottom (values x1 y1 (middle u1 u2) v2) ;; draw from the bottom to the x middle of TO on the ;; top... (values x1 y2 (middle u1 u2) v1))) ;; overlapping in X -- as long as this is a tree, means ;; they are siblings. ((< y2 v1) ;; FROM above: middle x of FROM to middle x of TO, bottom to top... (values (middle x1 x2) y2 (middle u1 u2) v1)) ((< v2 y1) ;; TO above: middle x of FROM to middle x of TO, top to bottom... (values (middle x1 x2) y1 (middle u1 u2) v2)) (t (error "Unforeseen node positioning."))))))

;;; copied from original layout-graph-edges and enhanced to add cross ;;; edges. (defmethod layout-graph-edges :after ((graph cross-tree-output-record) stream arc-drawer arc-drawing-options) "After the main method has drawn the tree, add the cross-edges." (declare (ignore arc-drawer arc-drawing-options)) ;;; (format excl:*initial-terminal-io* "~&Invoking after method to layout cross-edges.~%") ;;; (unless (cross-arc-producer graph) ;;; (format excl:*initial-terminal-io* "~&Uh-oh! No cross-arc-producer!~%")) (with-slots (orientation) graph ;; We tranformed the position of the nodes when we inserted them into ;; output history, so the bounding rectangles queried below will be ;; transformed. Therefore, disable the transformation now, otherwise ;; the transformation is effectively applied twice to the edges. (when (cross-arc-producer graph) (with-identity-transformation (stream) ;; for some damn reason, this graph traversal isn't working.... (traverse-graph-nodes graph (lambda (node children continuation) ;;; (format excl:*initial-terminal-io* ;;; "~&Invoking traverse function on ~S and ~S!~%" node children) (unless (eq node graph) (multiple-value-bind (source-siblings types) (funcall (cross-arc-producer graph) (graph-node-object node)) ;; there's a kind of odd loop here ;; because types might be NIL. Using ;; a built-in stepper would cause the ;; loop to terminate too soon if types ;; was nil [2005/05/06:rpg] (loop for ss in source-siblings for k = (lookup-node ss graph) for typelist = types then (cdr typelist) for type = (when typelist (car typelist)) do (multiple-value-bind (fromx fromy tox toy) (cross-arc-routing node k orientation) (apply (cross-arc-drawer graph) stream node k fromx fromy tox toy :edge-type type (cross-arc-drawing-options graph)))))) (map nil continuation children)))))))