dev/subgraph-containing.lisp

   1 ;; 2008-09-23 - these are the only bits that depend on moptilities
   2
   3 (in-package #:cl-graph)
   4
   5
   6 ;;; make-filtered-graph
   7
   8 (defmethod complete-links ((new-graph basic-graph)
   9                            (old-graph basic-graph))
  10   ;; Copy links from old-graph ONLY for nodes already in new-graph
  11   (iterate-vertexes
  12    new-graph
  13    (lambda (vertex)
  14      (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
  15        (iterate-edges
  16         old-graph-vertex
  17         (lambda (old-edge)
  18           (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
  19                  (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
  20             (when (and new-other-vertex
  21                        (< (vertex-id vertex) (vertex-id new-other-vertex)))
  22               (let* ((new-edge (mopu:copy-template old-edge)))
  23                 (if (eq old-graph-vertex (vertex-1 old-edge))
  24                   (setf (slot-value new-edge 'vertex-1) vertex
  25                         (slot-value new-edge 'vertex-2) new-other-vertex)
  26                   (setf (slot-value new-edge 'vertex-2) vertex
  27                         (slot-value new-edge 'vertex-1) new-other-vertex))
  28                 (add-edge new-graph new-edge))))))))))
  29
  30 #+Old
  31 (defmethod complete-links ((new-graph basic-graph)
  32                            (old-graph basic-graph))
  33   ;; Copy links from old-graph ONLY for nodes already in new-graph
  34   (iterate-vertexes
  35    new-graph
  36    (lambda (vertex)
  37      (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
  38        (iterate-edges
  39         old-graph-vertex
  40         (lambda (edge)
  41           (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
  42                  (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
  43                  (edge-type (if (directed-edge-p edge)
  44                               :directed :undirected)))
  45             (when new-other-vertex
  46               (if (and (directed-edge-p edge)
  47                        (eq old-graph-vertex (target-vertex edge)))
  48                 (add-edge-between-vertexes new-graph new-other-vertex vertex
  49                                            :value (value edge)
  50                                            :edge-type edge-type)
  51                 (add-edge-between-vertexes new-graph vertex new-other-vertex
  52                                            :value (value edge)
  53                                            :edge-type edge-type))))))))))
  54
  55
  56 (defmethod make-filtered-graph ((old-graph basic-graph)
  57                                 test-fn
  58                                 &key
  59                                 (graph-completion-method nil)
  60                                 (depth nil)
  61                                 (new-graph
  62                                  (mopu:copy-template old-graph)))
  63   (ecase graph-completion-method
  64     ((nil
  65       :complete-links)
  66      (iterate-vertexes old-graph
  67                        (lambda (vertex)
  68                          (when (funcall test-fn vertex)
  69                            (add-vertex new-graph (value vertex))))))
  70     ((:complete-closure-nodes-only
  71       :complete-closure-with-links)
  72      (let* ((old-graph-vertexes  (collect-items old-graph :filter test-fn))
  73             (closure-vertexes
  74              (get-transitive-closure old-graph-vertexes depth)))
  75        (dolist (vertex closure-vertexes)
  76          (add-vertex new-graph (mopu:copy-template vertex))))))
  77   (ecase graph-completion-method
  78       ((nil :complete-closure-nodes-only) nil)
  79       ((:complete-links
  80         :complete-closure-with-links)
  81        (complete-links new-graph old-graph)))
  82   new-graph)
  83
  84
  85 (defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
  86                                 &rest args &key (depth nil) (new-graph nil))
  87   (declare (ignore depth new-graph))
  88   (apply #'make-filtered-graph
  89          graph
  90          #'(lambda (v)
  91              (equal v vertex))
  92          :graph-completion-method :complete-closure-with-links
  93          args))
  94
  95 ;;; for completeness
  96
  97 (defmethod make-graph-from-vertexes ((vertex-list list))
  98   (bind ((edges-to-keep nil)
  99          (g (mopu:copy-template (graph (first vertex-list)))))
 100
 101     (iterate-elements
 102      vertex-list
 103      (lambda (v)
 104        (add-vertex g (element v))
 105        (iterate-elements
 106         (edges v)
 107         (lambda (e)
 108           (when (and (member (vertex-1 e) vertex-list)
 109                      (member (vertex-2 e) vertex-list))
 110             (pushnew e edges-to-keep :test #'eq))))))
 111
 112     (iterate-elements
 113      edges-to-keep
 114      (lambda (e)
 115        (bind ((v1 (source-vertex e))
 116               (v2 (target-vertex e)))
 117          ;;?? can we use copy here...
 118          (add-edge-between-vertexes
 119           g (element v1) (element v2)
 120           :edge-type (if (directed-edge-p e)
 121                        :directed
 122                        :undirected)
 123           :if-duplicate-do :force
 124           :edge-class (type-of e)
 125           :value (value e)
 126           :edge-id (edge-id e)
 127           :element (element e)
 128           :tag (tag e)
 129           :graph g
 130           :color (color e)))))
 131     g))