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

Diff of /mcclim/graph-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15 by ahefner, Fri May 13 03:00:25 2005 UTC revision 1.16 by rgoldman, Fri Aug 12 02:18:03 2005 UTC
# Line 7  Line 7 
7  ;;; ---------------------------------------------------------------------------  ;;; ---------------------------------------------------------------------------
8    
9  ;;;  (c) copyright 2002 by Gilbert Baumann  ;;;  (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  ;;; This library is free software; you can redistribute it and/or
13  ;;; modify it under the terms of the GNU Library General Public  ;;; modify it under the terms of the GNU Library General Public
# Line 138  Line 139 
139          graph-type (or graph-type (if merge-duplicates :digraph :tree))          graph-type (or graph-type (if merge-duplicates :digraph :tree))
140          duplicate-key (or duplicate-key #'identity)          duplicate-key (or duplicate-key #'identity)
141          duplicate-test (or duplicate-test #'eql) )          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    ;; clean the options
153    (remf graph-options :stream)    (remf graph-options :stream)
# Line 163  Line 173 
173                      #'cont                      #'cont
174                      (find-graph-type graph-type)                      (find-graph-type graph-type)
175                      nil                      nil
176                      :hash-table (make-hash-table :test duplicate-test)                      ;; moved to local variable... [2005/07/25:rpg]
177                      graph-options))))                      ;; :hash-table (make-hash-table :test duplicate-test)
178                        graph-options
179                        ))))
180        (setf (output-record-position graph-output-record)        (setf (output-record-position graph-output-record)
181              (values cursor-old-x cursor-old-y))              (values cursor-old-x cursor-old-y))
182        (with-output-recording-options (stream :draw t :record nil)        (with-output-recording-options (stream :draw t :record nil)
# Line 182  Line 194 
194    
195  (defclass standard-graph-output-record (graph-output-record  (defclass standard-graph-output-record (graph-output-record
196                                          standard-sequence-output-record)                                          standard-sequence-output-record)
197    ((orientation       ((orientation
198      :initarg :orientation         :initarg :orientation
199      :initform :horizontal)         :initform :horizontal)
200     (center-nodes        (center-nodes
201      :initarg :center-nodes         :initarg :center-nodes
202      :initform nil)         :initform nil)
203     (cutoff-depth        (cutoff-depth
204      :initarg :cutoff-depth         :initarg :cutoff-depth
205      :initform nil)         :initform nil)
206     (merge-duplicates        (merge-duplicates
207      :initarg :merge-duplicates         :initarg :merge-duplicates
208      :initform nil)         :initform nil)
209     (generation-separation        (generation-separation
210      :initarg :generation-separation         :initarg :generation-separation
211      :initform '(4 :character))         :initform '(4 :character))
212     (within-generation-separation        (within-generation-separation
213      :initarg :within-generation-separation         :initarg :within-generation-separation
214      :initform '(1/2 :line))         :initform '(1/2 :line))
215     (hash-table        ;; removed HASH-TABLE slot and stuffed it into
216      :initarg :hash-table        ;; GENERATE-GRAPH-NODES method definition [2005/07/25:rpg]
217      :initform nil)        (root-nodes
218     (root-nodes         :accessor graph-root-nodes)
219      :accessor graph-root-nodes) ))        ))
220    
221  (defclass tree-graph-output-record (standard-graph-output-record)  (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)  (defclass dag-graph-output-record (standard-graph-output-record)
229    ())    (
230       ))
231    
232  (defclass digraph-graph-output-record (standard-graph-output-record)  (defclass digraph-graph-output-record (standard-graph-output-record)
233    ())    ())
# Line 238  Line 255 
255    
256  ;;;;  ;;;;
257    
258    ;;; Modified to make this obey the spec better by using a hash-table
259    ;;; for detecting previous nodes only when the duplicate-test argument
260    ;;; permits it.  [2005/08/10:rpg]
261  (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record)  (defmethod generate-graph-nodes ((graph-output-record standard-graph-output-record)
262                                   stream root-objects                                   stream root-objects
263                                   object-printer inferior-producer                                   object-printer inferior-producer
264                                   &key duplicate-key duplicate-test)                                   &key duplicate-key duplicate-test)
265    (declare (ignore duplicate-test))    (with-slots (cutoff-depth merge-duplicates) graph-output-record
266    (with-slots (cutoff-depth merge-duplicates hash-table) graph-output-record      (let* ((hash-table (when (and merge-duplicates (member duplicate-test (list #'eq #'eql #'equal #'equalp)))
267      (labels                           (make-hash-table :test duplicate-test)))
268          ((traverse-objects (node objects depth)             node-list
269             (unless (and cutoff-depth (>= depth cutoff-depth))             (hashed hash-table))
270               (remove nil        (labels
271                       (map 'list            ((previous-node (obj)
272                            (lambda (child)               ;; is there a previous node for obj?  if so, return it.
273                              (let* ((key (funcall duplicate-key child))               (when merge-duplicates
274                                     (child-node (and merge-duplicates                 (if hashed
275                                                      (gethash key hash-table))))                     (locally (declare (type hash-table hash-table))
276                                (cond (child-node                       (gethash obj hash-table))
277                                       (when node                   (cdr (assoc obj node-list :test duplicate-test)))))
278                                         (push node (graph-node-parents child-node)))             ((setf previous-node) (val obj)
279                                       child-node)               (if hashed
280                                      (t                   (locally (declare (type hash-table hash-table))
281                                       (let ((child-node                     (setf (gethash obj hash-table) val))
282                                              (with-output-to-output-record                   (setf node-list (push (cons obj val) node-list))))
283                                                  (stream 'standard-graph-node-output-record new-node             (traverse-objects (node objects depth)
284                                                          :object child)               (unless (and cutoff-depth (>= depth cutoff-depth))
285                                                (funcall object-printer child stream))))                 (remove nil
286                                         (when merge-duplicates                         (map 'list
287                                           (setf (gethash key hash-table) child-node))                           (lambda (child)
288                                         (when node                             (let* ((key (funcall duplicate-key child))
289                                           (push node (graph-node-parents child-node)))                                    (child-node (previous-node key)))
290                                         (setf (graph-node-children child-node)                               (cond (child-node
291                                               (traverse-objects child-node                                      (when node
292                                                                (funcall inferior-producer child)                                        (push node (graph-node-parents child-node)))
293                                                                (+ depth 1)))                                      child-node)
294                                         child-node)))))                                     (t
295                            objects)))))                                      (let ((child-node
296        ;;                                             (with-output-to-output-record
297        (setf (graph-root-nodes graph-output-record)                                                 (stream 'standard-graph-node-output-record new-node
298              (traverse-objects nil root-objects 0))                                                         :object child)
299        (values))))                                               (funcall object-printer child stream))))
300                                          (when merge-duplicates
301                                            (setf (previous-node key) child-node)
302                                            ;; (setf (gethash key hash-table) child-node)
303                                            )
304                                          (when node
305                                            (push node (graph-node-parents child-node)))
306                                          (setf (graph-node-children child-node)
307                                            (traverse-objects child-node
308                                                              (funcall inferior-producer child)
309                                                              (+ depth 1)))
310                                          child-node)))))
311                             objects)))))
312            ;;
313            (setf (graph-root-nodes graph-output-record)
314              (traverse-objects nil root-objects 0))
315            (values)))))
316    
317  (defun traverse-graph-nodes (graph continuation)  (defun traverse-graph-nodes (graph continuation)
318    ;; continuation: node x children x cont -> some value    ;; continuation: node x children x cont -> some value
# Line 300  Line 336 
336                                                         (:horizontal :vertical)                                                         (:horizontal :vertical)
337                                                         (:vertical :horizontal))))                                                         (:vertical :horizontal))))
338            (generation-separation (parse-space stream generation-separation orientation)))            (generation-separation (parse-space stream generation-separation orientation)))
339          ;; generation sizes is an adjustable array that tracks the major
340          ;; dimension of each of the generations [2005/07/18:rpg]
341        (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))        (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0)))
342          (labels ((node-major-dimension (node)          (labels ((node-major-dimension (node)
343                     (if (eq orientation :vertical)                     (if (eq orientation :vertical)
# Line 309  Line 347 
347                     (if (eq orientation :vertical)                     (if (eq orientation :vertical)
348                         (bounding-rectangle-width node)                         (bounding-rectangle-width node)
349                         (bounding-rectangle-height node)))                         (bounding-rectangle-height node)))
350                     ;; WALK returns a node minor dimension for the node,
351                     ;; AFAICT, allowing space for that node's children
352                     ;; along the minor dimension. [2005/07/18:rpg]
353                   (walk (node depth)                   (walk (node depth)
354                     (unless (graph-node-minor-size node)                     (unless (graph-node-minor-size node)
355                       (when (>= depth (length generation-sizes))                       (when (>= depth (length generation-sizes))
# Line 368  Line 409 
409                                 (incf v within-generation-separation)))                                 (incf v within-generation-separation)))
410                             (graph-root-nodes graph-output-record)))))))))))                             (graph-root-nodes graph-output-record)))))))))))
411    
412    
413    (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
414                                   stream arc-drawer arc-drawing-options)
415      "This is a first shot at a DAG layout.  First does a TOPO sort that associates
416    each node with a depth, then lays out by depth.  Tries to reuse a maximum of the
417    tree graph layout code.
418    PRECONDITION:  This code assumes that we have generated only nodes up to the
419    cutoff-depth.  GENERATE-GRAPH-NODES seems to obey this precondition."
420      (declare (ignore arc-drawer arc-drawing-options))
421      (with-slots (orientation center-nodes generation-separation within-generation-separation root-nodes
422                               merge-duplicates) graph-output-record
423        ;; this code is snarly enough, handling merge-duplicates.  If
424        ;; you're not merging duplicates, you're out of luck, at least for
425        ;; now... [2005/07/18:rpg]
426        (unless merge-duplicates
427          (cerror "Set to T and continue?" "DAG graph-layout type only supports merge-duplicates to be T")
428          (setf merge-duplicates t))
429    
430        (check-type orientation (member :horizontal :vertical)) ;xxx move to init.-inst.
431    
432        ;; here major dimension is the dimension in which we grow the
433        ;; tree.
434        (let ((within-generation-separation (parse-space stream within-generation-separation
435                                                         (case orientation
436                                                           (:horizontal :vertical)
437                                                           (:vertical :horizontal))))
438              (generation-separation (parse-space stream generation-separation orientation)))
439          ;; generation sizes is an adjustable array that tracks the major
440          ;; dimension of each of the generations [2005/07/18:rpg]
441          (let ((generation-sizes (make-array 10 :adjustable t :initial-element 0))
442                (visited (make-hash-table :test #'eq))
443                (parent-hash (make-hash-table :test #'eq)))
444            (labels ((node-major-dimension (node)
445                       (if (eq orientation :vertical)
446                           (bounding-rectangle-height node)
447                           (bounding-rectangle-width node)))
448                     (node-minor-dimension (node)
449                       (if (eq orientation :vertical)
450                           (bounding-rectangle-width node)
451                           (bounding-rectangle-height node)))
452                     ;; WALK returns a node minor dimension for the node,
453                     ;; AFAICT, allowing space for that node's children
454                     ;; along the minor dimension. [2005/07/18:rpg]
455                     (walk (node depth &optional parent)
456                       (unless (gethash node visited)
457                         (setf (gethash node visited) depth)
458                         (when parent
459                           (setf (gethash node parent-hash) parent))
460                         (unless (graph-node-minor-size node)
461                           (when (>= depth (length generation-sizes))
462                             (setf generation-sizes (adjust-array generation-sizes (ceiling (* depth 1.2))
463                                                                  :initial-element 0)))
464                           (setf (aref generation-sizes depth)
465                                 (max (aref generation-sizes depth) (node-major-dimension node)))
466                           (setf (graph-node-minor-size node) 0)
467                           (max (node-minor-dimension node)
468                                (setf (graph-node-minor-size node)
469                                      (let ((sum 0) (n 0))
470                                        (map nil (lambda (child)
471                                                   (let ((x (walk child (+ depth 1) node)))
472                                                     (when x
473                                                       (incf sum x)
474                                                       (incf n))))
475                                             (graph-node-children node))
476                                        (+ sum
477                                           (* (max 0 (- n 1)) within-generation-separation)))))))))
478              (map nil #'(lambda (x) (walk x 0)) root-nodes)
479              (let ((hash (make-hash-table :test #'eq)))
480                (labels ((foo (node majors u0 v0)
481                           (cond ((gethash node hash)
482                                  v0)
483                                 (t
484                                  (setf (gethash node hash) t)
485                                  (let ((d (- (node-minor-dimension node)
486                                              (graph-node-minor-size node))))
487                                    (let ((v (+ v0 (/ (min 0 d) -2))))
488                                      (setf (output-record-position node)
489                                            (if (eq orientation :vertical)
490                                                (transform-position (medium-transformation stream) v u0)
491                                                (transform-position (medium-transformation stream) u0 v)))
492                                      (add-output-record node graph-output-record))
493                                    ;;
494                                    (let ((u (+ u0 (car majors)))
495                                          (v (+ v0 (max 0 (/ d 2))))
496                                          (firstp t))
497                                      (map nil (lambda (q)
498                                                 (unless (gethash q hash)
499                                                   (if firstp
500                                                       (setf firstp nil)
501                                                       (incf v within-generation-separation))
502                                                   (setf v (foo q (cdr majors)
503                                                                u v))))
504                                           ;; when computing the sizes, to
505                                           ;; make the tree-style layout
506                                           ;; work, we have to have each
507                                           ;; node have a unique
508                                           ;; parent. [2005/07/18:rpg]
509                                           (remove-if-not #'(lambda (x) (eq (gethash x parent-hash) node))
510                                                          (graph-node-children node))))
511                                    ;;
512                                    (+ v0 (max (node-minor-dimension node)
513                                               (graph-node-minor-size node))))))))
514                  ;;
515                  (let ((majors (mapcar (lambda (x) (+ x generation-separation))
516                                        (coerce generation-sizes 'list))))
517                    (let ((u (+ 0 (car majors)))
518                          (v 0))
519                      (maplist (lambda (rest)
520                                 (setf v (foo (car rest) majors u v))
521                                 (unless (null rest)
522                                   (incf v within-generation-separation)))
523                               (graph-root-nodes graph-output-record)))))))))))
524    
525    
526    
527  #+ignore  #+ignore
528  (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)  (defmethod layout-graph-edges ((graph-output-record standard-graph-output-record)
529                                 stream arc-drawer arc-drawing-options)                                 stream arc-drawer arc-drawing-options)

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5