ViewVC logotype

Diff of /mcclim/graph-formatting.lisp

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

revision 1.20 by ahefner, Sun Mar 4 22:26:22 2007 UTC revision 1.21 by rgoldman, Sun Sep 16 22:39:22 2007 UTC
# Line 115  Line 115 
115  (define-graph-type :digraph digraph-graph-output-record)  (define-graph-type :digraph digraph-graph-output-record)
117  ;;;; Entry  ;;;; Entry
118    (defun format-graph-from-root (root-object &rest other-args)
119      (apply #'format-graph-from-roots (list root-object) other-args))
121  (defun format-graph-from-roots (root-objects object-printer inferior-producer  (defun format-graph-from-roots (root-objects object-printer inferior-producer
122                                  &rest graph-options                                  &rest rest-args
123                                  &key stream orientation cutoff-depth                                  &key stream orientation cutoff-depth
124                                       merge-duplicates duplicate-key duplicate-test                                       merge-duplicates duplicate-key duplicate-test
125                                       generation-separation                                       generation-separation
# Line 128  Line 130 
130                                       graph-type (move-cursor t)                                       graph-type (move-cursor t)
131                                  &allow-other-keys)                                  &allow-other-keys)
132    (declare (ignore orientation generation-separation within-generation-separation center-nodes))    (declare (ignore orientation generation-separation within-generation-separation center-nodes))
133    ;; Mungle some arguments    ;; don't destructively modify the &rest arg
134    (check-type cutoff-depth (or null integer))    (let ((graph-options (copy-list rest-args)))
135    (check-type root-objects sequence)      ;; Munge some arguments
136    (setf stream (or stream *standard-output*)      (check-type cutoff-depth (or null integer))
137          graph-type (or graph-type (if merge-duplicates :digraph :tree))      (check-type root-objects sequence)
138          duplicate-key (or duplicate-key #'identity)      (setf stream (or stream *standard-output*)
139          duplicate-test (or duplicate-test #'eql) )            graph-type (or graph-type (if merge-duplicates :digraph :tree))
140              duplicate-key (or duplicate-key #'identity)
141    ;; I'm not sure what to do here.  Saying you want a tree, but want            duplicate-test (or duplicate-test #'eql) )
142    ;; duplicates merged seems wrong.  OTOH, if you go out of your way  
143    ;; to do it, at your own risk, is it our place to say "no"?      ;; 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]    ;; [2005/08/11:rpg]
147  ;;;  (when (and (eq graph-type :tree) merge-duplicates)  ;;;  (when (and (eq graph-type :tree) merge-duplicates)
148  ;;;    (cerror "Substitute NIL for merge-duplicates"  ;;;    (cerror "Substitute NIL for merge-duplicates"
149  ;;;         "Merge duplicates specified to be true when using :tree layout.")  ;;;         "Merge duplicates specified to be true when using :tree layout.")
150  ;;;    (setf merge-duplicates nil))  ;;;    (setf merge-duplicates nil))
152    ;; clean the options      ;; clean the options
153    (remf graph-options :stream)      (remf graph-options :stream)
154    (remf graph-options :duplicate-key)      (remf graph-options :duplicate-key)
155    (remf graph-options :duplicate-test)      (remf graph-options :duplicate-test)
156    (remf graph-options :arc-drawer)      (remf graph-options :arc-drawer)
157    (remf graph-options :arc-drawing-options)      (remf graph-options :arc-drawing-options)
158    (remf graph-options :graph-type)      (remf graph-options :graph-type)
159    (remf graph-options :move-cursor)      (remf graph-options :move-cursor)
161    (multiple-value-bind (cursor-old-x cursor-old-y)      (multiple-value-bind (cursor-old-x cursor-old-y)
162        (stream-cursor-position stream)          (stream-cursor-position stream)
163      (let ((graph-output-record        (let ((graph-output-record
164             (labels ((cont (stream graph-output-record)               (labels ((cont (stream graph-output-record)
165                        (with-output-recording-options (stream :draw nil :record t)                          (with-output-recording-options (stream :draw nil :record t)
166                          (generate-graph-nodes graph-output-record stream root-objects                            (generate-graph-nodes graph-output-record stream root-objects
167                                                object-printer inferior-producer                                                  object-printer inferior-producer
168                                                :duplicate-key duplicate-key                                                  :duplicate-key duplicate-key
169                                                :duplicate-test duplicate-test)                                                  :duplicate-test duplicate-test)
170                          (layout-graph-nodes graph-output-record stream arc-drawer arc-drawing-options)                            (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)) ))                            (layout-graph-edges graph-output-record stream arc-drawer arc-drawing-options)) ))
172               (apply #'invoke-with-new-output-record stream                 (apply #'invoke-with-new-output-record stream
173                      #'cont                        #'cont
174                      (find-graph-type graph-type)                        (find-graph-type graph-type)
175                      nil                        nil
176                      ;; moved to local variable... [2005/07/25:rpg]                        ;; moved to local variable... [2005/07/25:rpg]
177                      ;; :hash-table (make-hash-table :test duplicate-test)                        ;; :hash-table (make-hash-table :test duplicate-test)
178                      graph-options                        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        (when (and (stream-drawing-p stream)          (when (and (stream-drawing-p stream)
183                   (output-record-ancestor-p (stream-output-history stream)                     (output-record-ancestor-p (stream-output-history stream)
184                                             graph-output-record))                                               graph-output-record))
185          (with-output-recording-options (stream :draw t :record nil)            (with-output-recording-options (stream :draw t :record nil)
186            (replay graph-output-record stream)))              (replay graph-output-record stream)))
187        (when move-cursor          (when move-cursor
188          (setf (stream-cursor-position stream)            (setf (stream-cursor-position stream)
189                (values (bounding-rectangle-max-x graph-output-record)              (values (bounding-rectangle-max-x graph-output-record)
190                        (bounding-rectangle-max-y graph-output-record))))                      (bounding-rectangle-max-y graph-output-record))))
191        graph-output-record)))          graph-output-record))))
193  (defun format-graph-from-root (root &rest rest)  (defun format-graph-from-root (root &rest rest)
194    (apply #'format-graph-from-roots (list root) rest))    (apply #'format-graph-from-roots (list root) rest))
# Line 248  Line 252 
252     (object     (object
253      :initarg :object      :initarg :object
254      :reader graph-node-object)      :reader graph-node-object)
255     ;; internal slots for the graph layout algorithmn     ;; internal slots for the graph layout algorithm
256     (minor-size     (minor-size
257      :initform nil      :initform nil
258      :accessor graph-node-minor-size      :accessor graph-node-minor-size

Removed from v.1.20  
changed lines
  Added in v.1.21

  ViewVC Help
Powered by ViewVC 1.1.5