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