/[mcclim]/mcclim/graph-formatting.lisp
ViewVC logotype

Contents of /mcclim/graph-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (show annotations)
Mon Sep 17 19:20:49 2007 UTC (6 years, 7 months ago) by crhodes
Branch: MAIN
CVS Tags: McCLIM-0-9-6
Changes since 1.21: +1 -4 lines
Only one version of format-graph-from-roots, please
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: Graph Formatting
4 ;;; Created: 2002-08-13
5 ;;; License: LGPL (See file COPYING for details).
6 ;;; $Id: graph-formatting.lisp,v 1.22 2007/09/17 19:20:49 crhodes Exp $
7 ;;; ---------------------------------------------------------------------------
8
9 ;;; (c) copyright 2002 by Gilbert Baumann
10 ;;; (c) copyright 2005 by Robert P. Goldman
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 (in-package :clim-internals)
28
29 ;;;; Notes
30
31 ;; - Now what exactly are layout-graph-nodes and layout-graph-edges
32 ;; supposed to do? If LAYOUT-GRAPH-NODES is only responsible for
33 ;; laying out the node output records, why does it get the
34 ;; arc-drawer? If it should also draw the edges why then is there
35 ;; the other function? --GB 2002-08-13
36
37 ;; - There is this hash table initarg to graph-output-records? Should
38 ;; FORMAT-GRAPH-FROM-ROOTS pass a suitable hash table for the given
39 ;; 'duplicate-test', if so why it is passed down and why is it not
40 ;; restricted to the set of hash test functions? --GB 2002-08-13
41
42 ;; - What is the purpose of (SETF GRAPH-NODE-CHILDREN) and
43 ;; (SETF GRAPH-NODE-PARENTS)? --GB 2002-08-14
44
45 ;; - FORMAT-GRAPH-FROM-ROOTS passes the various options on to the
46 ;; instantiation of the graph-output-record class, so that the
47 ;; individual classes can choose appropriate defaults. --GB 2002-08-14
48
49 ;; - In the same spirit, a non given ARC-DRAWER option is passed as it
50 ;; is, that is being NIL, to LAYOUT-GRAPH-EDGES so that the concrete
51 ;; graph-output-record can choose a default. --GB 2002-08-14
52
53 ;;;; Declarations
54
55 ;; format-graph-from-roots
56
57 (defgeneric graph-root-nodes (graph-output-record))
58 (defgeneric (setf graph-root-nodes) (new-value graph-output-record))
59 (defgeneric generate-graph-nodes (graph-output-record stream root-objects
60 object-printer inferior-producer
61 &key duplicate-key duplicate-test))
62 (defgeneric layout-graph-nodes (graph-output-record stream arc-drawer arc-drawing-options))
63 (defgeneric layout-graph-edges (graph-output-record stream arc-drawer arc-drawing-options))
64 ;;; NOTE: Which calls which? --GB 2002-08-13
65
66 (defgeneric graph-node-parents (graph-node-record))
67 (defgeneric (setf graph-node-parents) (new-value graph-node-record))
68 (defgeneric graph-node-children (graph-node-record))
69 (defgeneric (setf graph-node-children) (new-value graph-node-record))
70 (defgeneric graph-node-object (graph-node-record))
71
72 ;;;; Machinery for graph types
73
74 (defconstant +built-in-graph-types+
75 '(:tree :directed-graph :digraph :directed-acyclic-graph :dag)
76 "List of graph types builtin by CLIM.")
77
78 (defvar *graph-types-hash*
79 (make-hash-table :test #'eq)
80 "A hash table which maps from symbols that name graph-types to class names; Filled by CLIM:DEFINE-GRAPH-TYPE")
81
82 (defun register-graph-type (graph-type class)
83 "Registers a new graph-type."
84 (setf (gethash graph-type *graph-types-hash*) class))
85
86 (defun find-graph-type (graph-type)
87 "Find the a graph type; when it does not exist barks at the user."
88 (or (gethash graph-type *graph-types-hash*)
89 (progn
90 (cerror "Specify another graph type to use instead."
91 "There is no such graph type defined: ~S.~%The defined ones are: ~{~S~^, ~@_~}."
92 graph-type
93 (loop for key being each hash-key of *graph-types-hash*
94 collect key))
95 ;; accept anyone?
96 (princ "Graph Type? ")
97 (find-graph-type (read)))))
98
99 (defmacro define-graph-type (graph-type class)
100 (check-type graph-type symbol)
101 (check-type class symbol)
102 (unless (eq *package* (find-package :climi))
103 (when (member graph-type +built-in-graph-types+)
104 (cerror "Do it anyway" "You are about to redefine the builtin graph type ~S."
105 graph-type)))
106 ;; Note: I would really like this to obey to package locks and stuff.
107 `(progn
108 (register-graph-type ',graph-type ',class)
109 ',graph-type))
110
111 (define-graph-type :tree tree-graph-output-record)
112 (define-graph-type :directed-acyclic-graph dag-graph-output-record)
113 (define-graph-type :dag dag-graph-output-record)
114 (define-graph-type :directed-graph digraph-graph-output-record)
115 (define-graph-type :digraph digraph-graph-output-record)
116
117 ;;;; Entry
118 (defun format-graph-from-root (root-object &rest other-args)
119 (apply #'format-graph-from-roots (list root-object) other-args))
120
121 (defun format-graph-from-roots (root-objects object-printer inferior-producer
122 &rest rest-args
123 &key stream orientation cutoff-depth
124 merge-duplicates duplicate-key duplicate-test
125 generation-separation
126 within-generation-separation
127 center-nodes
128 (arc-drawer #'clim-internals::standard-arc-drawer)
129 arc-drawing-options
130 graph-type (move-cursor t)
131 &allow-other-keys)
132 (declare (ignore orientation generation-separation within-generation-separation center-nodes))
133 ;; don't destructively modify the &rest arg
134 (let ((graph-options (copy-list rest-args)))
135 ;; Munge some arguments
136 (check-type cutoff-depth (or null integer))
137 (check-type root-objects sequence)
138 (setf stream (or stream *standard-output*)
139 graph-type (or graph-type (if merge-duplicates :digraph :tree))
140 duplicate-key (or duplicate-key #'identity)
141 duplicate-test (or duplicate-test #'eql) )
142
143 ;; I'm not sure what to do here. Saying you want a tree, but want
144 ;; duplicates merged seems wrong. OTOH, if you go out of your way
145 ;; to do it, at your own risk, is it our place to say "no"?
146 ;; [2005/08/11:rpg]
147 ;;; (when (and (eq graph-type :tree) merge-duplicates)
148 ;;; (cerror "Substitute NIL for merge-duplicates"
149 ;;; "Merge duplicates specified to be true when using :tree layout.")
150 ;;; (setf merge-duplicates nil))
151
152 ;; clean the options
153 (remf graph-options :stream)
154 (remf graph-options :duplicate-key)
155 (remf graph-options :duplicate-test)
156 (remf graph-options :arc-drawer)
157 (remf graph-options :arc-drawing-options)
158 (remf graph-options :graph-type)
159 (remf graph-options :move-cursor)
160
161 (multiple-value-bind (cursor-old-x cursor-old-y)
162 (stream-cursor-position stream)
163 (let ((graph-output-record
164 (labels ((cont (stream graph-output-record)
165 (with-output-recording-options (stream :draw nil :record t)
166 (generate-graph-nodes graph-output-record stream root-objects
167 object-printer inferior-producer
168 :duplicate-key duplicate-key
169 :duplicate-test duplicate-test)
170 (layout-graph-nodes graph-output-record stream arc-drawer arc-drawing-options)
171 (layout-graph-edges graph-output-record stream arc-drawer arc-drawing-options)) ))
172 (apply #'invoke-with-new-output-record stream
173 #'cont
174 (find-graph-type graph-type)
175 nil
176 ;; moved to local variable... [2005/07/25:rpg]
177 ;; :hash-table (make-hash-table :test duplicate-test)
178 graph-options
179 ))))
180 (setf (output-record-position graph-output-record)
181 (values cursor-old-x cursor-old-y))
182 (when (and (stream-drawing-p stream)
183 (output-record-ancestor-p (stream-output-history stream)
184 graph-output-record))
185 (with-output-recording-options (stream :draw t :record nil)
186 (replay graph-output-record stream)))
187 (when move-cursor
188 (setf (stream-cursor-position stream)
189 (values (bounding-rectangle-max-x graph-output-record)
190 (bounding-rectangle-max-y graph-output-record))))
191 graph-output-record))))
192
193 ;;;; Graph Output Records
194
195 (defclass standard-graph-output-record (graph-output-record
196 standard-sequence-output-record)
197 ((orientation
198 :initarg :orientation
199 :initform :horizontal)
200 (center-nodes
201 :initarg :center-nodes
202 :initform nil)
203 (cutoff-depth
204 :initarg :cutoff-depth
205 :initform nil)
206 (merge-duplicates
207 :initarg :merge-duplicates
208 :initform nil)
209 (generation-separation
210 :initarg :generation-separation
211 :initform '(4 :character))
212 (within-generation-separation
213 :initarg :within-generation-separation
214 :initform '(1/2 :line))
215 ;; removed HASH-TABLE slot and stuffed it into
216 ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg]
217 (root-nodes
218 :accessor graph-root-nodes)
219 ))
220
221 (defclass tree-graph-output-record (standard-graph-output-record)
222 ())
223
224 ;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates)
225 ;;; (when merge-duplicates
226 ;;; (warn "Cannot use a TREE layout for graphs while merging duplicates.")))
227
228 (defclass dag-graph-output-record (standard-graph-output-record)
229 (
230 ))
231
232 (defclass digraph-graph-output-record (standard-graph-output-record)
233 ())
234
235 ;;;; Nodes
236
237 (defclass standard-graph-node-output-record (graph-node-output-record
238 standard-sequence-output-record)
239 ((graph-parents
240 :initarg :graph-parents
241 :initform nil
242 :accessor graph-node-parents)
243 (graph-children
244 :initarg :graph-children
245 :initform nil
246 :accessor graph-node-children)
247 (edges-from :initform (make-hash-table))
248 (edges-to :initform (make-hash-table))
249 (object
250 :initarg :object
251 :reader graph-node-object)
252 ;; internal slots for the graph layout algorithm
253 (minor-size
254 :initform nil
255 :accessor graph-node-minor-size
256 :documentation "Space requirement for this node and its children. Also used as a mark.") ))
257
258 ;;;;
259
260 ;;; Modified to make this obey the spec better by using a hash-table
261 ;;; for detecting previous nodes only when the duplicate-test argument
262 ;;; permits it. [2005/08/10:rpg]
263 (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record)
264 stream root-objects
265 object-printer inferior-producer
266 &key duplicate-key duplicate-test)
267 (with-slots (cutoff-depth merge-duplicates) graph-output-record
268 (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp)))
269 (make-hash-table :test duplicate-test)))
270 node-list
271 (hashed hash-table))
272 (labels
273 ((previous-node (obj)
274 ;; is there a previous node for obj? if so, return it.
275 (when merge-duplicates
276 (if hashed
277 (locally (declare (type hash-table hash-table))
278 (gethash obj hash-table))
279 (cdr (assoc obj node-list :test duplicate-test)))))
280 ((setf previous-node) (val obj)
281 (if hashed
282 (locally (declare (type hash-table hash-table))
283 (setf (gethash obj hash-table) val))
284 (setf node-list (push (cons obj val) node-list))))
285 (traverse-objects (node objects depth)
286 (unless (and cutoff-depth (>= depth cutoff-depth))
287 (remove nil
288 (map 'list
289 (lambda (child)
290 (let* ((key (funcall duplicate-key child))
291 (child-node (previous-node key)))
292 (cond (child-node
293 (when node
294 (push node (graph-node-parents child-node)))
295 child-node)
296 (t
297 (let ((child-node
298 (with-output-to-output-record
299 (stream 'standard-graph-node-output-record new-node
300 :object child)
301 (funcall object-printer child stream))))
302 (when merge-duplicates
303 (setf (previous-node key) child-node)
304 ;; (setf (gethash key hash-table) child-node)
305 )
306 (when node
307 (push node (graph-node-parents child-node)))
308 (setf (graph-node-children child-node)
309 (traverse-objects child-node
310 (funcall inferior-producer child)
311 (+ depth 1)))
312 child-node)))))
313 objects)))))
314 ;;
315 (setf (graph-root-nodes graph-output-record)
316 (traverse-objects nil root-objects 0))
317 (values)))))
318
319 (defun traverse-graph-nodes (graph continuation)
320 ;; continuation: node x children x cont -> some value
321 (let ((hash (make-hash-table :test #'eq)))
322 (labels ((walk (node)
323 (unless (gethash node hash)
324 (setf (gethash node hash) t)
325 (funcall continuation node (graph-node-children node) #'walk))))
326 (funcall continuation graph (graph-root-nodes graph) #'walk))))
327
328 (defmethod layout-graph-nodes ((graph-output-record tree-graph-output-record)
329 stream arc-drawer arc-drawing-options)
330 ;; work in progress! --GB 2002-08-14
331 (declare (ignore arc-drawer arc-drawing-options))
332 (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes) graph-output-record
333 (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
334 ;; here major dimension is the dimension in which we grow the
335 ;; tree.
336 (let ((within-generation-separation (parse-space stream within-generation-separation
337 (case orientation
338 (:horizontal :vertical)
339 (:vertical :horizontal))))
340 (generation-separation (parse-space stream generation-separation orientation)))
341 ;; generation sizes is an adjustable array that tracks the major
342 ;; dimension of each of the generations [2005/07/18:rpg]
343 (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))
344 (labels ((node-major-dimension (node)
345 (if (eq orientation :vertical)
346 (bounding-rectangle-height node)
347 (bounding-rectangle-width node)))
348 (node-minor-dimension (node)
349 (if (eq orientation :vertical)
350 (bounding-rectangle-width node)
351 (bounding-rectangle-height node)))
352 ;; WALK returns a node minor dimension for the node,
353 ;; AFAICT, allowing space for that node's children
354 ;; along the minor dimension. [2005/07/18:rpg]
355 (walk (node depth)
356 (unless (graph-node-minor-size node)
357 (when (>= depth (length generation-sizes))
358 (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) :initial-element 0)))
359 (setf (aref generation-sizes depth)
360 (max (aref generation-sizes depth) (node-major-dimension node)))
361 (setf (graph-node-minor-size node) 0)
362 (max (node-minor-dimension node)
363 (setf (graph-node-minor-size node)
364 (let ((sum 0) (n 0))
365 (map nil (lambda (child)
366 (let ((x (walk child (+ depth 1))))
367 (when x
368 (incf sum x)
369 (incf n))))
370 (graph-node-children node))
371 (+ sum
372 (* (max 0 (- n 1)) within-generation-separation))))))))
373 (map nil #'(lambda (x) (walk x 0)) root-nodes)
374 (let ((hash (make-hash-table :test #'eq)))
375 (labels ((foo (node majors u0 v0)
376 (cond ((gethash node hash)
377 v0)
378 (t
379 (setf (gethash node hash) t)
380 (let ((d (- (node-minor-dimension node)
381 (graph-node-minor-size node))))
382 (let ((v (+ v0 (/ (min 0 d) -2))))
383 (setf (output-record-position node)
384 (if (eq orientation :vertical)
385 (transform-position (medium-transformation stream) v u0)
386 (transform-position (medium-transformation stream) u0 v)))
387 (add-output-record node graph-output-record))
388 ;;
389 (let ((u (+ u0 (car majors)))
390 (v (+ v0 (max 0 (/ d 2))))
391 (firstp t))
392 (map nil (lambda (q)
393 (unless (gethash q hash)
394 (if firstp
395 (setf firstp nil)
396 (incf v within-generation-separation))
397 (setf v (foo q (cdr majors)
398 u v))))
399 (graph-node-children node)))
400 ;;
401 (+ v0 (max (node-minor-dimension node)
402 (graph-node-minor-size node))))))))
403 ;;
404 (let ((majors (mapcar (lambda (x) (+ x generation-separation))
405 (coerce generation-sizes 'list))))
406 (let ((u (+ 0 (car majors)))
407 (v 0))
408 (maplist (lambda (rest)
409 (setf v (foo (car rest) majors u v))
410 (unless (null rest)
411 (incf v within-generation-separation)))
412 (graph-root-nodes graph-output-record)))))))))))
413
414 ;;;; Edges
415
416 (defclass standard-edge-output-record (standard-sequence-output-record)
417 ((stream)
418 (arc-drawer)
419 (arc-drawing-options)
420 (from-node :initarg :from-node)
421 (to-node :initarg :to-node)))
422
423
424 (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
425 stream arc-drawer arc-drawing-options)
426 "This is a first shot at a DAG layout. First does a TOPO sort that associates
427 each node with a depth, then lays out by depth. Tries to reuse a maximum of the
428 tree graph layout code.
429 PRECONDITION: This code assumes that we have generated only nodes up to the
430 cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition."
431 (declare (ignore arc-drawer arc-drawing-options))
432 (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes
433 merge-duplicates) graph-output-record
434 ;; this code is snarly enough, handling merge-duplicates. If
435 ;; you're not merging duplicates, you're out of luck, at least for
436 ;; now... [2005/07/18:rpg]
437 (unless merge-duplicates
438 (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T")
439 (setf merge-duplicates t))
440
441 (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
442
443 ;; here major dimension is the dimension in which we grow the
444 ;; tree.
445 (let ((within-generation-separation (parse-space stream within-generation-separation
446 (case orientation
447 (:horizontal :vertical)
448 (:vertical :horizontal))))
449 (generation-separation (parse-space stream generation-separation orientation)))
450 ;; generation sizes is an adjustable array that tracks the major
451 ;; dimension of each of the generations [2005/07/18:rpg]
452 (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))
453 (visited (make-hash-table :test #'eq))
454 (parent-hash (make-hash-table :test #'eq)))
455 (labels ((node-major-dimension (node)
456 (if (eq orientation :vertical)
457 (bounding-rectangle-height node)
458 (bounding-rectangle-width node)))
459 (node-minor-dimension (node)
460 (if (eq orientation :vertical)
461 (bounding-rectangle-width node)
462 (bounding-rectangle-height node)))
463 ;; WALK returns a node minor dimension for the node,
464 ;; AFAICT, allowing space for that node's children
465 ;; along the minor dimension. [2005/07/18:rpg]
466 (walk (node depth &optional parent)
467 (unless (gethash node visited)
468 (setf (gethash node visited) depth)
469 (when parent
470 (setf (gethash node parent-hash) parent))
471 (unless (graph-node-minor-size node)
472 (when (>= depth (length generation-sizes))
473 (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))
474 :initial-element 0)))
475 (setf (aref generation-sizes depth)
476 (max (aref generation-sizes depth) (node-major-dimension node)))
477 (setf (graph-node-minor-size node) 0)
478 (max (node-minor-dimension node)
479 (setf (graph-node-minor-size node)
480 (let ((sum 0) (n 0))
481 (map nil (lambda (child)
482 (let ((x (walk child (+ depth 1) node)))
483 (when x
484 (incf sum x)
485 (incf n))))
486 (graph-node-children node))
487 (+ sum
488 (* (max 0 (- n 1)) within-generation-separation)))))))))
489 (map nil #'(lambda (x) (walk x 0)) root-nodes)
490 (let ((hash (make-hash-table :test #'eq)))
491 (labels ((foo (node majors u0 v0)
492 (cond ((gethash node hash)
493 v0)
494 (t
495 (setf (gethash node hash) t)
496 (let ((d (- (node-minor-dimension node)
497 (graph-node-minor-size node))))
498 (let ((v (+ v0 (/ (min 0 d) -2))))
499 (setf (output-record-position node)
500 (if (eq orientation :vertical)
501 (transform-position (medium-transformation stream) v u0)
502 (transform-position (medium-transformation stream) u0 v)))
503 (add-output-record node graph-output-record))
504 ;;
505 (let ((u (+ u0 (car majors)))
506 (v (+ v0 (max 0 (/ d 2))))
507 (firstp t))
508 (map nil (lambda (q)
509 (unless (gethash q hash)
510 (if firstp
511 (setf firstp nil)
512 (incf v within-generation-separation))
513 (setf v (foo q (cdr majors)
514 u v))))
515 ;; when computing the sizes, to
516 ;; make the tree-style layout
517 ;; work, we have to have each
518 ;; node have a unique
519 ;; parent. [2005/07/18:rpg]
520 (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node))
521 (graph-node-children node))))
522 ;;
523 (+ v0 (max (node-minor-dimension node)
524 (graph-node-minor-size node))))))))
525 ;;
526 (let ((majors (mapcar (lambda (x) (+ x generation-separation))
527 (coerce generation-sizes 'list))))
528 (let ((u (+ 0 (car majors)))
529 (v 0))
530 (maplist (lambda (rest)
531 (setf v (foo (car rest) majors u v))
532 (unless (null rest)
533 (incf v within-generation-separation)))
534 (graph-root-nodes graph-output-record)))))))))))
535
536
537
538 #+ignore
539 (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)
540 stream arc-drawer arc-drawing-options)
541 (with-slots (root-nodes orientation) graph-output-record
542 (let ((hash (make-hash-table)))
543 (labels ((walk (node)
544 (unless (gethash node hash)
545 (setf (gethash node hash) t)
546 (dolist (k (graph-node-children node))
547 (with-bounding-rectangle* (x1 y1 x2 y2) node
548 (with-bounding-rectangle* (u1 v1 u2 v2) k
549 (ecase orientation
550 ((:horizontal)
551 (multiple-value-bind (from to) (if (< x1 u1)
552 (values x2 u1)
553 (values x1 u2))
554 (apply arc-drawer stream node k
555 from (/ (+ y1 y2) 2)
556 to (/ (+ v1 v2) 2)
557 arc-drawing-options)))
558 ((:vertical)
559 (multiple-value-bind (from to) (if (< y1 v1)
560 (values y2 v1)
561 (values y1 v2))
562 (apply arc-drawer stream node k
563 (/ (+ x1 x2) 2) from
564 (/ (+ u1 u2) 2) to
565 arc-drawing-options)) ))))
566 (walk k)))))
567 (map nil #'walk root-nodes)))))
568
569 (defun layout-edges (graph node stream arc-drawer arc-drawing-options)
570 (dolist (k (graph-node-children node))
571 (layout-edge graph node k stream arc-drawer arc-drawing-options)))
572
573 (defun ensure-edge-record (graph major-node minor-node)
574 (let ((edges-from (slot-value major-node 'edges-from))
575 (edges-to (slot-value minor-node 'edges-to)))
576 (assert (eq (gethash minor-node edges-from)
577 (gethash major-node edges-to)))
578 (or (gethash minor-node edges-from)
579 (let ((record (make-instance 'standard-edge-output-record
580 :from-node major-node :to-node minor-node)))
581 (setf (gethash minor-node edges-from) record
582 (gethash major-node edges-to) record)
583 (add-output-record record graph)
584 record))))
585
586 (defun layout-edge-1 (graph major-node minor-node)
587 (let ((edge-record (ensure-edge-record graph major-node minor-node)))
588 (with-slots (stream arc-drawer arc-drawing-options) edge-record
589 (with-bounding-rectangle* (x1 y1 x2 y2) major-node
590 (with-bounding-rectangle* (u1 v1 u2 v2) minor-node
591 (clear-output-record edge-record) ;;; FIXME: repaint?
592 (letf (((stream-current-output-record stream) edge-record))
593 (ecase (slot-value graph 'orientation)
594 ((:horizontal)
595 (multiple-value-bind (from to) (if (< x1 u1)
596 (values x2 u1)
597 (values x1 u2))
598 (apply arc-drawer stream major-node minor-node
599 from (/ (+ y1 y2) 2)
600 to (/ (+ v1 v2) 2)
601 arc-drawing-options)))
602 ((:vertical)
603 (multiple-value-bind (from to) (if (< y1 v1)
604 (values y2 v1)
605 (values y1 v2))
606 (apply arc-drawer stream major-node minor-node
607 (/ (+ x1 x2) 2) from
608 (/ (+ u1 u2) 2) to
609 arc-drawing-options))))))))))
610
611 (defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options)
612 (let ((edge-record (ensure-edge-record graph major-node minor-node)))
613 (setf (slot-value edge-record 'stream) stream
614 (slot-value edge-record 'arc-drawer) arc-drawer
615 (slot-value edge-record 'arc-drawing-options) arc-drawing-options)
616 (layout-edge-1 graph major-node minor-node)))
617
618 (defmethod layout-graph-edges ((graph standard-graph-output-record)
619 stream arc-drawer arc-drawing-options)
620 (with-slots (orientation) graph
621 ;; We tranformed the position of the nodes when we inserted them into
622 ;; output history, so the bounding rectangles queried below will be
623 ;; transformed. Therefore, disable the transformation now, otherwise
624 ;; the transformation is effectively applied twice to the edges.
625 (with-identity-transformation (stream)
626 (traverse-graph-nodes graph
627 (lambda (node children continuation)
628 (unless (eq node graph)
629 (layout-edges graph node stream arc-drawer arc-drawing-options))
630 (map nil continuation children))))))
631
632 (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record)
633 stream arc-drawer arc-drawing-options)
634 (setf arc-drawer (or arc-drawer #'standard-arc-drawer))
635 (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
636
637 (defmethod layout-graph-edges :around ((graph-output-record digraph-graph-output-record)
638 stream arc-drawer arc-drawing-options)
639 (setf arc-drawer (or arc-drawer #'arrow-arc-drawer))
640 (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
641
642 (defmethod layout-graph-edges :around ((graph-output-record dag-graph-output-record)
643 stream arc-drawer arc-drawing-options)
644 (setf arc-drawer (or arc-drawer #'standard-arc-drawer))
645 (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
646
647 (defun standard-arc-drawer (stream from-node to-node x1 y1 x2 y2
648 &rest drawing-options
649 &key &allow-other-keys)
650 (declare (ignore from-node to-node))
651 (apply #'draw-line* stream x1 y1 x2 y2 drawing-options))
652
653 (defun arrow-arc-drawer (stream from-node to-node x1 y1 x2 y2
654 &rest drawing-options
655 &key &allow-other-keys)
656 (declare (ignore from-node to-node))
657 (apply #'draw-arrow* stream x1 y1 x2 y2 drawing-options))
658
659 #||
660
661 ;; Experimental version for rectangular graphs
662
663 (defmethod layout-graph-edges ((graph-output-record tree-graph-output-record)
664 stream arc-drawer arc-drawing-options)
665 (with-slots (root-nodes orientation) graph-output-record
666 (let ((hash (make-hash-table)))
667 (labels ((walk (node &aux (vlast nil) uu)
668 (unless (gethash node hash)
669 (setf (gethash node hash) t)
670 (with-bounding-rectangle* (x1 y1 x2 y2) node
671 (dolist (k (graph-node-children node))
672 (with-bounding-rectangle* (u1 v1 u2 v2) k
673 (case orientation
674 (:horizontal
675 (draw-line* stream (/ (+ x2 u1) 2) (/ (+ v1 v2) 2)
676 (- u1 2) (/ (+ v1 v2) 2))
677 (setf uu u1)
678 (setf vlast (max (or vlast 0) (/ (+ v1 v2) 2))))
679 (:vertical
680 (draw-line* stream (/ (+ x1 x2) 2) y2
681 (/ (+ u1 u2) 2) v1))))
682 (walk k))
683 (when vlast
684 (draw-line* stream (+ x2 2) (/ (+ y1 y2) 2) (/ (+ x2 uu) 2) (/ (+ y1 y2) 2))
685 (draw-line* stream (/ (+ x2 uu) 2) (/ (+ y1 y2) 2)
686 (/ (+ x2 uu) 2) vlast))))))
687 (map nil #'walk root-nodes)))))
688 ||#
689
690 #||
691
692 ;;; Testing --GB 2002-08-14
693
694 (define-application-frame graph-test ()
695 ()
696 (:panes
697 (interactor :interactor :width 800 :height 400 :max-width +fill+ :max-height +fill+))
698 (:layouts
699 (default
700 interactor)))
701
702 (define-graph-test-command foo ()
703 (with-text-style (*query-io* (make-text-style :sans-serif nil 12))
704 (let ((*print-case* :downcase))
705 (format-graph-from-roots
706 (list `(define-graph-test-command test ()
707 (let ((stream *query-io*)
708 (orientation :horizontal))
709 (fresh-line stream)
710 (macrolet ((make-node (&key name children)
711 `(list* ,name ,children)))
712 (flet ((node-name (node)
713 (car node))
714 (node-children (node)
715 (cdr node)))
716 (let* ((2a (make-node :name "2A"))
717 (2b (make-node :name "2B"))
718 (2c (make-node :name "2C"))
719 (1a (make-node :name "1A" :children (list 2a 2b)))
720 (1b (make-node :name "1B" :children (list 2b 2c)))
721 (root (make-node :name "0" :children (list 1a 1b))))
722 (format-graph-from-roots
723 (list root)
724 #'(lambda (node s)
725 (write-string (node-name node) s))
726 #'node-children
727 :orientation orientation
728 :stream stream)))))))
729 #'(lambda (x s) (with-output-as-presentation (s x 'command)
730 (let ((*print-level* 1))
731 (princ (if (consp x) (car x) x) s))))
732 #'(lambda (x) (and (consp x) (cdr x)))
733 :stream *query-io*
734 :orientation :horizontal))))
735
736 (defun external-symbol-p (sym)
737 ;; *cough* *cough*
738 (< (count #\: (let ((*package* (find-package :keyword)))
739 (prin1-to-string sym)))
740 2))
741
742 (define-graph-test-command bar ()
743 (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
744 (let ((*print-case* :downcase))
745 (format-graph-from-roots
746 (list (clim-mop:find-class 'climi::basic-output-record))
747 #'(lambda (x s)
748 (progn ;;surrounding-output-with-border (s :shape :oval)
749 (with-text-style (s (make-text-style nil
750 (if (external-symbol-p (class-name x))
751 :bold
752 nil)
753 nil))
754 (prin1 (class-name x) s))))
755 #'(lambda (x)
756 (clim-mop:class-direct-subclasses x))
757 :generation-separation '(4 :line)
758 :within-generation-separation '(2 :character)
759 :stream *query-io*
760 :orientation :vertical))))
761
762 (define-graph-test-command bar ()
763 (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
764 (format-graph-from-roots
765 (list '(:foo
766 (:bar)
767 (:baaaaaaaaaaaaaaz
768 (:a)
769 (:b))
770 (:q
771 (:x) (:y)))
772 )
773 #'(lambda (x s)
774 (prin1 (first x) s))
775 #'(lambda (x)
776 (cdr x))
777 :generation-separation '(4 :line)
778 :within-generation-separation '(2 :character)
779 :stream *query-io*
780 :orientation :vertical)))
781
782 (define-graph-test-command baz ()
783 (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
784 (let ((*print-case* :downcase))
785 (format-graph-from-roots
786 (list (clim-mop:find-class 'standard-graph-output-record)
787 ;;(clim-mop:find-class 'climi::basic-output-record)
788 ;;(clim-mop:find-class 'climi::graph-output-record)
789
790 )
791 #'(lambda (x s)
792 (with-text-style (s (make-text-style nil
793 (if (external-symbol-p (class-name x))
794 :bold
795 nil)
796 nil))
797 (prin1 (class-name x) s)))
798 #'(lambda (x)
799 (reverse(clim-mop:class-direct-superclasses x)))
800 ;; :duplicate-key #'(lambda (x) 't)
801 :merge-duplicates t
802 :graph-type :tree
803 :arc-drawer #'arrow-arc-drawer
804 :stream *query-io*
805 :orientation :vertical))))
806
807 (define-graph-test-command test ()
808 (let ((stream *query-io*)
809 (orientation :vertical))
810 (fresh-line stream)
811 (macrolet ((make-node (&key name children)
812 `(list* ,name ,children)))
813 (flet ((node-name (node)
814 (car node))
815 (node-children (node)
816 (cdr node)))
817 (let* ((2a (make-node :name "2A"))
818 (2b (make-node :name "2B"))
819 (2c (make-node :name "2C"))
820 (1a (make-node :name "1A" :children (list 2a 2b)))
821 (1b (make-node :name "1B" :children (list 2b 2c)))
822 (root (make-node :name "0" :children (list 1a 1b))))
823 (format-graph-from-roots
824 (list root)
825 #'(lambda (node s)
826 (write-string (node-name node) s))
827 #'node-children
828 :arc-drawer #'arrow-arc-drawer
829 :arc-drawing-options (list :ink +red+ :line-thickness 1)
830 :orientation orientation
831 :stream stream))))))
832
833 (defun make-circ-list (list)
834 (nconc list list))
835
836 (define-graph-test-command test2 ()
837 (let ((stream *query-io*)
838 (orientation :vertical))
839 (fresh-line stream)
840 (format-graph-from-roots
841 (list '(defun dcons (x) (cons x x))
842 (make-circ-list (list 1 '(2 . 4) 3)))
843 #'(lambda (node s)
844 (if (consp node)
845 (progn
846 (draw-circle* s 5 5 5 :filled nil))
847 (princ node s)))
848 #'(lambda (x) (if (consp x) (list (car x) (cdr x))))
849 :cutoff-depth nil
850 :graph-type :tree
851 :merge-duplicates t
852 :arc-drawer #'arrow-arc-drawer
853 :arc-drawing-options (list :ink +red+ :line-thickness 1)
854 :orientation orientation
855 :stream stream)))
856 ||#

  ViewVC Help
Powered by ViewVC 1.1.5