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)