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            (dynamic-extent args))
  89   (apply #'make-filtered-graph
  90          graph
  91          #'(lambda (v)
  92              (equal v vertex))
  93          :graph-completion-method :complete-closure-with-links
  94          args))
  95
  96 ;;; for completeness
  97
  98 (defmethod make-graph-from-vertexes ((vertex-list list))
  99   (bind ((edges-to-keep nil)
 100          (g (mopu:copy-template (graph (first vertex-list)))))
 101
 102     (iterate-elements
 103      vertex-list
 104      (lambda (v)
 105        (add-vertex g (element v))
 106        (iterate-elements
 107         (edges v)
 108         (lambda (e)
 109           (when (and (member (vertex-1 e) vertex-list)
 110                      (member (vertex-2 e) vertex-list))
 111             (pushnew e edges-to-keep :test #'eq))))))
 112
 113     (iterate-elements
 114      edges-to-keep
 115      (lambda (e)
 116        (bind ((v1 (source-vertex e))
 117               (v2 (target-vertex e)))
 118          ;;?? can we use copy here...
 119          (add-edge-between-vertexes
 120           g (element v1) (element v2)
 121           :edge-type (if (directed-edge-p e)
 122                        :directed
 123                        :undirected)
 124           :if-duplicate-do :force
 125           :edge-class (type-of e)
 126           :value (value e)
 127           :edge-id (edge-id e)
 128           :element (element e)
 129           :tag (tag e)
 130           :graph g
 131           :color (color e)))))
 132     g))