diff options
Diffstat (limited to 'modules/graph')
| -rw-r--r-- | modules/graph/pom.xml | 16 | ||||
| -rw-r--r-- | modules/graph/src/main/clojure/clojure/contrib/graph.clj | 228 |
2 files changed, 244 insertions, 0 deletions
diff --git a/modules/graph/pom.xml b/modules/graph/pom.xml new file mode 100644 index 00000000..9a32dfd6 --- /dev/null +++ b/modules/graph/pom.xml @@ -0,0 +1,16 @@ +<?xml version="1.0" encoding="UTF-8"?> +<project xmlns="http://maven.apache.org/POM/4.0.0" + xmlns:xsi="http//www.w3.org/2001/XMLSchema-instance" + xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 + http://maven.apache.org/maven-v4_0_0.xsd"> + <modelVersion>4.0.0</modelVersion> + <parent> + <groupId>org.clojure.contrib</groupId> + <artifactId>parent</artifactId> + <version>1.3.0-SNAPSHOT</version> + <relativePath>../parent</relativePath> + </parent> + <artifactId>graph</artifactId> + <dependencies> + </dependencies> +</project>
\ No newline at end of file diff --git a/modules/graph/src/main/clojure/clojure/contrib/graph.clj b/modules/graph/src/main/clojure/clojure/contrib/graph.clj new file mode 100644 index 00000000..226908fc --- /dev/null +++ b/modules/graph/src/main/clojure/clojure/contrib/graph.clj @@ -0,0 +1,228 @@ +;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and +;; distribution terms for this software are covered by the Eclipse Public +;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can +;; be found in the file epl-v10.html at the root of this distribution. By +;; using this software in any fashion, you are agreeing to be bound by the +;; terms of this license. You must not remove this notice, or any other, +;; from this software. +;; +;; graph +;; +;; Basic Graph Theory Algorithms +;; +;; straszheimjeffrey (gmail) +;; Created 23 June 2009 + + +(ns + ^{:author "Jeffrey Straszheim", + :doc "Basic graph theory algorithms"} + clojure.contrib.graph + (use [clojure.set :only (union)])) + + +(defstruct directed-graph + :nodes ; The nodes of the graph, a collection + :neighbors) ; A function that, given a node returns a collection + ; neighbor nodes. + +(defn get-neighbors + "Get the neighbors of a node." + [g n] + ((:neighbors g) n)) + + +;; Graph Modification + +(defn reverse-graph + "Given a directed graph, return another directed graph with the + order of the edges reversed." + [g] + (let [op (fn [rna idx] + (let [ns (get-neighbors g idx) + am (fn [m val] + (assoc m val (conj (get m val #{}) idx)))] + (reduce am rna ns))) + rn (reduce op {} (:nodes g))] + (struct directed-graph (:nodes g) rn))) + +(defn add-loops + "For each node n, add the edge n->n if not already present." + [g] + (struct directed-graph + (:nodes g) + (into {} (map (fn [n] + [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) + +(defn remove-loops + "For each node n, remove any edges n->n." + [g] + (struct directed-graph + (:nodes g) + (into {} (map (fn [n] + [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) + + +;; Graph Walk + +(defn lazy-walk + "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, + provide a set of visited notes (v) and a collection of nodes to + visit (ns)." + ([g n] + (lazy-walk g [n] #{})) + ([g ns v] + (lazy-seq (let [s (seq (drop-while v ns)) + n (first s) + ns (rest s)] + (when s + (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) + +(defn transitive-closure + "Returns the transitive closure of a graph. The neighbors are lazily computed. + + Note: some version of this algorithm return all edges a->a + regardless of whether such loops exist in the original graph. This + version does not. Loops will be included only if produced by + cycles in the graph. If you have code that depends on such + behavior, call (-> g transitive-closure add-loops)" + [g] + (let [nns (fn [n] + [n (delay (lazy-walk g (get-neighbors g n) #{}))]) + nbs (into {} (map nns (:nodes g)))] + (struct directed-graph + (:nodes g) + (fn [n] (force (nbs n)))))) + + +;; Strongly Connected Components + +(defn- post-ordered-visit + "Starting at node n, perform a post-ordered walk." + [g n [visited acc :as state]] + (if (visited n) + state + (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) + [(conj visited n) acc] + (get-neighbors g n))] + [v2 (conj acc2 n)]))) + +(defn post-ordered-nodes + "Return a sequence of indexes of a post-ordered walk of the graph." + [g] + (fnext (reduce #(post-ordered-visit g %2 %1) + [#{} []] + (:nodes g)))) + +(defn scc + "Returns, as a sequence of sets, the strongly connected components + of g." + [g] + (let [po (reverse (post-ordered-nodes g)) + rev (reverse-graph g) + step (fn [stack visited acc] + (if (empty? stack) + acc + (let [[nv comp] (post-ordered-visit rev + (first stack) + [visited #{}]) + ns (remove nv stack)] + (recur ns nv (conj acc comp)))))] + (step po #{} []))) + +(defn component-graph + "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. + Each node in the new graph will be a set of nodes from the old. + These sets are the strongly connected components. Each edge will + be the union of the corresponding edges of the prior graph." + ([g] + (component-graph g (scc g))) + ([g sccs] + (let [find-node-set (fn [n] + (some #(if (% n) % nil) sccs)) + find-neighbors (fn [ns] + (let [nbs1 (map (partial get-neighbors g) ns) + nbs2 (map set nbs1) + nbs3 (apply union nbs2)] + (set (map find-node-set nbs3)))) + nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] + (struct directed-graph (set sccs) nm)))) + +(defn recursive-component? + "Is the component (recieved from scc) self recursive?" + [g ns] + (or (> (count ns) 1) + (let [n (first ns)] + (some #(= % n) (get-neighbors g n))))) + +(defn self-recursive-sets + "Returns, as a sequence of sets, the components of a graph that are + self-recursive." + [g] + (filter (partial recursive-component? g) (scc g))) + + +;; Dependency Lists + +(defn fixed-point + "Repeatedly apply fun to data until (equal old-data new-data) + returns true. If max iterations occur, it will throw an + exception. Set max to nil for unlimited iterations." + [data fun max equal] + (let [step (fn step [data idx] + (when (and idx (= 0 idx)) + (throw (Exception. "Fixed point overflow"))) + (let [new-data (fun data)] + (if (equal data new-data) + new-data + (recur new-data (and idx (dec idx))))))] + (step data max))) + +(defn- fold-into-sets + [priorities] + (let [max (inc (apply max 0 (vals priorities))) + step (fn [acc [n dep]] + (assoc acc dep (conj (acc dep) n)))] + (reduce step + (vec (replicate max #{})) + priorities))) + +(defn dependency-list + "Similar to a topological sort, this returns a vector of sets. The + set of nodes at index 0 are independent. The set at index 1 depend + on index 0; those at 2 depend on 0 and 1, and so on. Those withing + a set have no mutual dependencies. Assume the input graph (which + much be acyclic) has an edge a->b when a depends on b." + [g] + (let [step (fn [d] + (let [update (fn [n] + (inc (apply max -1 (map d (get-neighbors g n)))))] + (into {} (map (fn [[k v]] [k (update k)]) d)))) + counts (fixed-point (zipmap (:nodes g) (repeat 0)) + step + (inc (count (:nodes g))) + =)] + (fold-into-sets counts))) + +(defn stratification-list + "Similar to dependency-list (see doc), except two graphs are + provided. The first is as dependency-list. The second (which may + have cycles) provides a partial-dependency relation. If node a + depends on node b (meaning an edge a->b exists) in the second + graph, node a must be equal or later in the sequence." + [g1 g2] + (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) + (let [step (fn [d] + (let [update (fn [n] + (max (inc (apply max -1 + (map d (get-neighbors g1 n)))) + (apply max -1 (map d (get-neighbors g2 n)))))] + (into {} (map (fn [[k v]] [k (update k)]) d)))) + counts (fixed-point (zipmap (:nodes g1) (repeat 0)) + step + (inc (count (:nodes g1))) + =)] + (fold-into-sets counts))) + + +;; End of file |