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

Contents of /mcclim/graph-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Sun Mar 4 22:26:22 2007 UTC (7 years, 1 month ago) by ahefner
Branch: MAIN
CVS Tags: McCLIM-0-9-5
Changes since 1.19: +6 -3 lines
Don't replay the rendered graph on the stream if drawing is disabled, or
if we are drawing into a record which does not have the stream output
history as an ancestor.
1 gilbert 1.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 ahefner 1.20 ;;; $Id: graph-formatting.lisp,v 1.20 2007/03/04 22:26:22 ahefner Exp $
7 gilbert 1.1 ;;; ---------------------------------------------------------------------------
8    
9     ;;; (c) copyright 2002 by Gilbert Baumann
10 rgoldman 1.16 ;;; (c) copyright 2005 by Robert P. Goldman
11 gilbert 1.1
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 mikemac 1.7 (in-package :clim-internals)
28 gilbert 1.1
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 thenriksen 1.19 ;; - What is the purpose of (SETF GRAPH-NODE-CHILDREN) and
43     ;; (SETF GRAPH-NODE-PARENTS)? --GB 2002-08-14
44 gilbert 1.3
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 gilbert 1.1
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    
119     (defun format-graph-from-roots (root-objects object-printer inferior-producer
120 gilbert 1.3 &rest graph-options
121 gilbert 1.1 &key stream orientation cutoff-depth
122     merge-duplicates duplicate-key duplicate-test
123     generation-separation
124     within-generation-separation
125 ahefner 1.12 center-nodes
126     (arc-drawer #'clim-internals::standard-arc-drawer)
127     arc-drawing-options
128 gilbert 1.3 graph-type (move-cursor t)
129     &allow-other-keys)
130 gilbert 1.4 (declare (ignore orientation generation-separation within-generation-separation center-nodes))
131 gilbert 1.1 ;; Mungle some arguments
132     (check-type cutoff-depth (or null integer))
133 ahefner 1.14 (check-type root-objects sequence)
134 gilbert 1.1 (setf stream (or stream *standard-output*)
135     graph-type (or graph-type (if merge-duplicates :digraph :tree))
136     duplicate-key (or duplicate-key #'identity)
137 gilbert 1.3 duplicate-test (or duplicate-test #'eql) )
138 rgoldman 1.16
139     ;; I'm not sure what to do here. Saying you want a tree, but want
140     ;; duplicates merged seems wrong. OTOH, if you go out of your way
141     ;; to do it, at your own risk, is it our place to say "no"?
142     ;; [2005/08/11:rpg]
143     ;;; (when (and (eq graph-type :tree) merge-duplicates)
144     ;;; (cerror "Substitute NIL for merge-duplicates"
145     ;;; "Merge duplicates specified to be true when using :tree layout.")
146     ;;; (setf merge-duplicates nil))
147 gilbert 1.3
148     ;; clean the options
149 gilbert 1.4 (remf graph-options :stream)
150     (remf graph-options :duplicate-key)
151     (remf graph-options :duplicate-test)
152     (remf graph-options :arc-drawer)
153     (remf graph-options :arc-drawing-options)
154     (remf graph-options :graph-type)
155     (remf graph-options :move-cursor)
156 gilbert 1.3
157 adejneka 1.2 (multiple-value-bind (cursor-old-x cursor-old-y)
158     (stream-cursor-position stream)
159     (let ((graph-output-record
160 gilbert 1.3 (labels ((cont (stream graph-output-record)
161     (with-output-recording-options (stream :draw nil :record t)
162     (generate-graph-nodes graph-output-record stream root-objects
163     object-printer inferior-producer
164     :duplicate-key duplicate-key
165     :duplicate-test duplicate-test)
166     (layout-graph-nodes graph-output-record stream arc-drawer arc-drawing-options)
167     (layout-graph-edges graph-output-record stream arc-drawer arc-drawing-options)) ))
168     (apply #'invoke-with-new-output-record stream
169     #'cont
170     (find-graph-type graph-type)
171 moore 1.10 nil
172 rgoldman 1.16 ;; moved to local variable... [2005/07/25:rpg]
173     ;; :hash-table (make-hash-table :test duplicate-test)
174     graph-options
175     ))))
176 adejneka 1.2 (setf (output-record-position graph-output-record)
177     (values cursor-old-x cursor-old-y))
178 ahefner 1.20 (when (and (stream-drawing-p stream)
179     (output-record-ancestor-p (stream-output-history stream)
180     graph-output-record))
181     (with-output-recording-options (stream :draw t :record nil)
182     (replay graph-output-record stream)))
183 adejneka 1.2 (when move-cursor
184     (setf (stream-cursor-position stream)
185     (values (bounding-rectangle-max-x graph-output-record)
186     (bounding-rectangle-max-y graph-output-record))))
187     graph-output-record)))
188 mikemac 1.6
189     (defun format-graph-from-root (root &rest rest)
190     (apply #'format-graph-from-roots (list root) rest))
191 gilbert 1.1
192     ;;;; Graph Output Records
193    
194     (defclass standard-graph-output-record (graph-output-record
195     standard-sequence-output-record)
196 rgoldman 1.16 ((orientation
197     :initarg :orientation
198     :initform :horizontal)
199     (center-nodes
200     :initarg :center-nodes
201     :initform nil)
202     (cutoff-depth
203     :initarg :cutoff-depth
204     :initform nil)
205     (merge-duplicates
206     :initarg :merge-duplicates
207     :initform nil)
208     (generation-separation
209     :initarg :generation-separation
210     :initform '(4 :character))
211     (within-generation-separation
212     :initarg :within-generation-separation
213     :initform '(1/2 :line))
214     ;; removed HASH-TABLE slot and stuffed it into
215     ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg]
216     (root-nodes
217     :accessor graph-root-nodes)
218     ))
219 gilbert 1.1
220 adejneka 1.2 (defclass tree-graph-output-record (standard-graph-output-record)
221 rgoldman 1.16 ())
222    
223     ;;;(defmethod initialize-instance :after ((obj tree-graph-output-record) &key merge-duplicates)
224     ;;; (when merge-duplicates
225     ;;; (warn "Cannot use a TREE layout for graphs while merging duplicates.")))
226 gilbert 1.3
227 adejneka 1.2 (defclass dag-graph-output-record (standard-graph-output-record)
228 rgoldman 1.16 (
229     ))
230 gilbert 1.3
231 adejneka 1.2 (defclass digraph-graph-output-record (standard-graph-output-record)
232     ())
233 gilbert 1.1
234     ;;;; Nodes
235    
236     (defclass standard-graph-node-output-record (graph-node-output-record
237     standard-sequence-output-record)
238     ((graph-parents
239     :initarg :graph-parents
240     :initform nil
241     :accessor graph-node-parents)
242     (graph-children
243     :initarg :graph-children
244     :initform nil
245     :accessor graph-node-children)
246 crhodes 1.18 (edges-from :initform (make-hash-table))
247     (edges-to :initform (make-hash-table))
248 gilbert 1.1 (object
249     :initarg :object
250 gilbert 1.4 :reader graph-node-object)
251     ;; internal slots for the graph layout algorithmn
252     (minor-size
253     :initform nil
254     :accessor graph-node-minor-size
255     :documentation "Space requirement for this node and its children. Also used as a mark.") ))
256 gilbert 1.1
257     ;;;;
258    
259 rgoldman 1.16 ;;; Modified to make this obey the spec better by using a hash-table
260     ;;; for detecting previous nodes only when the duplicate-test argument
261     ;;; permits it. [2005/08/10:rpg]
262 gilbert 1.1 (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record)
263     stream root-objects
264     object-printer inferior-producer
265     &key duplicate-key duplicate-test)
266 rgoldman 1.16 (with-slots (cutoff-depth merge-duplicates) graph-output-record
267     (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp)))
268     (make-hash-table :test duplicate-test)))
269     node-list
270     (hashed hash-table))
271     (labels
272     ((previous-node (obj)
273     ;; is there a previous node for obj? if so, return it.
274     (when merge-duplicates
275     (if hashed
276     (locally (declare (type hash-table hash-table))
277     (gethash obj hash-table))
278     (cdr (assoc obj node-list :test duplicate-test)))))
279     ((setf previous-node) (val obj)
280     (if hashed
281     (locally (declare (type hash-table hash-table))
282     (setf (gethash obj hash-table) val))
283     (setf node-list (push (cons obj val) node-list))))
284     (traverse-objects (node objects depth)
285     (unless (and cutoff-depth (>= depth cutoff-depth))
286     (remove nil
287     (map 'list
288     (lambda (child)
289     (let* ((key (funcall duplicate-key child))
290     (child-node (previous-node key)))
291     (cond (child-node
292     (when node
293     (push node (graph-node-parents child-node)))
294     child-node)
295     (t
296     (let ((child-node
297     (with-output-to-output-record
298     (stream 'standard-graph-node-output-record new-node
299     :object child)
300     (funcall object-printer child stream))))
301     (when merge-duplicates
302     (setf (previous-node key) child-node)
303     ;; (setf (gethash key hash-table) child-node)
304     )
305     (when node
306     (push node (graph-node-parents child-node)))
307     (setf (graph-node-children child-node)
308     (traverse-objects child-node
309     (funcall inferior-producer child)
310     (+ depth 1)))
311     child-node)))))
312     objects)))))
313     ;;
314     (setf (graph-root-nodes graph-output-record)
315     (traverse-objects nil root-objects 0))
316     (values)))))
317 gilbert 1.1
318 gilbert 1.4 (defun traverse-graph-nodes (graph continuation)
319 hefner1 1.11 ;; continuation: node x children x cont -> some value
320 gilbert 1.4 (let ((hash (make-hash-table :test #'eq)))
321     (labels ((walk (node)
322     (unless (gethash node hash)
323     (setf (gethash node hash) t)
324     (funcall continuation node (graph-node-children node) #'walk))))
325     (funcall continuation graph (graph-root-nodes graph) #'walk))))
326    
327 gilbert 1.1 (defmethod layout-graph-nodes ((graph-output-record tree-graph-output-record)
328     stream arc-drawer arc-drawing-options)
329 gilbert 1.3 ;; work in progress! --GB 2002-08-14
330     (declare (ignore arc-drawer arc-drawing-options))
331 gilbert 1.1 (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes) graph-output-record
332     (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
333     ;; here major dimension is the dimension in which we grow the
334     ;; tree.
335 gilbert 1.3 (let ((within-generation-separation (parse-space stream within-generation-separation
336     (case orientation
337     (:horizontal :vertical)
338     (:vertical :horizontal))))
339     (generation-separation (parse-space stream generation-separation orientation)))
340 rgoldman 1.16 ;; generation sizes is an adjustable array that tracks the major
341     ;; dimension of each of the generations [2005/07/18:rpg]
342 gilbert 1.4 (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))
343     (labels ((node-major-dimension (node)
344     (if (eq orientation :vertical)
345     (bounding-rectangle-height node)
346     (bounding-rectangle-width node)))
347     (node-minor-dimension (node)
348     (if (eq orientation :vertical)
349     (bounding-rectangle-width node)
350     (bounding-rectangle-height node)))
351 rgoldman 1.16 ;; WALK returns a node minor dimension for the node,
352     ;; AFAICT, allowing space for that node's children
353     ;; along the minor dimension. [2005/07/18:rpg]
354 gilbert 1.4 (walk (node depth)
355     (unless (graph-node-minor-size node)
356     (when (>= depth (length generation-sizes))
357 ahefner 1.15 (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2)) :initial-element 0)))
358 gilbert 1.4 (setf (aref generation-sizes depth)
359     (max (aref generation-sizes depth) (node-major-dimension node)))
360     (setf (graph-node-minor-size node) 0)
361     (max (node-minor-dimension node)
362     (setf (graph-node-minor-size node)
363     (let ((sum 0) (n 0))
364     (map nil (lambda (child)
365     (let ((x (walk child (+ depth 1))))
366     (when x
367     (incf sum x)
368     (incf n))))
369     (graph-node-children node))
370     (+ sum
371     (* (max 0 (- n 1)) within-generation-separation))))))))
372     (map nil #'(lambda (x) (walk x 0)) root-nodes)
373     (let ((hash (make-hash-table :test #'eq)))
374     (labels ((foo (node majors u0 v0)
375     (cond ((gethash node hash)
376     v0)
377 gilbert 1.3 (t
378 gilbert 1.4 (setf (gethash node hash) t)
379     (let ((d (- (node-minor-dimension node)
380     (graph-node-minor-size node))))
381     (let ((v (+ v0 (/ (min 0 d) -2))))
382     (setf (output-record-position node)
383     (if (eq orientation :vertical)
384 ahefner 1.13 (transform-position (medium-transformation stream) v u0)
385     (transform-position (medium-transformation stream) u0 v)))
386 gilbert 1.4 (add-output-record node graph-output-record))
387     ;;
388     (let ((u (+ u0 (car majors)))
389     (v (+ v0 (max 0 (/ d 2))))
390     (firstp t))
391     (map nil (lambda (q)
392     (unless (gethash q hash)
393     (if firstp
394     (setf firstp nil)
395     (incf v within-generation-separation))
396     (setf v (foo q (cdr majors)
397     u v))))
398     (graph-node-children node)))
399     ;;
400     (+ v0 (max (node-minor-dimension node)
401     (graph-node-minor-size node))))))))
402     ;;
403     (let ((majors (mapcar (lambda (x) (+ x generation-separation))
404     (coerce generation-sizes 'list))))
405     (let ((u (+ 0 (car majors)))
406     (v 0))
407     (maplist (lambda (rest)
408     (setf v (foo (car rest) majors u v))
409     (unless (null rest)
410     (incf v within-generation-separation)))
411     (graph-root-nodes graph-output-record)))))))))))
412 rgoldman 1.16
413 crhodes 1.18 ;;;; Edges
414    
415     (defclass standard-edge-output-record (standard-sequence-output-record)
416     ((stream)
417     (arc-drawer)
418     (arc-drawing-options)
419     (from-node :initarg :from-node)
420     (to-node :initarg :to-node)))
421    
422 rgoldman 1.16
423     (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
424     stream arc-drawer arc-drawing-options)
425     "This is a first shot at a DAG layout. First does a TOPO sort that associates
426     each node with a depth, then lays out by depth. Tries to reuse a maximum of the
427     tree graph layout code.
428     PRECONDITION: This code assumes that we have generated only nodes up to the
429     cutoff-depth. GENERATE-GRAPH-NODES seems to obey this precondition."
430     (declare (ignore arc-drawer arc-drawing-options))
431     (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes
432     merge-duplicates) graph-output-record
433     ;; this code is snarly enough, handling merge-duplicates. If
434     ;; you're not merging duplicates, you're out of luck, at least for
435     ;; now... [2005/07/18:rpg]
436     (unless merge-duplicates
437     (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T")
438     (setf merge-duplicates t))
439    
440     (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
441    
442     ;; here major dimension is the dimension in which we grow the
443     ;; tree.
444     (let ((within-generation-separation (parse-space stream within-generation-separation
445     (case orientation
446     (:horizontal :vertical)
447     (:vertical :horizontal))))
448     (generation-separation (parse-space stream generation-separation orientation)))
449     ;; generation sizes is an adjustable array that tracks the major
450     ;; dimension of each of the generations [2005/07/18:rpg]
451     (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))
452     (visited (make-hash-table :test #'eq))
453     (parent-hash (make-hash-table :test #'eq)))
454     (labels ((node-major-dimension (node)
455     (if (eq orientation :vertical)
456     (bounding-rectangle-height node)
457     (bounding-rectangle-width node)))
458     (node-minor-dimension (node)
459     (if (eq orientation :vertical)
460     (bounding-rectangle-width node)
461     (bounding-rectangle-height node)))
462     ;; WALK returns a node minor dimension for the node,
463     ;; AFAICT, allowing space for that node's children
464     ;; along the minor dimension. [2005/07/18:rpg]
465     (walk (node depth &optional parent)
466     (unless (gethash node visited)
467     (setf (gethash node visited) depth)
468     (when parent
469     (setf (gethash node parent-hash) parent))
470     (unless (graph-node-minor-size node)
471     (when (>= depth (length generation-sizes))
472     (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))
473     :initial-element 0)))
474     (setf (aref generation-sizes depth)
475     (max (aref generation-sizes depth) (node-major-dimension node)))
476     (setf (graph-node-minor-size node) 0)
477     (max (node-minor-dimension node)
478     (setf (graph-node-minor-size node)
479     (let ((sum 0) (n 0))
480     (map nil (lambda (child)
481     (let ((x (walk child (+ depth 1) node)))
482     (when x
483     (incf sum x)
484     (incf n))))
485     (graph-node-children node))
486     (+ sum
487     (* (max 0 (- n 1)) within-generation-separation)))))))))
488     (map nil #'(lambda (x) (walk x 0)) root-nodes)
489     (let ((hash (make-hash-table :test #'eq)))
490     (labels ((foo (node majors u0 v0)
491     (cond ((gethash node hash)
492     v0)
493     (t
494     (setf (gethash node hash) t)
495     (let ((d (- (node-minor-dimension node)
496     (graph-node-minor-size node))))
497     (let ((v (+ v0 (/ (min 0 d) -2))))
498     (setf (output-record-position node)
499     (if (eq orientation :vertical)
500     (transform-position (medium-transformation stream) v u0)
501     (transform-position (medium-transformation stream) u0 v)))
502     (add-output-record node graph-output-record))
503     ;;
504     (let ((u (+ u0 (car majors)))
505     (v (+ v0 (max 0 (/ d 2))))
506     (firstp t))
507     (map nil (lambda (q)
508     (unless (gethash q hash)
509     (if firstp
510     (setf firstp nil)
511     (incf v within-generation-separation))
512     (setf v (foo q (cdr majors)
513     u v))))
514     ;; when computing the sizes, to
515     ;; make the tree-style layout
516     ;; work, we have to have each
517     ;; node have a unique
518     ;; parent. [2005/07/18:rpg]
519     (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node))
520     (graph-node-children node))))
521     ;;
522     (+ v0 (max (node-minor-dimension node)
523     (graph-node-minor-size node))))))))
524     ;;
525     (let ((majors (mapcar (lambda (x) (+ x generation-separation))
526     (coerce generation-sizes 'list))))
527     (let ((u (+ 0 (car majors)))
528     (v 0))
529     (maplist (lambda (rest)
530     (setf v (foo (car rest) majors u v))
531     (unless (null rest)
532     (incf v within-generation-separation)))
533     (graph-root-nodes graph-output-record)))))))))))
534    
535    
536 gilbert 1.1
537 mikemac 1.5 #+ignore
538 gilbert 1.4 (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)
539 gilbert 1.1 stream arc-drawer arc-drawing-options)
540     (with-slots (root-nodes orientation) graph-output-record
541     (let ((hash (make-hash-table)))
542     (labels ((walk (node)
543 crhodes 1.18 (unless (gethash node hash)
544 gilbert 1.1 (setf (gethash node hash) t)
545     (dolist (k (graph-node-children node))
546     (with-bounding-rectangle* (x1 y1 x2 y2) node
547     (with-bounding-rectangle* (u1 v1 u2 v2) k
548 gilbert 1.3 (ecase orientation
549     ((:horizontal)
550     (multiple-value-bind (from to) (if (< x1 u1)
551     (values x2 u1)
552     (values x1 u2))
553     (apply arc-drawer stream node k
554     from (/ (+ y1 y2) 2)
555     to (/ (+ v1 v2) 2)
556     arc-drawing-options)))
557     ((:vertical)
558     (multiple-value-bind (from to) (if (< y1 v1)
559     (values y2 v1)
560     (values y1 v2))
561     (apply arc-drawer stream node k
562     (/ (+ x1 x2) 2) from
563     (/ (+ u1 u2) 2) to
564     arc-drawing-options)) ))))
565 gilbert 1.1 (walk k)))))
566     (map nil #'walk root-nodes)))))
567    
568 crhodes 1.18 (defun layout-edges (graph node stream arc-drawer arc-drawing-options)
569     (dolist (k (graph-node-children node))
570     (layout-edge graph node k stream arc-drawer arc-drawing-options)))
571    
572     (defun ensure-edge-record (graph major-node minor-node)
573     (let ((edges-from (slot-value major-node 'edges-from))
574     (edges-to (slot-value minor-node 'edges-to)))
575     (assert (eq (gethash minor-node edges-from)
576     (gethash major-node edges-to)))
577     (or (gethash minor-node edges-from)
578     (let ((record (make-instance 'standard-edge-output-record
579     :from-node major-node :to-node minor-node)))
580     (setf (gethash minor-node edges-from) record
581     (gethash major-node edges-to) record)
582     (add-output-record record graph)
583     record))))
584    
585     (defun layout-edge-1 (graph major-node minor-node)
586     (let ((edge-record (ensure-edge-record graph major-node minor-node)))
587     (with-slots (stream arc-drawer arc-drawing-options) edge-record
588     (with-bounding-rectangle* (x1 y1 x2 y2) major-node
589     (with-bounding-rectangle* (u1 v1 u2 v2) minor-node
590     (clear-output-record edge-record) ;;; FIXME: repaint?
591     (letf (((stream-current-output-record stream) edge-record))
592     (ecase (slot-value graph 'orientation)
593     ((:horizontal)
594     (multiple-value-bind (from to) (if (< x1 u1)
595     (values x2 u1)
596     (values x1 u2))
597     (apply arc-drawer stream major-node minor-node
598     from (/ (+ y1 y2) 2)
599     to (/ (+ v1 v2) 2)
600     arc-drawing-options)))
601     ((:vertical)
602     (multiple-value-bind (from to) (if (< y1 v1)
603     (values y2 v1)
604     (values y1 v2))
605     (apply arc-drawer stream major-node minor-node
606     (/ (+ x1 x2) 2) from
607     (/ (+ u1 u2) 2) to
608     arc-drawing-options))))))))))
609    
610     (defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options)
611     (let ((edge-record (ensure-edge-record graph major-node minor-node)))
612     (setf (slot-value edge-record 'stream) stream
613     (slot-value edge-record 'arc-drawer) arc-drawer
614     (slot-value edge-record 'arc-drawing-options) arc-drawing-options)
615     (layout-edge-1 graph major-node minor-node)))
616    
617 gilbert 1.4 (defmethod layout-graph-edges ((graph standard-graph-output-record)
618     stream arc-drawer arc-drawing-options)
619     (with-slots (orientation) graph
620 ahefner 1.13 ;; We tranformed the position of the nodes when we inserted them into
621     ;; output history, so the bounding rectangles queried below will be
622     ;; transformed. Therefore, disable the transformation now, otherwise
623     ;; the transformation is effectively applied twice to the edges.
624     (with-identity-transformation (stream)
625 gilbert 1.4 (traverse-graph-nodes graph
626     (lambda (node children continuation)
627     (unless (eq node graph)
628 crhodes 1.18 (layout-edges graph node stream arc-drawer arc-drawing-options))
629 ahefner 1.13 (map nil continuation children))))))
630 gilbert 1.4
631     (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record)
632     stream arc-drawer arc-drawing-options)
633     (setf arc-drawer (or arc-drawer #'standard-arc-drawer))
634     (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
635    
636     (defmethod layout-graph-edges :around ((graph-output-record digraph-graph-output-record)
637     stream arc-drawer arc-drawing-options)
638     (setf arc-drawer (or arc-drawer #'arrow-arc-drawer))
639     (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
640    
641     (defmethod layout-graph-edges :around ((graph-output-record dag-graph-output-record)
642     stream arc-drawer arc-drawing-options)
643     (setf arc-drawer (or arc-drawer #'standard-arc-drawer))
644     (call-next-method graph-output-record stream arc-drawer arc-drawing-options))
645    
646 gilbert 1.3 (defun standard-arc-drawer (stream from-node to-node x1 y1 x2 y2
647     &rest drawing-options
648     &key &allow-other-keys)
649     (declare (ignore from-node to-node))
650     (apply #'draw-line* stream x1 y1 x2 y2 drawing-options))
651    
652     (defun arrow-arc-drawer (stream from-node to-node x1 y1 x2 y2
653     &rest drawing-options
654     &key &allow-other-keys)
655     (declare (ignore from-node to-node))
656     (apply #'draw-arrow* stream x1 y1 x2 y2 drawing-options))
657    
658 gilbert 1.1 #||
659 gilbert 1.3
660 gilbert 1.1 ;; Experimental version for rectangular graphs
661 gilbert 1.3
662 gilbert 1.1 (defmethod layout-graph-edges ((graph-output-record tree-graph-output-record)
663     stream arc-drawer arc-drawing-options)
664     (with-slots (root-nodes orientation) graph-output-record
665     (let ((hash (make-hash-table)))
666     (labels ((walk (node &aux (vlast nil) uu)
667     (unless (gethash node hash)
668     (setf (gethash node hash) t)
669     (with-bounding-rectangle* (x1 y1 x2 y2) node
670     (dolist (k (graph-node-children node))
671     (with-bounding-rectangle* (u1 v1 u2 v2) k
672     (case orientation
673     (:horizontal
674     (draw-line* stream (/ (+ x2 u1) 2) (/ (+ v1 v2) 2)
675     (- u1 2) (/ (+ v1 v2) 2))
676     (setf uu u1)
677     (setf vlast (max (or vlast 0) (/ (+ v1 v2) 2))))
678     (:vertical
679     (draw-line* stream (/ (+ x1 x2) 2) y2
680     (/ (+ u1 u2) 2) v1))))
681     (walk k))
682     (when vlast
683     (draw-line* stream (+ x2 2) (/ (+ y1 y2) 2) (/ (+ x2 uu) 2) (/ (+ y1 y2) 2))
684     (draw-line* stream (/ (+ x2 uu) 2) (/ (+ y1 y2) 2)
685     (/ (+ x2 uu) 2) vlast))))))
686     (map nil #'walk root-nodes)))))
687     ||#
688    
689     #||
690 gilbert 1.3
691     ;;; Testing --GB 2002-08-14
692    
693 gilbert 1.1 (define-application-frame graph-test ()
694     ()
695     (:panes
696     (interactor :interactor :width 800 :height 400 :max-width +fill+ :max-height +fill+))
697     (:layouts
698     (default
699     interactor)))
700    
701     (define-graph-test-command foo ()
702     (with-text-style (*query-io* (make-text-style :sans-serif nil 12))
703     (let ((*print-case* :downcase))
704     (format-graph-from-roots
705     (list `(define-graph-test-command test ()
706     (let ((stream *query-io*)
707     (orientation :horizontal))
708     (fresh-line stream)
709     (macrolet ((make-node (&key name children)
710     `(list* ,name ,children)))
711     (flet ((node-name (node)
712     (car node))
713     (node-children (node)
714     (cdr node)))
715     (let* ((2a (make-node :name "2A"))
716     (2b (make-node :name "2B"))
717     (2c (make-node :name "2C"))
718     (1a (make-node :name "1A" :children (list 2a 2b)))
719     (1b (make-node :name "1B" :children (list 2b 2c)))
720     (root (make-node :name "0" :children (list 1a 1b))))
721     (format-graph-from-roots
722     (list root)
723     #'(lambda (node s)
724     (write-string (node-name node) s))
725     #'node-children
726     :orientation orientation
727     :stream stream)))))))
728     #'(lambda (x s) (with-output-as-presentation (s x 'command)
729     (let ((*print-level* 1))
730     (princ (if (consp x) (car x) x) s))))
731     #'(lambda (x) (and (consp x) (cdr x)))
732     :stream *query-io*
733     :orientation :horizontal))))
734    
735     (defun external-symbol-p (sym)
736     ;; *cough* *cough*
737     (< (count #\: (let ((*package* (find-package :keyword)))
738     (prin1-to-string sym)))
739     2))
740    
741     (define-graph-test-command bar ()
742 gilbert 1.3 (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
743 gilbert 1.1 (let ((*print-case* :downcase))
744     (format-graph-from-roots
745     (list (clim-mop:find-class 'climi::basic-output-record))
746     #'(lambda (x s)
747 gilbert 1.4 (progn ;;surrounding-output-with-border (s :shape :oval)
748 gilbert 1.3 (with-text-style (s (make-text-style nil
749     (if (external-symbol-p (class-name x))
750     :bold
751     nil)
752     nil))
753     (prin1 (class-name x) s))))
754 gilbert 1.1 #'(lambda (x)
755     (clim-mop:class-direct-subclasses x))
756 gilbert 1.4 :generation-separation '(4 :line)
757     :within-generation-separation '(2 :character)
758 gilbert 1.1 :stream *query-io*
759 gilbert 1.4 :orientation :vertical))))
760    
761     (define-graph-test-command bar ()
762     (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
763     (format-graph-from-roots
764 mikemac 1.8 (list '(:foo
765     (:bar)
766     (:baaaaaaaaaaaaaaz
767     (:a)
768     (:b))
769     (:q
770     (:x) (:y)))
771 gilbert 1.4 )
772     #'(lambda (x s)
773     (prin1 (first x) s))
774     #'(lambda (x)
775     (cdr x))
776     :generation-separation '(4 :line)
777     :within-generation-separation '(2 :character)
778     :stream *query-io*
779     :orientation :vertical)))
780 gilbert 1.1
781     (define-graph-test-command baz ()
782 gilbert 1.4 (with-text-style (*query-io* (make-text-style :sans-serif nil 10))
783 gilbert 1.1 (let ((*print-case* :downcase))
784     (format-graph-from-roots
785 gilbert 1.4 (list (clim-mop:find-class 'standard-graph-output-record)
786     ;;(clim-mop:find-class 'climi::basic-output-record)
787     ;;(clim-mop:find-class 'climi::graph-output-record)
788    
789 gilbert 1.1 )
790     #'(lambda (x s)
791     (with-text-style (s (make-text-style nil
792     (if (external-symbol-p (class-name x))
793     :bold
794     nil)
795     nil))
796     (prin1 (class-name x) s)))
797     #'(lambda (x)
798 gilbert 1.4 (reverse(clim-mop:class-direct-superclasses x)))
799 gilbert 1.1 ;; :duplicate-key #'(lambda (x) 't)
800     :merge-duplicates t
801     :graph-type :tree
802 gilbert 1.4 :arc-drawer #'arrow-arc-drawer
803 gilbert 1.1 :stream *query-io*
804 gilbert 1.4 :orientation :vertical))))
805 gilbert 1.1
806     (define-graph-test-command test ()
807     (let ((stream *query-io*)
808     (orientation :vertical))
809     (fresh-line stream)
810     (macrolet ((make-node (&key name children)
811     `(list* ,name ,children)))
812     (flet ((node-name (node)
813     (car node))
814     (node-children (node)
815     (cdr node)))
816     (let* ((2a (make-node :name "2A"))
817     (2b (make-node :name "2B"))
818     (2c (make-node :name "2C"))
819     (1a (make-node :name "1A" :children (list 2a 2b)))
820     (1b (make-node :name "1B" :children (list 2b 2c)))
821     (root (make-node :name "0" :children (list 1a 1b))))
822     (format-graph-from-roots
823     (list root)
824     #'(lambda (node s)
825     (write-string (node-name node) s))
826     #'node-children
827 gilbert 1.3 :arc-drawer #'arrow-arc-drawer
828     :arc-drawing-options (list :ink +red+ :line-thickness 1)
829 gilbert 1.1 :orientation orientation
830     :stream stream))))))
831 gilbert 1.3
832     (defun make-circ-list (list)
833     (nconc list list))
834    
835     (define-graph-test-command test2 ()
836     (let ((stream *query-io*)
837     (orientation :vertical))
838     (fresh-line stream)
839     (format-graph-from-roots
840 gilbert 1.4 (list '(defun dcons (x) (cons x x))
841     (make-circ-list (list 1 '(2 . 4) 3)))
842 gilbert 1.3 #'(lambda (node s)
843     (if (consp node)
844     (progn
845     (draw-circle* s 5 5 5 :filled nil))
846     (princ node s)))
847     #'(lambda (x) (if (consp x) (list (car x) (cdr x))))
848     :cutoff-depth nil
849     :graph-type :tree
850     :merge-duplicates t
851     :arc-drawer #'arrow-arc-drawer
852     :arc-drawing-options (list :ink +red+ :line-thickness 1)
853     :orientation orientation
854     :stream stream)))
855 gilbert 1.1 ||#

  ViewVC Help
Powered by ViewVC 1.1.5