1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/graph.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,228 @@
     1.4 +;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
     1.5 +;;  distribution terms for this software are covered by the Eclipse Public
     1.6 +;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
     1.7 +;;  be found in the file epl-v10.html at the root of this distribution.  By
     1.8 +;;  using this software in any fashion, you are agreeing to be bound by the
     1.9 +;;  terms of this license.  You must not remove this notice, or any other,
    1.10 +;;  from this software.
    1.11 +;;
    1.12 +;;  graph
    1.13 +;;
    1.14 +;;  Basic Graph Theory Algorithms
    1.15 +;;
    1.16 +;;  straszheimjeffrey (gmail)
    1.17 +;;  Created 23 June 2009
    1.18 +
    1.19 +
    1.20 +(ns 
    1.21 +  ^{:author "Jeffrey Straszheim",
    1.22 +     :doc "Basic graph theory algorithms"}
    1.23 +  clojure.contrib.graph
    1.24 +  (use [clojure.set :only (union)]))
    1.25 +
    1.26 +
    1.27 +(defstruct directed-graph
    1.28 +  :nodes       ; The nodes of the graph, a collection
    1.29 +  :neighbors)  ; A function that, given a node returns a collection
    1.30 +               ; neighbor nodes.
    1.31 +
    1.32 +(defn get-neighbors
    1.33 +  "Get the neighbors of a node."
    1.34 +  [g n]
    1.35 +  ((:neighbors g) n))
    1.36 +
    1.37 +
    1.38 +;; Graph Modification
    1.39 +
    1.40 +(defn reverse-graph
    1.41 +  "Given a directed graph, return another directed graph with the
    1.42 +   order of the edges reversed."
    1.43 +  [g]
    1.44 +  (let [op (fn [rna idx]
    1.45 +             (let [ns (get-neighbors g idx)
    1.46 +                   am (fn [m val]
    1.47 +                        (assoc m val (conj (get m val #{}) idx)))]
    1.48 +               (reduce am rna ns)))
    1.49 +        rn (reduce op {} (:nodes g))]
    1.50 +    (struct directed-graph (:nodes g) rn)))
    1.51 +
    1.52 +(defn add-loops
    1.53 +  "For each node n, add the edge n->n if not already present."
    1.54 +  [g]
    1.55 +  (struct directed-graph
    1.56 +          (:nodes g)
    1.57 +          (into {} (map (fn [n]
    1.58 +                          [n (conj (set (get-neighbors g n)) n)]) (:nodes g)))))
    1.59 +
    1.60 +(defn remove-loops
    1.61 +  "For each node n, remove any edges n->n."
    1.62 +  [g]
    1.63 +  (struct directed-graph
    1.64 +          (:nodes g)
    1.65 +          (into {} (map (fn [n]
    1.66 +                          [n (disj (set (get-neighbors g n)) n)]) (:nodes g)))))
    1.67 +
    1.68 +
    1.69 +;; Graph Walk
    1.70 +
    1.71 +(defn lazy-walk
    1.72 +  "Return a lazy sequence of the nodes of a graph starting a node n.  Optionally,
    1.73 +   provide a set of visited notes (v) and a collection of nodes to
    1.74 +   visit (ns)."
    1.75 +  ([g n]
    1.76 +     (lazy-walk g [n] #{}))
    1.77 +  ([g ns v]
    1.78 +     (lazy-seq (let [s (seq (drop-while v ns))
    1.79 +                     n (first s)
    1.80 +                     ns (rest s)]
    1.81 +                 (when s
    1.82 +                   (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n))))))))
    1.83 +
    1.84 +(defn transitive-closure
    1.85 +  "Returns the transitive closure of a graph.  The neighbors are lazily computed.
    1.86 +
    1.87 +   Note: some version of this algorithm return all edges a->a
    1.88 +   regardless of whether such loops exist in the original graph.  This
    1.89 +   version does not.  Loops will be included only if produced by
    1.90 +   cycles in the graph.  If you have code that depends on such
    1.91 +   behavior, call (-> g transitive-closure add-loops)"
    1.92 +  [g]
    1.93 +  (let [nns (fn [n]
    1.94 +              [n (delay (lazy-walk g (get-neighbors g n) #{}))])
    1.95 +        nbs (into {} (map nns (:nodes g)))]
    1.96 +    (struct directed-graph
    1.97 +            (:nodes g)
    1.98 +            (fn [n] (force (nbs n))))))
    1.99 +          
   1.100 +                
   1.101 +;; Strongly Connected Components
   1.102 +
   1.103 +(defn- post-ordered-visit
   1.104 +  "Starting at node n, perform a post-ordered walk."
   1.105 +  [g n [visited acc :as state]]
   1.106 +  (if (visited n)
   1.107 +    state
   1.108 +    (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st))
   1.109 +                            [(conj visited n) acc]
   1.110 +                            (get-neighbors g n))]
   1.111 +      [v2 (conj acc2 n)])))
   1.112 +  
   1.113 +(defn post-ordered-nodes
   1.114 +  "Return a sequence of indexes of a post-ordered walk of the graph."
   1.115 +  [g]
   1.116 +  (fnext (reduce #(post-ordered-visit g %2 %1)
   1.117 +                 [#{} []]
   1.118 +                 (:nodes g))))
   1.119 +
   1.120 +(defn scc
   1.121 +  "Returns, as a sequence of sets, the strongly connected components
   1.122 +   of g."
   1.123 +  [g]
   1.124 +  (let [po (reverse (post-ordered-nodes g))
   1.125 +        rev (reverse-graph g)
   1.126 +        step (fn [stack visited acc]
   1.127 +               (if (empty? stack)
   1.128 +                 acc
   1.129 +                 (let [[nv comp] (post-ordered-visit rev
   1.130 +                                                     (first stack)
   1.131 +                                                     [visited #{}])
   1.132 +                       ns (remove nv stack)]
   1.133 +                   (recur ns nv (conj acc comp)))))]
   1.134 +    (step po #{} [])))
   1.135 +
   1.136 +(defn component-graph
   1.137 +  "Given a graph, perhaps with cycles, return a reduced graph that is acyclic.
   1.138 +   Each node in the new graph will be a set of nodes from the old.
   1.139 +   These sets are the strongly connected components.  Each edge will
   1.140 +   be the union of the corresponding edges of the prior graph."
   1.141 +  ([g]
   1.142 +     (component-graph g (scc g)))
   1.143 +  ([g sccs]
   1.144 +     (let [find-node-set (fn [n]
   1.145 +                           (some #(if (% n) % nil) sccs))
   1.146 +           find-neighbors (fn [ns]
   1.147 +                            (let [nbs1 (map (partial get-neighbors g) ns)
   1.148 +                                  nbs2 (map set nbs1)
   1.149 +                                  nbs3 (apply union nbs2)]
   1.150 +                              (set (map find-node-set nbs3))))
   1.151 +           nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))]
   1.152 +       (struct directed-graph (set sccs) nm))))
   1.153 +
   1.154 +(defn recursive-component?
   1.155 +  "Is the component (recieved from scc) self recursive?"
   1.156 +  [g ns]
   1.157 +  (or (> (count ns) 1)
   1.158 +      (let [n (first ns)]
   1.159 +        (some #(= % n) (get-neighbors g n)))))
   1.160 +
   1.161 +(defn self-recursive-sets
   1.162 +  "Returns, as a sequence of sets, the components of a graph that are
   1.163 +   self-recursive."
   1.164 +  [g]
   1.165 +  (filter (partial recursive-component? g) (scc g)))
   1.166 +                          
   1.167 +
   1.168 +;; Dependency Lists
   1.169 +
   1.170 +(defn fixed-point
   1.171 +  "Repeatedly apply fun to data until (equal old-data new-data)
   1.172 +   returns true.  If max iterations occur, it will throw an
   1.173 +   exception.  Set max to nil for unlimited iterations."
   1.174 +  [data fun max equal]
   1.175 +  (let [step (fn step [data idx]
   1.176 +               (when (and idx (= 0 idx))
   1.177 +                 (throw (Exception. "Fixed point overflow")))
   1.178 +               (let [new-data (fun data)]
   1.179 +                 (if (equal data new-data)
   1.180 +                   new-data
   1.181 +                   (recur new-data (and idx (dec idx))))))]
   1.182 +    (step data max)))
   1.183 +                  
   1.184 +(defn- fold-into-sets
   1.185 +  [priorities]
   1.186 +  (let [max (inc (apply max 0 (vals priorities)))
   1.187 +        step (fn [acc [n dep]]
   1.188 +               (assoc acc dep (conj (acc dep) n)))]
   1.189 +    (reduce step
   1.190 +            (vec (replicate max #{}))
   1.191 +            priorities)))
   1.192 +            
   1.193 +(defn dependency-list
   1.194 +  "Similar to a topological sort, this returns a vector of sets. The
   1.195 +   set of nodes at index 0 are independent.  The set at index 1 depend
   1.196 +   on index 0; those at 2 depend on 0 and 1, and so on.  Those withing
   1.197 +   a set have no mutual dependencies.  Assume the input graph (which
   1.198 +   much be acyclic) has an edge a->b when a depends on b."
   1.199 +  [g]
   1.200 +  (let [step (fn [d]
   1.201 +               (let [update (fn [n]
   1.202 +                              (inc (apply max -1 (map d (get-neighbors g n)))))]
   1.203 +                 (into {} (map (fn [[k v]] [k (update k)]) d))))
   1.204 +        counts (fixed-point (zipmap (:nodes g) (repeat 0))
   1.205 +                            step
   1.206 +                            (inc (count (:nodes g)))
   1.207 +                            =)]
   1.208 +    (fold-into-sets counts)))
   1.209 +    
   1.210 +(defn stratification-list
   1.211 +  "Similar to dependency-list (see doc), except two graphs are
   1.212 +   provided.  The first is as dependency-list.  The second (which may
   1.213 +   have cycles) provides a partial-dependency relation.  If node a
   1.214 +   depends on node b (meaning an edge a->b exists) in the second
   1.215 +   graph, node a must be equal or later in the sequence."
   1.216 +  [g1 g2]
   1.217 +  (assert (= (-> g1 :nodes set) (-> g2 :nodes set)))
   1.218 +  (let [step (fn [d]
   1.219 +               (let [update (fn [n]
   1.220 +                              (max (inc (apply max -1
   1.221 +                                               (map d (get-neighbors g1 n))))
   1.222 +                                   (apply max -1 (map d (get-neighbors g2 n)))))]
   1.223 +                 (into {} (map (fn [[k v]] [k (update k)]) d))))
   1.224 +        counts (fixed-point (zipmap (:nodes g1) (repeat 0))
   1.225 +                            step
   1.226 +                            (inc (count (:nodes g1)))
   1.227 +                            =)]
   1.228 +    (fold-into-sets counts)))
   1.229 +
   1.230 +
   1.231 +;; End of file