/[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.17 by tmoore, Fri Mar 10 21:58:13 2006 UTC revision 1.18 by crhodes, Mon Apr 10 09:48:40 2006 UTC
# Line 240  Line 240 
240      :initarg :graph-children      :initarg :graph-children
241      :initform nil      :initform nil
242      :accessor graph-node-children)      :accessor graph-node-children)
243       (edges-from :initform (make-hash-table))
244       (edges-to   :initform (make-hash-table))
245     (object     (object
246      :initarg :object      :initarg :object
247      :reader graph-node-object)      :reader graph-node-object)
# Line 405  Line 407 
407                                 (incf v within-generation-separation)))                                 (incf v within-generation-separation)))
408                             (graph-root-nodes graph-output-record)))))))))))                             (graph-root-nodes graph-output-record)))))))))))
409    
410    ;;;; Edges
411    
412    (defclass standard-edge-output-record (standard-sequence-output-record)
413      ((stream)
414       (arc-drawer)
415       (arc-drawing-options)
416       (from-node :initarg :from-node)
417       (to-node :initarg :to-node)))
418    
419    
420  (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)  (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record)
421                                 stream arc-drawer arc-drawing-options)                                 stream arc-drawer arc-drawing-options)
# Line 526  cutoff-depth.  GENERATE-GRAPH-NODES seem Line 537  cutoff-depth.  GENERATE-GRAPH-NODES seem
537    (with-slots (root-nodes orientation) graph-output-record    (with-slots (root-nodes orientation) graph-output-record
538      (let ((hash (make-hash-table)))      (let ((hash (make-hash-table)))
539        (labels ((walk (node)        (labels ((walk (node)
540                   (unless (gethash node hash)                   (unless (gethash node hash)
541                     (setf (gethash node hash) t)                     (setf (gethash node hash) t)
542                     (dolist (k (graph-node-children node))                     (dolist (k (graph-node-children node))
543                       (with-bounding-rectangle* (x1 y1 x2 y2) node                       (with-bounding-rectangle* (x1 y1 x2 y2) node
# Line 551  cutoff-depth.  GENERATE-GRAPH-NODES seem Line 562  cutoff-depth.  GENERATE-GRAPH-NODES seem
562                       (walk k)))))                       (walk k)))))
563          (map nil #'walk root-nodes)))))          (map nil #'walk root-nodes)))))
564    
565    (defun layout-edges (graph node stream arc-drawer arc-drawing-options)
566      (dolist (k (graph-node-children node))
567        (layout-edge graph node k stream arc-drawer arc-drawing-options)))
568    
569    (defun ensure-edge-record (graph major-node minor-node)
570      (let ((edges-from (slot-value major-node 'edges-from))
571            (edges-to   (slot-value minor-node 'edges-to)))
572        (assert (eq (gethash minor-node edges-from)
573                    (gethash major-node edges-to)))
574        (or (gethash minor-node edges-from)
575            (let ((record (make-instance 'standard-edge-output-record
576                                         :from-node major-node :to-node minor-node)))
577              (setf (gethash minor-node edges-from) record
578                    (gethash major-node edges-to) record)
579              (add-output-record record graph)
580              record))))
581    
582    (defun layout-edge-1 (graph major-node minor-node)
583      (let ((edge-record (ensure-edge-record graph major-node minor-node)))
584        (with-slots (stream arc-drawer arc-drawing-options) edge-record
585          (with-bounding-rectangle* (x1 y1 x2 y2) major-node
586            (with-bounding-rectangle* (u1 v1 u2 v2) minor-node
587              (clear-output-record edge-record)  ;;; FIXME: repaint?
588               (letf (((stream-current-output-record stream) edge-record))
589                (ecase (slot-value graph 'orientation)
590                  ((:horizontal)
591                   (multiple-value-bind (from to) (if (< x1 u1)
592                                                      (values x2 u1)
593                                                      (values x1 u2))
594                     (apply arc-drawer stream major-node minor-node
595                            from (/ (+ y1 y2) 2)
596                            to   (/ (+ v1 v2) 2)
597                            arc-drawing-options)))
598                  ((:vertical)
599                   (multiple-value-bind (from to) (if (< y1 v1)
600                                                      (values y2 v1)
601                                                      (values y1 v2))
602                     (apply arc-drawer stream major-node minor-node
603                            (/ (+ x1 x2) 2) from
604                            (/ (+ u1 u2) 2) to
605                            arc-drawing-options))))))))))
606    
607    (defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options)
608      (let ((edge-record (ensure-edge-record graph major-node minor-node)))
609        (setf (slot-value edge-record 'stream) stream
610              (slot-value edge-record 'arc-drawer) arc-drawer
611              (slot-value edge-record 'arc-drawing-options) arc-drawing-options)
612        (layout-edge-1 graph major-node minor-node)))
613    
614  (defmethod layout-graph-edges ((graph standard-graph-output-record)  (defmethod layout-graph-edges ((graph standard-graph-output-record)
615                                 stream arc-drawer arc-drawing-options)                                 stream arc-drawer arc-drawing-options)
616    (with-slots (orientation) graph    (with-slots (orientation) graph
# Line 562  cutoff-depth.  GENERATE-GRAPH-NODES seem Line 622  cutoff-depth.  GENERATE-GRAPH-NODES seem
622      (traverse-graph-nodes graph      (traverse-graph-nodes graph
623                            (lambda (node children continuation)                            (lambda (node children continuation)
624                              (unless (eq node graph)                              (unless (eq node graph)
625                                (dolist (k children)                                (layout-edges graph node stream arc-drawer arc-drawing-options))
                                 (with-bounding-rectangle* (x1 y1 x2 y2) node  
                                   (with-bounding-rectangle* (u1 v1 u2 v2) k  
                                     (ecase orientation  
                                       ((:horizontal)  
                                        (multiple-value-bind (from to) (if (< x1 u1)  
                                                                           (values x2 u1)  
                                                                           (values x1 u2))  
                                          (apply arc-drawer stream node k  
                                                 from (/ (+ y1 y2) 2)  
                                                 to   (/ (+ v1 v2) 2)  
                                                 arc-drawing-options)))  
                                       ((:vertical)  
                                        (multiple-value-bind (from to) (if (< y1 v1)  
                                                                           (values y2 v1)  
                                                                           (values y1 v2))  
                                          (apply arc-drawer stream node k  
                                                 (/ (+ x1 x2) 2) from  
                                                 (/ (+ u1 u2) 2) to  
                                                 arc-drawing-options))))))))  
626                              (map nil continuation children))))))                              (map nil continuation children))))))
627    
628  (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record)  (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

  ViewVC Help
Powered by ViewVC 1.1.5