[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
Robert Goldman
rgoldman at common-lisp.net
Fri Aug 12 02:18:04 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv20270
Modified Files:
graph-formatting.lisp
Log Message:
Modified layout-graph-nodes so that it permits duplicate-test arguments
that are not compatible with hash-tables.
Added a (not very good) layout method for DAGS. Arbitrary DIGRAPHs still
not supported.
Date: Fri Aug 12 04:18:03 2005
Author: rgoldman
Index: mcclim/graph-formatting.lisp
diff -u mcclim/graph-formatting.lisp:1.15 mcclim/graph-formatting.lisp:1.16
--- mcclim/graph-formatting.lisp:1.15 Fri May 13 05:00:25 2005
+++ mcclim/graph-formatting.lisp Fri Aug 12 04:18:03 2005
@@ -3,10 +3,11 @@
;;; Title: Graph Formatting
;;; Created: 2002-08-13
;;; License: LGPL (See file COPYING for details).
-;;; $Id: graph-formatting.lisp,v 1.15 2005/05/13 03:00:25 ahefner Exp $
+;;; $Id: graph-formatting.lisp,v 1.16 2005/08/12 02:18:03 rgoldman Exp $
;;; ---------------------------------------------------------------------------
;;; (c) copyright 2002 by Gilbert Baumann
+;;; (c) copyright 2005 by Robert P. Goldman
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
@@ -138,6 +139,15 @@
graph-type (or graph-type (if merge-duplicates :digraph :tree))
duplicate-key (or duplicate-key #'identity)
duplicate-test (or duplicate-test #'eql) )
+
+ ;; I'm not sure what to do here. Saying you want a tree, but want
+ ;; duplicates merged seems wrong. OTOH, if you go out of your way
+ ;; to do it, at your own risk, is it our place to say "no"?
+ ;; [2005/08/11:rpg]
+;;; (when (and (eq graph-type :tree) merge-duplicates)
+;;; (cerror "Substitute NIL for merge-duplicates"
+;;; "Merge duplicates specified to be true when using :tree layout.")
+;;; (setf merge-duplicates nil))
;; clean the options
(remf graph-options :stream)
@@ -163,8 +173,10 @@
#'cont
(find-graph-type graph-type)
nil
- :hash-table (make-hash-table :test duplicate-test)
- graph-options))))
+ ;; moved to local variable... [2005/07/25:rpg]
+ ;; :hash-table (make-hash-table :test duplicate-test)
+ graph-options
+ ))))
(setf (output-record-position graph-output-record)
(values cursor-old-x cursor-old-y))
(with-output-recording-options (stream :draw t :record nil)
@@ -182,35 +194,40 @@
(defclass standard-graph-output-record (graph-output-record
standard-sequence-output-record)
- ((orientation
- :initarg :orientation
- :initform :horizontal)
- (center-nodes
- :initarg :center-nodes
- :initform nil)
- (cutoff-depth
- :initarg :cutoff-depth
- :initform nil)
- (merge-duplicates
- :initarg :merge-duplicates
- :initform nil)
- (generation-separation
- :initarg :generation-separation
- :initform '(4 :character))
- (within-generation-separation
- :initarg :within-generation-separation
- :initform '(1/2 :line))
- (hash-table
- :initarg :hash-table
- :initform nil)
- (root-nodes
- :accessor graph-root-nodes) ))
+ ((orientation
+ :initarg :orientation
+ :initform :horizontal)
+ (center-nodes
+ :initarg :center-nodes
+ :initform nil)
+ (cutoff-depth
+ :initarg :cutoff-depth
+ :initform nil)
+ (merge-duplicates
+ :initarg :merge-duplicates
+ :initform nil)
+ (generation-separation
+ :initarg :generation-separation
+ :initform '(4 :character))
+ (within-generation-separation
+ :initarg :within-generation-separation
+ :initform '(1/2 :line))
+ ;; removed HASH-TABLE slot and stuffed it into
+ ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg]
+ (root-nodes
+ :accessor graph-root-nodes)
+ ))
(defclass tree-graph-output-record (standard-graph-output-record)
- ())
+ ())
+
+;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates)
+;;; (when merge-duplicates
+;;; (warn "Cannot use a TREE layout for graphs while merging duplicates.")))
(defclass dag-graph-output-record (standard-graph-output-record)
- ())
+ (
+ ))
(defclass digraph-graph-output-record (standard-graph-output-record)
())
@@ -238,45 +255,64 @@
;;;;
+;;; Modified to make this obey the spec better by using a hash-table
+;;; for detecting previous nodes only when the duplicate-test argument
+;;; permits it. [2005/08/10:rpg]
(defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record)
stream root-objects
object-printer inferior-producer
&key duplicate-key duplicate-test)
- (declare (ignore duplicate-test))
- (with-slots (cutoff-depth merge-duplicates hash-table) graph-output-record
- (labels
- ((traverse-objects (node objects depth)
- (unless (and cutoff-depth (>= depth cutoff-depth))
- (remove nil
- (map 'list
- (lambda (child)
- (let* ((key (funcall duplicate-key child))
- (child-node (and merge-duplicates
- (gethash key hash-table))))
- (cond (child-node
- (when node
- (push node (graph-node-parents child-node)))
- child-node)
- (t
- (let ((child-node
- (with-output-to-output-record
- (stream 'standard-graph-node-output-record new-node
- :object child)
- (funcall object-printer child stream))))
- (when merge-duplicates
- (setf (gethash key hash-table) child-node))
- (when node
- (push node (graph-node-parents child-node)))
- (setf (graph-node-children child-node)
- (traverse-objects child-node
- (funcall inferior-producer child)
- (+ depth 1)))
- child-node)))))
- objects)))))
- ;;
- (setf (graph-root-nodes graph-output-record)
- (traverse-objects nil root-objects 0))
- (values))))
+ (with-slots (cutoff-depth merge-duplicates) graph-output-record
+ (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp)))
+ (make-hash-table :test duplicate-test)))
+ node-list
+ (hashed hash-table))
+ (labels
+ ((previous-node (obj)
+ ;; is there a previous node for obj? if so, return it.
+ (when merge-duplicates
+ (if hashed
+ (locally (declare (type hash-table hash-table))
+ (gethash obj hash-table))
+ (cdr (assoc obj node-list :test duplicate-test)))))
+ ((setf previous-node) (val obj)
+ (if hashed
+ (locally (declare (type hash-table hash-table))
+ (setf (gethash obj hash-table) val))
+ (setf node-list (push (cons obj val) node-list))))
+ (traverse-objects (node objects depth)
+ (unless (and cutoff-depth (>= depth cutoff-depth))
+ (remove nil
+ (map 'list
+ (lambda (child)
+ (let* ((key (funcall duplicate-key child))
+ (child-node (previous-node key)))
+ (cond (child-node
+ (when node
+ (push node (graph-node-parents child-node)))
+ child-node)
+ (t
+ (let ((child-node
+ (with-output-to-output-record
+ (stream 'standard-graph-node-output-record new-node
+ :object child)
+ (funcall object-printer child stream))))
+ (when merge-duplicates
+ (setf (previous-node key) child-node)
+ ;; (setf (gethash key hash-table) child-node)
+ )
+ (when node
+ (push node (graph-node-parents child-node)))
+ (setf (graph-node-children child-node)
+ (traverse-objects child-node
+ (funcall inferior-producer child)
+ (+ depth 1)))
+ child-node)))))
+ objects)))))
+ ;;
+ (setf (graph-root-nodes graph-output-record)
+ (traverse-objects nil root-objects 0))
+ (values)))))
(defun traverse-graph-nodes (graph continuation)
;; continuation: node x children x cont -> some value
@@ -300,6 +336,8 @@
(:horizontal :vertical)
(:vertical :horizontal))))
(generation-separation (parse-space stream generation-separation orientation)))
+ ;; generation sizes is an adjustable array that tracks the major
+ ;; dimension of each of the generations [2005/07/18:rpg]
(let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))
(labels ((node-major-dimension (node)
(if (eq orientation :vertical)
@@ -309,6 +347,9 @@
(if (eq orientation :vertical)
(bounding-rectangle-width node)
(bounding-rectangle-height node)))
+ ;; WALK returns a node minor dimension for the node,
+ ;; AFAICT, allowing space for that node's children
+ ;; along the minor dimension. [2005/07/18:rpg]
(walk (node depth)
(unless (graph-node-minor-size node)
(when (>= depth (length generation-sizes))
@@ -367,6 +408,121 @@
(unless (null rest)
(incf v within-generation-separation)))
(graph-root-nodes graph-output-record)))))))))))
+
+
+(defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
+ stream arc-drawer arc-drawing-options)
+ "This is a first shot at a DAG layout. First does a TOPO sort that associates
+each node with a depth, then lays out by depth. Tries to reuse a maximum of the
+tree graph layout code.
+PRECONDITION: This code assumes that we have generated only nodes up to the
+cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition."
+ (declare (ignore arc-drawer arc-drawing-options))
+ (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes
+ merge-duplicates) graph-output-record
+ ;; this code is snarly enough, handling merge-duplicates. If
+ ;; you're not merging duplicates, you're out of luck, at least for
+ ;; now... [2005/07/18:rpg]
+ (unless merge-duplicates
+ (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T")
+ (setf merge-duplicates t))
+
+ (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
+
+ ;; here major dimension is the dimension in which we grow the
+ ;; tree.
+ (let ((within-generation-separation (parse-space stream within-generation-separation
+ (case orientation
+ (:horizontal :vertical)
+ (:vertical :horizontal))))
+ (generation-separation (parse-space stream generation-separation orientation)))
+ ;; generation sizes is an adjustable array that tracks the major
+ ;; dimension of each of the generations [2005/07/18:rpg]
+ (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))
+ (visited (make-hash-table :test #'eq))
+ (parent-hash (make-hash-table :test #'eq)))
+ (labels ((node-major-dimension (node)
+ (if (eq orientation :vertical)
+ (bounding-rectangle-height node)
+ (bounding-rectangle-width node)))
+ (node-minor-dimension (node)
+ (if (eq orientation :vertical)
+ (bounding-rectangle-width node)
+ (bounding-rectangle-height node)))
+ ;; WALK returns a node minor dimension for the node,
+ ;; AFAICT, allowing space for that node's children
+ ;; along the minor dimension. [2005/07/18:rpg]
+ (walk (node depth &optional parent)
+ (unless (gethash node visited)
+ (setf (gethash node visited) depth)
+ (when parent
+ (setf (gethash node parent-hash) parent))
+ (unless (graph-node-minor-size node)
+ (when (>= depth (length generation-sizes))
+ (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))
+ :initial-element 0)))
+ (setf (aref generation-sizes depth)
+ (max (aref generation-sizes depth) (node-major-dimension node)))
+ (setf (graph-node-minor-size node) 0)
+ (max (node-minor-dimension node)
+ (setf (graph-node-minor-size node)
+ (let ((sum 0) (n 0))
+ (map nil (lambda (child)
+ (let ((x (walk child (+ depth 1) node)))
+ (when x
+ (incf sum x)
+ (incf n))))
+ (graph-node-children node))
+ (+ sum
+ (* (max 0 (- n 1)) within-generation-separation)))))))))
+ (map nil #'(lambda (x) (walk x 0)) root-nodes)
+ (let ((hash (make-hash-table :test #'eq)))
+ (labels ((foo (node majors u0 v0)
+ (cond ((gethash node hash)
+ v0)
+ (t
+ (setf (gethash node hash) t)
+ (let ((d (- (node-minor-dimension node)
+ (graph-node-minor-size node))))
+ (let ((v (+ v0 (/ (min 0 d) -2))))
+ (setf (output-record-position node)
+ (if (eq orientation :vertical)
+ (transform-position (medium-transformation stream) v u0)
+ (transform-position (medium-transformation stream) u0 v)))
+ (add-output-record node graph-output-record))
+ ;;
+ (let ((u (+ u0 (car majors)))
+ (v (+ v0 (max 0 (/ d 2))))
+ (firstp t))
+ (map nil (lambda (q)
+ (unless (gethash q hash)
+ (if firstp
+ (setf firstp nil)
+ (incf v within-generation-separation))
+ (setf v (foo q (cdr majors)
+ u v))))
+ ;; when computing the sizes, to
+ ;; make the tree-style layout
+ ;; work, we have to have each
+ ;; node have a unique
+ ;; parent. [2005/07/18:rpg]
+ (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node))
+ (graph-node-children node))))
+ ;;
+ (+ v0 (max (node-minor-dimension node)
+ (graph-node-minor-size node))))))))
+ ;;
+ (let ((majors (mapcar (lambda (x) (+ x generation-separation))
+ (coerce generation-sizes 'list))))
+ (let ((u (+ 0 (car majors)))
+ (v 0))
+ (maplist (lambda (rest)
+ (setf v (foo (car rest) majors u v))
+ (unless (null rest)
+ (incf v within-generation-separation)))
+ (graph-root-nodes graph-output-record)))))))))))
+
+
#+ignore
(defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)
More information about the Mcclim-cvs
mailing list