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

Contents of /mcclim/graph-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5