From a8301f09c90d904d72c677823d07b68236845a31 Mon Sep 17 00:00:00 2001 From: Justin Kramer Date: Sat, 18 Sep 2010 03:35:09 -0400 Subject: [PATCH] initial commit --- .gitignore | 4 + README.md | 140 ++++++++++++ project.clj | 11 + src/loom/alg.clj | 234 ++++++++++++++++++++ src/loom/alg_generic.clj | 289 ++++++++++++++++++++++++ src/loom/attr.clj | 136 ++++++++++++ src/loom/gen.clj | 54 +++++ src/loom/graph.clj | 459 +++++++++++++++++++++++++++++++++++++++ src/loom/io.clj | 140 ++++++++++++ src/loom/io/ubigraph.clj | 56 +++++ src/loom/label.clj | 66 ++++++ src/loom/multigraph.clj | 5 + test/loom/test/alg.clj | 102 +++++++++ test/loom/test/graph.clj | 251 +++++++++++++++++++++ 14 files changed, 1947 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 project.clj create mode 100644 src/loom/alg.clj create mode 100644 src/loom/alg_generic.clj create mode 100644 src/loom/attr.clj create mode 100644 src/loom/gen.clj create mode 100644 src/loom/graph.clj create mode 100644 src/loom/io.clj create mode 100644 src/loom/io/ubigraph.clj create mode 100644 src/loom/label.clj create mode 100644 src/loom/multigraph.clj create mode 100644 test/loom/test/alg.clj create mode 100644 test/loom/test/graph.clj diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d9148e9 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +pom.xml +*jar +lib +classes \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..3c080de --- /dev/null +++ b/README.md @@ -0,0 +1,140 @@ +# Loom + +This library isn't ready for consumption yet. The API is still in flux. Even the name may change. + +That said, feedback welcome. + +## Usage + +### Leiningen/Clojars [group-id/name version] + + [none yet -- see above] + +### Namespaces + + loom.graph - records & constructors + loom.alg - algorithms (see also loom.alg-generic) + loom.gen - graph generators + loom.attr - graph attributes + loom.label - graph labels + loom.io - read, write, and view graphs in external formats + +### Basics + +Create a graph: + + ;; Initialize with any of: edges, adacency lists, nodes, other graphs + (def g (graph [1 2] [2 3] {3 [4] 5 [6 7]} 7 8 9)) + (def dg (digraph g)) + (def wg (weighted-graph {:a {:b 10 :c 20} :c {:d 30} :e {:b 5 :d 5}})) + (def wdg (weighted-digraph [:a :b 10] [:a :c 20] [:c :d 30] [:d :b 10])) + (def rwg (gen-rand (weighted-graph) 10 20 :max-weight 100)) + (def fg (fly-graph :neighbors range :weight (constantly 77))) + +If you have [GraphViz](http://www.graphviz.org) installed, and its binaries are in the path, you can view graphs with loom.io/view: + + (view wdg) ;opens image in default image viewer + +Inspect: + + (nodes g) + => #{1 2 3 4 5 6 7 8 9} + + (edges wdg) + => ([:a :c] [:a :b] [:c :d] [:d :b]) + + (neighbors g 3) + => #{2 4} + + (incoming wdg :b) + => #{:a :d} + + (degree g 3) + => 2 + + (in-degree wdg :b) + => 2 + + (weight wg :a :c) + => 20 + + (map (juxt graph? directed? weighted?) [g wdg]) + => ([true false false] [true true true]) + +Add/remove items (graphs are immutable, of course, so these return new graphs): + + (add-nodes g "foobar" {:name "baz"} [1 2 3]) + + (add-edges g [10 11] ["foobar" {:name "baz"}]) + + (add-edges wg [:e :f 40] [:f :g 50]) ;weighted edges + + (remove-nodes g 1 2 3) + + (remove-edges g [1 2] [2 3]) + + (subgraph g [5 6 7]) + +Traverse a graph: + + (bf-traverse g) ;lazy + => (9 8 5 6 7 1 2 3 4) + + (bf-traverse g 1) + => (1 2 3 4) + + (pre-traverse wdg) ;lazy + => (:a :b :c :d) + + (post-traverse wdg) ;not lazy + => (:b :d :c :a) + + (topsort wdg) + => (:a :c :d :b) + +Pathfinding: + + (bf-path g 1 4) + => (1 2 3 4) + + (bf-path-bi g 1 4) ;bidirectional, parallel + => (1 2 3 4) + + (dijkstra-path wg :a :d) + => (:a :b :e :d) + + (dijkstra-path-dist wg :a :d) + => [(:a :b :e :d) 20] + +Other stuff: + + (connected-components g) + => [[1 2 3 4] [5 6 7] [8] [9]] + + (bf-span wg :a) + => {:c [:d], :b [:e], :a [:b :c]} + + (pre-span wg :a) + => {:a [:b], :b [:e], :e [:d], :d [:c]} + + (dijkstra-span wg :a) + => {:a {:b 10, :c 20}, :b {:e 15}, :e {:d 20}} + +TODO: link to autodocs + +## Dependencies + +There is (optional) support for visualization via [GrapViz](http://graphviz.org). + +## TODO + +* Solidify basic API, guarantees +* Implement more algorithms +* Test & profile more with big, varied graphs +* Multigraphs, hypergraphs, adjacency matrix-based graphs? + +## License + +Copyright (C) 2010 Justin Kramer jkkramer@gmail.com + +Distributed under the Eclipse Public License, the same as Clojure. diff --git a/project.clj b/project.clj new file mode 100644 index 0000000..733a484 --- /dev/null +++ b/project.clj @@ -0,0 +1,11 @@ +(defproject loom "0.1.0-SNAPSHOT" + :description "Graph library for Clojure" + :author "Justin Kramer" + :dependencies [[org.clojure/clojure "1.3.0-master-SNAPSHOT"] + [org.apache.xmlrpc/xmlrpc-client "3.1.3"] + [robert/hooke "1.0.2"] + ;[org.clojure.contrib/priority-map "1.3.0-SNAPSHOT"] + ;[vijual "0.1.0-SNAPSHOT"] + ] + :dev-dependencies [[swank-clojure "1.3.0-SNAPSHOT"]] + :jvm-opts ["-Xmx1g"]) diff --git a/src/loom/alg.clj b/src/loom/alg.clj new file mode 100644 index 0000000..9306a11 --- /dev/null +++ b/src/loom/alg.clj @@ -0,0 +1,234 @@ +(ns ^{:doc "Graph algorithms. Any graph record/type that satisfies the +Graph, Digraph, or WeightedGraph protocols (as appropriate per algorithm) +can use these functions." + :author "Justin Kramer"} + loom.alg + (:require [loom.alg-generic :as gen]) + (:use [loom.graph + :only [add-edges nodes edges neighbors weight incoming degree + in-degree weighted? directed? graph] + :rename {neighbors nb weight wt}] + [loom.alg-generic :only [trace-path]])) + +;;; +;;; Convenience wrappers for loom.alg-generic functions +;;; + +(defn- traverse-all + [nodes traverse] + (second + (reduce + (fn [[seen trav] n] + (if (seen n) + [seen trav] + (let [ctrav (traverse n :seen (conj seen n))] + [(into seen ctrav) (concat ctrav trav)]))) + [#{} []] + nodes))) + +;;TODO: options: :incoming, :when +(defn pre-traverse + "Traverses graph g depth-first from start. Returns a lazy seq of nodes. + When no starting node is provided, traverses the entire graph, connected + or not." + ([g] + (traverse-all (nodes g) (partial gen/pre-traverse (nb g)))) + ([g start] + (gen/pre-traverse (nb g) start))) + +(defn pre-span + "Return a depth-first spanning tree of the form {node [successors]}" + ([g] + (second + (reduce + (fn [[seen span] n] + (if (seen n) + [seen span] + (let [[cspan cseen] (gen/pre-span (nb g) n :seen seen)] + [(clojure.set/union seen cseen) (merge span {n []} cspan)]))) + [#{} {}] + (nodes g)))) + ([g start] + (gen/pre-span (nb g) start))) + +(defn post-traverse + "Traverses graph g depth-first, post-order from start. Returns a + vector of the nodes." + ([g] + (traverse-all (nodes g) (partial gen/post-traverse (nb g)))) + ([g start] + (gen/post-traverse (nb g) start))) + +(defn topsort + "Topological sort of a directed acyclic graph (DAG). Returns nil if + g contains any cycles." + ([g] + (loop [seen #{} + result () + [n & ns] (seq (nodes g))] + (if-not n + result + (if (seen n) + (recur seen result ns) + (when-let [cresult (gen/topsort-component (nb g) n seen seen)] + (recur (into seen cresult) (concat cresult result) ns)))))) + ([g start] + (gen/topsort-component (nb g) start))) + +(defn bf-traverse + "Traverses graph g breadth-first from start. When f is provided, returns + a lazy seq of (f node predecessor-map) for each node traversed. Otherwise, + returns a lazy seq of the nodes." + ([g] + (traverse-all (nodes g) (partial gen/bf-traverse (nb g)))) + ([g start] + (gen/bf-traverse (nb g) start)) + ([g start & {:as opts}] + (apply gen/bf-traverse (nb g) start (apply concat opts)))) + +(defn bf-span + "Return a breadth-first spanning tree of the form {node [successors]}" + ([g] + (second + (reduce + (fn [[seen span] n] + (if (seen n) + [seen span] + (let [cspan (gen/bf-span (nb g) n :seen seen)] + ;; FIXME: very inefficient + [(into seen (concat (keys cspan) (apply concat (vals cspan)))) + (merge span {n []} cspan)]))) + [#{} {}] + (nodes g)))) + ([g start] + (gen/bf-span (nb g) start))) + +(defn bf-path + "Return a path from start to end with the fewest hops (i.e. irrespective + of edge weights)" + [g start end] + (gen/bf-path (nb g) start end)) + +(defn bf-path-bi + "Using a bidirectional breadth-first search, finds a path from start to + end with the fewest hops (i.e. irrespective of edge weights). Can be much + faster than a unidirectional search on certain types of graphs" + [g start end] + (gen/bf-path-bi (nb g) start end)) + +(defn dijkstra-traverse + "Returns a lazy-seq of [current-node state] where state is a map in the + format {node [distance predecessor]}. When f is provided, returns + a lazy-seq of (f node state) for each node" + ([g] + (gen/dijkstra-traverse (nb g) (wt g) (first (nodes g)))) + ([g start] + (gen/dijkstra-traverse (nb g) (wt g) start vector)) + ([g start f] + (gen/dijkstra-traverse (nb g) (wt g) start f))) + +(defn dijkstra-span + "Finds all shortest distances from start. Returns a map in the format + {node {successor distance}}" + ([g] + (gen/dijkstra-span (nb g) (wt g) (first (nodes g)))) + ([g start] + (gen/dijkstra-span (nb g) (wt g) start))) + +(defn dijkstra-path-dist + "Finds the shortest path from start to end. Returns a vector: + [path distance]" + [g start end] + (gen/dijkstra-path-dist (nb g) (wt g) start end)) + +(defn dijkstra-path + "Finds the shortest path from start to end" + [g start end] + (first (dijkstra-path-dist g start end))) + + +;;; +;;; Graph algorithms +;;; + +(defn shortest-path + "Finds the shortest path from start to end in graph g, using Dijkstra's + algorithm if the graph is weighted, breadth-first search otherwise." + [g start end] + (if (weighted? g) + (dijkstra-path g start end) + (bf-path g start end))) + +(defn longest-shortest-path + "Finds the longest shortest path beginning at start, using Dijkstra's + algorithm if the graph is weighted, bread-first search otherwise." + [g start] + (reverse + (if (weighted? g) + (reduce + (fn [path1 [n state]] + (let [path2 (trace-path (comp second state) n)] + (if (< (count path1) (count path2)) path2 path1))) + [start] + (dijkstra-traverse g start vector)) + (reduce + (fn [path1 [n predmap]] + (let [path2 (trace-path predmap n)] + (if (< (count path1) (count path2)) path2 path1))) + [start] + (bf-traverse g start vector))))) + +(defn connected-components + "Return the connected components of undirected graph g as a vector of vectors" + [g] + (first + (reduce + (fn [[cc seen] n] + (if (seen n) + [cc seen] + (let [c (vec (gen/bf-traverse (nb g) n :seen seen))] + [(conj cc c) (into seen c)]))) + [[] #{}] + (nodes g)))) + +;; TODO: weak & strong cc + +(defn connect + "Return graph g with all connected components connected to each other" + [g] + (reduce add-edges g (partition 2 1 (map first (connected-components g))))) + +(defn density + "Return the density of graph g" + [g & {:keys [loops] :or {loops false}}] + (let [order (count (nodes g))] + (/ (count (edges g)) + (* order (if loops + order + (dec order)))))) + +(defn loners + "Return nodes with no connections to other nodes (i.e., isolated nodes)" + [g] + (let [degree-total (if (directed? g) + #(+ (in-degree g %) (degree g %)) + #(degree g %))] + (filter (comp zero? degree-total) (nodes g)))) + +(defn distinct-edges + "Distinct edges of g. Only useful for undirected graphs" + [g] + (if (directed? g) + (edges g) + (second + (reduce + (fn [[seen es] e] + (let [eset (set (take 2 e))] + (if (seen eset) + [seen es] + [(conj seen eset) + (conj es e)]))) + [#{} []] + (edges g))))) + +;; TODO: MST, coloring, bipartite, matching, etc etc \ No newline at end of file diff --git a/src/loom/alg_generic.clj b/src/loom/alg_generic.clj new file mode 100644 index 0000000..f1249d5 --- /dev/null +++ b/src/loom/alg_generic.clj @@ -0,0 +1,289 @@ +(ns ^{:doc "Graph algorithms for use on any type of graph" + :author "Justin Kramer"} + loom.alg-generic + (:use [loom.io.ubigraph :only [call]])) + +;;; +;;; Utility functions +;;; + +(defn trace-path + "Using a map of nodes-to-preds, traces a node's family tree back to the + source. Cycles are not accounted for." + [preds node] + (take-while identity (iterate preds node))) + +(defn preds->span + "Converts a map of the form {node predecessor} to a spanning tree of the + form {node [successors]}" + [preds] + (reduce + (fn [span [n p]] + (if p + (assoc span p (conj (span p []) n)) + span)) + {} preds)) + +;;; +;;; Depth-first traversal +;;; + +(defn pre-traverse + "Traverses a graph depth-first preorder from start, neighbors being a + function that returns adjacent nodes. Returns a lazy seq of nodes." + [neighbors start & {:keys [seen] :or {seen #{start}}}] + (letfn [(step [stack seen] + (when-let [node (peek stack)] + (cons + node + (lazy-seq + (let [nbrs (remove seen (neighbors node))] + (step (into (pop stack) nbrs) + (into seen nbrs)))))))] + (step [start] + seen))) + +(defn pre-span + "Return a depth-first spanning tree of the form {node [successors]}" + [neighbors start & {:keys [seen]}] + (let [seen-start seen] + (loop [seen (or seen-start #{}) + preds {start nil} + stack [start]] + (if (empty? stack) + (if seen-start + [(preds->span preds) seen] + (preds->span preds)) + (let [v (peek stack) + seen (conj seen v)] + (if-let [u (first (remove seen (neighbors v)))] + (recur seen (assoc preds u v) (conj stack u)) + (recur seen preds (pop stack)))))))) + +(defn post-traverse + "Traverses a graph depth-first postorder from start, neighbors being a + function that returns adjacent nodes. Returns a vector" + [neighbors start & {:keys [seen] :or {seen #{}}}] + ;; For most graphs, being lazy wouldn't matter + (loop [seen seen + result [] + stack [start]] + (if (empty? stack) + result + (let [v (peek stack) + seen (conj seen v) + nbrs (remove seen (neighbors v))] + (if (empty? nbrs) + (recur seen (conj result v) (pop stack)) + (recur seen result (conj stack (first nbrs)))))))) + +(defn topsort-component + "Topological sort of a component of a (presumably) directed graph. + Returns nil if the graph contains any cycles. See loom.alg/topsort + for a complete topological sort" + ([neighbors start] + (topsort-component neighbors start #{} #{})) + ([neighbors start seen explored] + (loop [seen seen + explored explored + result () + stack [start]] + (if (empty? stack) + result + (if (explored (peek stack)) + (recur seen explored result (pop stack)) + (let [v (peek stack) + seen (conj seen v) + us (remove explored (neighbors v))] + (if (seq us) + (when-not (some seen us) + (recur seen explored result (into stack us))) + (recur seen (conj explored v) (conj result v) (pop stack))))))))) + +;;; +;;; Breadth-first traversal +;;; + +;; TODO: depth limiter +;; TODO: per-level filters a la gremlin? + +(defn bf-traverse + "Traverses a graph breadth-first from start, neighbors being a + function that returns adjacent nodes. When f is provided, returns + a lazy seq of (f node predecessor-map) for each node traversed. Otherwise, + returns a lazy seq of the nodes." + [neighbors start & {:keys [f seen] :or {f (fn [n p] n)}}] + (letfn [(step [queue preds] + (when-let [node (peek queue)] + (let [nbrs (remove #(contains? preds %) (neighbors node))] + (cons (f node preds) + (lazy-seq + (step (into (pop queue) nbrs) + (reduce #(assoc %1 %2 node) preds nbrs)))))))] + (step (conj clojure.lang.PersistentQueue/EMPTY start) + (if seen + (into {start nil} (for [s seen] [s nil])) + {start nil})))) + +(defn bf-span + "Return a breadth-first spanning tree of the form {node [successors]}" + [neighbors start & {:keys [seen]}] + (preds->span + (bf-traverse neighbors start + :f (fn [n pm] [n (pm n)]) + :seen seen))) + +(defn bf-path + "Return a path from start to end with the fewest hops (i.e. irrespective + of edge weights), neighbors being a function that returns adjacent nodes" + [neighbors start end] + (when-let [preds (some (fn [[_ p]] (when (p end) p)) + (bf-traverse neighbors start :f vector))] + (reverse (trace-path preds end)))) + +(defn- shared-keys + "Return a lazy-seq of the keys that exist in both m1 and m2" + [m1 m2] + (if (< (count m2) (count m1)) + (recur m2 m1) + (filter (partial contains? m2) (keys m1)))) + +(defn bf-path-bi + "Using a bidirectional breadth-first search, finds a path from start to + end with the fewest hops (i.e. irrespective of edge weights), neighbors + being a function which returns adjacent nodes. Can be much faster than + a unidirectional search on certain types of graphs" + [neighbors start end] + ;; TODO: make this work better with directed graphs using incoming fn + (let [done? (atom false) + preds1 (atom {}) + preds2 (atom {}) + find-intersect #(first (shared-keys @preds1 @preds2)) + search (fn [n preds] + (dorun + (take-while + (fn [_] (not @done?)) + (bf-traverse neighbors n :f #(reset! preds %2))))) + search1 (future (search start preds1)) + search2 (future (search end preds2))] + (loop [intersect (find-intersect)] + (if (or intersect (future-done? search1)) ;; (future-done? search2) + (do + (reset! done? true) + (cond + intersect (concat + (reverse (trace-path @preds1 intersect)) + (rest (trace-path @preds2 intersect))) + (@preds1 end) (reverse (trace-path @preds1 end)) + (@preds2 start) (trace-path @preds2 start))) + (recur (find-intersect)))))) + +;;; +;;; Dijkstra +;;; + +(defn dijkstra-traverse + "Returns a lazy-seq of [current-node state] where state is a map in the + format {node [distance predecessor]}. When f is provided, returns + a lazy-seq of (f node state) for each node" + ([neighbors dist start] + (dijkstra-traverse neighbors dist start vector)) + ([neighbors dist start f] + (letfn [(step [[state pq]] + (when-let [[dist-su _ u :as fpq] (first pq)] + (cons + (f u state) + (lazy-seq + (step + (reduce + (fn [[state pq] v] + (let [dist-suv (+ dist-su (dist u v)) + dist-sv (first (state v))] + (if (and dist-sv (>= dist-suv dist-sv)) + [state pq] + (let [pq (if dist-sv + (disj pq [dist-sv (hash v) v]) + pq)] + [(assoc state v [dist-suv u]) + (conj pq [dist-suv (hash v) v])])))) + [state (disj pq fpq)] + (neighbors u)))))))] + (step [{start [0 nil]} + ;; Poor man's priority queue. Caveats: + ;; 1) Have to keep it in sync with current state + ;; 2) Have to include hash codes for non-Comparable items + ;; 3) O(logn) operations + ;; Tried clojure.contrib.priority-map but it wasn't any faster + (sorted-set [0 (hash start) start])])))) + +(defn dijkstra-span + "Finds all shortest distances from start, where neighbors and dist + are functions called as (neighbors node) and (dist node1 node2). + Returns a map in the format {node {successor distance}}" + [neighbors dist start] + (reduce + (fn [span [n [d p]]] + (if p + (assoc-in span [p n] d) + span)) + {} + (second (last (dijkstra-traverse neighbors dist start))))) + +(defn dijkstra-path-dist + "Finds the shortest path from start to end, where neighbors and dist + are functions called as (neighbors node) and (dist node1 node2). + Returns a vector: [path distance]" + [neighbors dist start end] + (if-let [[_ end-state] (first (filter + (fn [[node _]] (= end node)) + (dijkstra-traverse neighbors dist start)))] + [(reverse (trace-path (comp second end-state) end)) + (first (end-state end))])) + +(defn dijkstra-path + "Finds the shortest path from start to end, where neighbors and dist + are functions called as (neighbors node) and (dist node1 node2)" + [neighbors dist start end] + (first (dijkstra-path-dist neighbors dist start end))) + +;; FIXME: Research proper way to do this +#_(defn dijkstra-path-dist-bi + "Finds a path -- not necessarily the shortest -- from start to end + birectionally, where neighbors and dist are functions called as + (neighbors node) and (dist node1 node2). Returns a vector: [path distance]" + [neighbors dist start end] + ;; TODO: make this work better with directed graphs (incoming fn) + (let [done? (atom false) + processed1 (atom #{}) + processed2 (atom #{}) + state1 (atom nil) + state2 (atom nil) + find-intersect (fn [] (some #(when (@processed1 %) %) @processed2)) + search (fn [n processed state] + (dorun + (take-while + (fn [_] (not @done?)) + (dijkstra-traverse neighbors dist n + #(do + (swap! processed conj %1) + (reset! state %2)))))) + search1 (future (search start processed1 state1)) + search2 (future (search end processed2 state2))] + (loop [intersect (find-intersect)] + (if (or intersect (future-done? search1)) + (do + (prn intersect) + (reset! done? true) + (cond + intersect [(concat + (reverse (trace-path (comp second @state1) intersect)) + (rest (trace-path (comp second @state2) intersect))) + (+ (first (@state1 intersect)) + (first (@state2 intersect)))] + (@state1 end) [(reverse (trace-path (comp second @state1) end)) + (first (@state1 end))] + (@state2 start) [(trace-path (comp second @state2) start) + (first (@state2 start))])) + + (recur (find-intersect)))))) + diff --git a/src/loom/attr.clj b/src/loom/attr.clj new file mode 100644 index 0000000..6682c6f --- /dev/null +++ b/src/loom/attr.clj @@ -0,0 +1,136 @@ +(ns ^{:doc "Graph attribute protocol and implementations for records from +loom.graph. Common uses for attributes include labels and styling (color, +thickness, etc)." + :author "Justin Kramer"} + loom.attr + (use [loom.graph :only [directed? nodes edges]]) + (:import [loom.graph SimpleGraph SimpleDigraph + SimpleWeightedGraph SimpleWeightedDigraph + FlyGraph FlyDigraph WeightedFlyGraph WeightedFlyDigraph])) + +(defprotocol AttrGraph + (add-attr [g node k v] [g n1 n2 k v] "Add an attribute to node or edge") + (remove-attr [g node k] [g n1 n2 k] "Remove an attribute from a node or edge") + (attr [g node k] [g n1 n2 k] "Return the attribute on a node or edge") + (attrs [g node] [g n1 n2] "Return all attributes on a node or edge")) + +(def default-attr-graph-impl + {:add-attr (fn + ([g node k v] + (assoc-in g [:attrs node k] v)) + ([g n1 n2 k v] + (let [g (assoc-in g [:attrs n1 ::edge-attrs n2 k] v) + g (if (directed? g) g + (assoc-in g [:attrs n2 ::edge-attrs n1 k] v))] + g))) + :remove-attr (fn + ([g node k] + (update-in g [:attrs node] dissoc k)) + ([g n1 n2 k] + (update-in g [:attrs n1 ::edge-attrs n2] dissoc k))) + :attr (fn + ([g node k] + (get-in g [:attrs node k])) + ([g n1 n2 k] + (get-in g [:attrs n1 ::edge-attrs n2 k]))) + :attrs (fn + ([g node] + (dissoc (get-in g [:attrs node]) ::edge-attrs)) + ([g n1 n2] + (get-in g [:attrs n1 ::edge-attrs n2])))}) + +(extend SimpleGraph + AttrGraph + default-attr-graph-impl) + +(extend SimpleDigraph + AttrGraph + default-attr-graph-impl) + +(extend SimpleWeightedGraph + AttrGraph + default-attr-graph-impl) + +(extend SimpleWeightedDigraph + AttrGraph + default-attr-graph-impl) + +(extend FlyGraph + AttrGraph + default-attr-graph-impl) + +(extend FlyDigraph + AttrGraph + default-attr-graph-impl) + +(extend WeightedFlyGraph + AttrGraph + default-attr-graph-impl) + +(extend WeightedFlyDigraph + AttrGraph + default-attr-graph-impl) + +(defn attr? + "Return true if g satisfies AttrGraph" + [g] + (satisfies? AttrGraph g)) + +(defn add-attr-to-nodes + "Adds an attribute to the given nodes" + [g k v nodes] + (reduce + (fn [g n] + (add-attr g n k v)) + g nodes)) + +(defn add-attr-to-edges + "Adds an attribute to the given nodes" + [g k v edges] + (reduce + (fn [g [n1 n2]] + (add-attr g n1 n2 k v)) + g edges)) + +(defn add-attr-to-all + "Adds an attribute to all nodes and edges" + [g k v] + (-> g + (add-attr-to-nodes k v (nodes g)) + (add-attr-to-edges k v (edges g)))) + +(defn add-attrs-to-all + "Adds attributes to all nodes and edges" + [g & kvs] + (reduce + (fn [g [k v]] + (-> g + (add-attr-to-nodes k v (nodes g)) + (add-attr-to-edges k v (edges g)))) + g (partition 2 1 kvs))) + + +(defn hilite + "Adds a red :color attribute to a node or edge" + ([g node] + (-> g + (add-attr node :color :red) + (add-attr node :fontcolor :red) + (add-attr node :fillcolor "#ffeeee") + (add-attr node :style "filled,bold"))) + ([g n1 n2] + (-> g + (add-attr n1 n2 :color :red) + (add-attr n1 n2 :fontcolor :red) + (add-attr n1 n2 :style :bold)))) + +(defn hilite-path + "Hilites nodes and edges along a path" + [g path] + (reduce + (fn [g [n1 n2]] + (-> g + (hilite n1) + (hilite n2) + (hilite n1 n2))) + g (partition 2 1 path))) \ No newline at end of file diff --git a/src/loom/gen.clj b/src/loom/gen.clj new file mode 100644 index 0000000..fe8bfb5 --- /dev/null +++ b/src/loom/gen.clj @@ -0,0 +1,54 @@ +(ns ^{:doc "Graph-generating functions" + :author "Justin Kramer"} + loom.gen + (:use [loom.graph :only [weighted? directed? add-nodes* add-edges*]])) + +(defn gen-rand + "Adds num-nodes nodes and approximately num-edges edges to graph g. Nodes + used for each edge are chosen at random and may be chosen more than once." + [g num-nodes num-edges & {:keys [min-weight max-weight loops seed] + :or {min-weight 1 + max-weight 1 + loops false + seed (System/nanoTime)}}] + (let [rnd (java.util.Random. seed) + rand-w #(+ (.nextInt rnd (- max-weight min-weight)) min-weight) + rand-n #(.nextInt rnd num-nodes) + weighted? (weighted? g) + nodes (range num-nodes) + edges (for [_ (range num-edges) + :let [n1 (rand-n) n2 (rand-n)] + :when (or loops (not= n1 n2))] + (if weighted? + [n1 n2 (rand-w)] + [n1 n2]))] + (-> g + (add-nodes* nodes) + (add-edges* edges)))) + +(defn gen-rand-p + "Adds num-nodes nodes to graph g with the probably p of an edge between + each node." + [g num-nodes p & {:keys [min-weight max-weight loops seed] + :or {min-weight 1 + max-weight 1 + loops false + seed (System/nanoTime)}}] + (let [rnd (java.util.Random. seed) + rand-w #(+ (.nextInt rnd (- max-weight min-weight)) min-weight) + directed? (directed? g) + weighted? (weighted? g) + nodes (range num-nodes) + edges (for [n1 nodes n2 nodes + :when (and (if directed? + (or loops (not= n1 n2)) + (or (> n1 n2) + (and loops (= n1 n2)))) + (> p (.nextDouble rnd)))] + (if weighted? + [n1 n2 (rand-w)] + [n1 n2]))] + (-> g + (add-nodes* nodes) + (add-edges* edges)))) + diff --git a/src/loom/graph.clj b/src/loom/graph.clj new file mode 100644 index 0000000..a780061 --- /dev/null +++ b/src/loom/graph.clj @@ -0,0 +1,459 @@ +(ns ^{:doc "Defines protocols for graphs, digraphs, and weighted graphs. + +Also provides record implementations and constructors for simple graphs -- +weighted, unweighted, directed, and undirected. The implementations are based +on adjacency lists." + :author "Justin Kramer"} + loom.graph + (:use [loom.alg-generic :only [bf-traverse]])) + +;(set! *warn-on-reflection* true) + +;;; +;;; Protocols +;;; + +(defprotocol Graph + (add-nodes* [g nodes] "Add nodes to graph g. See add-nodes") + (add-edges* [g edges] "Add edges to graph g. See add-edges") + (remove-nodes* [g nodes] "Remove nodes from graph g. See remove-nodes") + (remove-edges* [g edges] "Removes edges from graph g. See remove-edges") + (remove-all [g] "Removes all nodes and edges from graph g") + (nodes [g] "Return a collection of the nodes in graph g") + (edges [g] "Edges in g. May return each edge twice in an undirected graph") + (has-node? [g node] "Return true when node is in g") + (has-edge? [g n1 n2] "Return true when edge [n1 n2] is in g") + (neighbors [g] [g node] "Return adjacent nodes, or (partial neighbors g)") + (degree [g node] "Return the number of nodes adjacent to node")) + +(defprotocol Digraph + (incoming [g node] "Return direct predecessors of node") + (in-degree [g node] "Return the number direct predecessors to node") + (transpose [g] "Return a graph with all edges reversed")) + +(defprotocol WeightedGraph + (weight [g] [g n1 n2] "Return weight of edge [n1 n2] or (partial weight g)")) + +;; Variadic wrappers + +(defn add-nodes + "Add nodes to graph g. Nodes can be any type of object" + [g & nodes] + (add-nodes* g nodes)) + +(defn add-edges + "Add edges to graph g. For unweighted graphs, edges take the form [n1 n2]. + For weighted graphs, edges take the form [n1 n2 weight] or [n1 n2], the + latter defaulting to a weight of 1" + [g & edges] + (add-edges* g edges)) + +(defn remove-nodes + "Remove nodes from graph g" + [g & nodes] + (remove-nodes* g nodes)) + +(defn remove-edges + "Remove edges from graph g. Do not include weights" + [g & edges] + (remove-edges* g edges)) + +;;; +;;; Records for simple graphs -- one edge per vertex pair/direction, +;;; loops allowed +;;; +;; TODO: allow custom weight fn? + +(defrecord SimpleGraph [nodeset adj]) +(defrecord SimpleDigraph [nodeset adj in]) +(defrecord SimpleWeightedGraph [nodeset adj]) +(defrecord SimpleWeightedDigraph [nodeset adj in]) + +(def ^{:doc "Weight used when none is given for edges in weighted graphs"} + *default-weight* 1) + +(def default-graph-impls + {:all + {:nodes (fn [g] + (:nodeset g)) + :edges (fn [g] + (for [n1 (nodes g) + n2 (neighbors g n1)] + [n1 n2])) + :has-node? (fn [g node] + (contains? (:nodeset g) node)) + :has-edge? (fn [g n1 n2] + (contains? (get-in g [:adj n1]) n2)) + :degree (fn [g node] + (count (get-in g [:adj node])))} + + ;; Unweighted graphs store adjacencies as {node #{neighbor}} + :unweighted + {:add-nodes* (fn [g nodes] + (reduce + (fn [g n] + (-> g + (update-in [:nodeset] conj n) + (assoc-in [:adj n] (or ((:adj g) n) #{})))) + g nodes)) + :neighbors (fn + ([g] (partial neighbors g)) + ([g node] (get-in g [:adj node])))} + + ;; Weighted graphs store adjacencies as {node {neighbor weight}} + :weighted + {:add-nodes* (fn [g nodes] + (reduce + (fn [g n] + (-> g + (update-in [:nodeset] conj n) + (assoc-in [:adj n] (or ((:adj g) n) {})))) + g nodes)) + :neighbors (fn + ([g] (partial neighbors g)) + ([g node] (keys (get-in g [:adj node]))))}}) + +(def default-digraph-impl + {:incoming (fn [g node] + (get-in g [:in node])) + :in-degree (fn [g node] + (count (get-in g [:in node])))}) + +(def default-weighted-graph-impl + {:weight (fn + ([g] (partial weight g)) + ([g n1 n2] (get-in g [:adj n1 n2])))}) + +(defn- remove-adj-nodes [m nodes adjacents remove-fn] + (reduce + (fn [m n] + (if (m n) + (update-in m [n] #(apply remove-fn % nodes)) + m)) + (apply dissoc m nodes) + adjacents)) + +(extend SimpleGraph + Graph + (assoc (apply merge (map default-graph-impls [:all :unweighted])) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:nodeset] conj n1 n2) + (update-in [:adj n1] (fnil conj #{}) n2) + (update-in [:adj n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [nbrs (mapcat #(neighbors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] disj n2) + (update-in [:adj n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {})))) + +(extend SimpleDigraph + Graph + (assoc (apply merge (map default-graph-impls [:all :unweighted])) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:nodeset] conj n1 n2) + (update-in [:adj n1] (fnil conj #{}) n2) + (update-in [:in n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [ins (mapcat #(incoming g %) nodes) + outs (mapcat #(neighbors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes ins disj)) + (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] disj n2) + (update-in [:in n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {} :in {}))) + + Digraph + (assoc default-digraph-impl + :transpose (fn [g] + (assoc g :adj (:in g) :in (:adj g))))) + +(extend SimpleWeightedGraph + Graph + (assoc (apply merge (map default-graph-impls [:all :weighted])) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2 & [w]]] + (-> g + (update-in [:nodeset] conj n1 n2) + (assoc-in [:adj n1 n2] (or w *default-weight*)) + (assoc-in [:adj n2 n1] (or w *default-weight*)))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [nbrs (mapcat #(neighbors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs dissoc))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] dissoc n2) + (update-in [:adj n2] dissoc n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {}))) + + WeightedGraph + default-weighted-graph-impl) + +(extend SimpleWeightedDigraph + Graph + (assoc (apply merge (map default-graph-impls [:all :weighted])) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2 & [w]]] + (-> g + (update-in [:nodeset] conj n1 n2) + (assoc-in [:adj n1 n2] (or w *default-weight*)) + (update-in [:in n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [ins (mapcat #(incoming g %) nodes) + outs (mapcat #(neighbors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes ins dissoc)) + (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] dissoc n2) + (update-in [:in n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {}) :in {})) + + Digraph + (assoc default-digraph-impl + :transpose (fn [g] + (reduce (fn [tg [n1 n2]] + (add-edges* tg [[n2 n1 (weight g n1 n2)]])) + (assoc g :adj {} :in {}) + (edges g)))) + + WeightedGraph + default-weighted-graph-impl) + +;;; +;;; FlyGraph -- a read-only, ad-hoc graph which uses provided functions to +;;; return values for nodes, edges, etc. Members which are not functions get +;;; returned as-is. Edges will be inferred if nodes and neighbors are provided. +;;; Nodes and edges will be inferred if neighbors and start are provided. +;;; + +(defn- call-or-return [f & args] + (if (or (fn? f) + (and (instance? clojure.lang.IFn f) (seq args))) + (apply f args) + f)) + +(def ^{:private true} default-flygraph-graph-impl + {:nodes (fn [g] + (if (or (:fnodes g) (not (:start g))) + (call-or-return (:fnodes g)) + (bf-traverse (neighbors g) (:start g)))) + :edges (fn [g] + (if (:fedges g) + (call-or-return (:fedges g)) + (for [n (nodes g) + nbr (neighbors g n)] + [n nbr]))) + :neighbors (fn + ([g] (partial neighbors g)) + ([g node] (call-or-return (:fneighbors g) node)))}) + +(def ^{:private true} default-flygraph-digraph-impl + {:incoming (fn [g node] (call-or-return (:fincoming g) node))}) + +(def ^{:private true} default-flygraph-weighted-impl + {:weight (fn [g n1 n2] (call-or-return (:fweight g) n1 n2))}) + +(defrecord FlyGraph [fnodes fedges fneighbors start]) +(defrecord FlyDigraph [fnodes fedges fneighbors fincoming start]) +(defrecord WeightedFlyGraph [fnodes fedges fneighbors fweight start]) +(defrecord WeightedFlyDigraph [fnodes fedges fneighbors fincoming fweight start]) + +(extend FlyGraph + Graph default-flygraph-graph-impl) + +(extend FlyDigraph + Graph default-flygraph-graph-impl + Digraph default-flygraph-digraph-impl) + +(extend WeightedFlyGraph + Graph default-flygraph-graph-impl + WeightedGraph default-flygraph-weighted-impl) + +(extend WeightedFlyDigraph + Graph default-flygraph-graph-impl + Digraph default-flygraph-digraph-impl + WeightedGraph default-flygraph-weighted-impl) + +;;; +;;; Utility functions and constructors +;;; + +;; TODO: make this work with read-only graphs? +;; Could also gain speed being impl-specific +(defn subgraph + "Return a graph without all but the given nodes" + [g ns] + (remove-nodes* g (filter (complement (set ns)) (nodes g)))) + +(defn add-path + "Add a path of edges connecting the given nodes in order" + [g & nodes] + (add-edges* g (partition 2 1 nodes))) + +(defn add-cycle + "Add a cycle of edges connecting the given nodes in order" + [g & nodes] + (add-edges* g (partition 2 1 (concat nodes [(first nodes)])))) + +(defn graph? + "Return true if g satisfies the Graph protocol" + [g] + (satisfies? Graph g)) + +(defn directed? + "Return true if g satisfies the Digraph protocol" + [g] + (satisfies? Digraph g)) + +(defn weighted? + "Return true if g satisfies the WeightedGraph protocol" + [g] + (satisfies? WeightedGraph g)) + +(defn build-graph + "Builds up a graph (i.e. adds edges and nodes) from any combination of + other graphs, adjacency maps, edges, or nodes." + [g & inits] + (letfn [(build [g init] + (cond + ;; graph + (graph? init) + (if (and (weighted? g) (weighted? init)) + (reduce add-edges + (add-nodes* g (nodes init)) + (for [[n1 n2] (edges init)] + [n1 n2 (weight init n1 n2)])) + (-> g + (add-nodes* (nodes init)) + (add-edges* (edges init)))) + ;; adacency map + (map? init) + (let [es (if (map? (val (first init))) + (for [[n nbrs] init + [nbr wt] nbrs] + [n nbr wt]) + (for [[n nbrs] init + nbr nbrs] + [n nbr]))] + (-> g + (add-nodes* (keys init)) + (add-edges* es))) + ;; edge + (sequential? init) (add-edges g init) + ;; node + :else (add-nodes g init)))] + (reduce build g inits))) + +(defn graph + "Create an unweighted, undirected graph. inits can be edges, adjacency maps, + or graphs" + [& inits] + (apply build-graph (SimpleGraph. #{} {}) inits)) + +(defn digraph + "Create an unweighted, directed graph. inits can be edges, adjacency maps, + or graphs" + [& inits] + (apply build-graph (SimpleDigraph. #{} {} {}) inits)) + +(defn weighted-graph + [& inits] + "Create an weighted, undirected graph. inits can be edges, adjacency maps, + or graphs" + (apply build-graph (SimpleWeightedGraph. #{} {}) inits)) + +(defn weighted-digraph + "Create an weighted, directed graph. inits can be edges, adjacency maps, + or graphs" + [& inits] + (apply build-graph (SimpleWeightedDigraph. #{} {} {}) inits)) + +(defn fly-graph + "Create a read-only, ad-hoc graph which uses the provided functions + to return values for nodes, edges, etc. If any members are not functions, + they will be returned as-is. Edges will be inferred if nodes and + neighbors are provided. Nodes and edges will be inferred if neighbors and + start are provided." + [& {:keys [nodes edges neighbors incoming weight start]}] + (cond + (and incoming weight) + (WeightedFlyDigraph. nodes edges neighbors incoming weight start) + incoming + (FlyDigraph. nodes edges neighbors incoming start) + weight + (WeightedFlyGraph. nodes edges neighbors weight start) + :else + (FlyGraph. nodes edges neighbors start))) diff --git a/src/loom/io.clj b/src/loom/io.clj new file mode 100644 index 0000000..e72ade6 --- /dev/null +++ b/src/loom/io.clj @@ -0,0 +1,140 @@ +(ns ^{:doc "Output and view graphs in various formats" + :author "Justin Kramer"} + loom.io + (:use [loom.graph :only [directed? weighted? nodes edges weight]] + [loom.alg :only [distinct-edges loners]] + [loom.attr :only [attr? attr attrs]] + [clojure.string :only [escape]] + [clojure.java [io :only [file]] [shell :only [sh]]]) + (:import [org.apache.xmlrpc.client XmlRpcClient XmlRpcClientConfigImpl] + [org.apache.xmlrpc XmlRpcException])) + +(defn- dot-esc + [s] + (escape s {\" "\\\"" \newline "\\n"})) + +(defn- dot-attrs + [attrs] + (when (seq attrs) + (let [sb (StringBuilder. "[")] + (doseq [[k v] attrs] + (when (pos? (.length (str v))) + (when (< 1 (.length sb)) + (.append sb \,)) + (doto sb + (.append \") + (.append (dot-esc (if (keyword? k) (name k) (str k)))) + (.append "\"=\"") + (.append (dot-esc (if (keyword? v) (name v) (str v)))) + (.append \")))) + (.append sb "]") + (str sb)))) + +(defn dot-str + "Render graph g as a DOT-format string. Calls (node-label node) and + (edge-label n1 n2) to determine what labels to use for nodes and edges, + if any. Will detect graphs that satisfy AttrGraph and include attributes, + too." + [g & {:keys [graph-name node-label edge-label] + :or {graph-name "graph"} :as opts }] + (let [node-label (if node-label node-label + (if (attr? g) + #(attr g % :label) (constantly nil))) + edge-label (if edge-label edge-label + (if (attr? g) + #(attr g %1 %2 :label) (constantly nil))) + d? (directed? g) + w? (weighted? g) + sb (doto (StringBuilder. + (if d? "digraph \"" "graph \"")) + (.append (dot-esc graph-name)) + (.append "\" {\n"))] + (when (:graph opts) + (doto sb + (.append " graph ") + (.append (dot-attrs (:graph opts))))) + (doseq [[n1 n2] (distinct-edges g)] + (let [n1l (str (or (node-label n1) n1)) + n2l (str (or (node-label n2) n2)) + el (if w? (weight g n1 n2) (edge-label n1 n2)) + eattrs (assoc (if (attr? g) + (attrs g n1 n2) {}) + :label el)] + (doto sb + (.append " \"") + (.append (dot-esc n1l)) + (.append (if d? "\" -> \"" "\" -- \"")) + (.append (dot-esc n2l)) + (.append \")) + (when (or (:label eattrs) (< 1 (count eattrs))) + (.append sb \space) + (.append sb (dot-attrs eattrs))) + (.append sb "\n"))) + (doseq [n (nodes g)] + (doto sb + (.append " \"") + (.append (dot-esc (str (or (node-label n) n)))) + (.append \")) + (when-let [nattrs (when (attr? g) + (dot-attrs (attrs g n)))] + (.append sb \space) + (.append sb nattrs)) + (.append sb "\n")) + (str (doto sb (.append "}"))))) + +(defn dot + "Writes graph g to f (string or File) in DOT format. args passed to dot-str" + [g f & args] + (spit (str (file f)) (apply dot-str g args))) + +(defn- os [] + "Returns :win, :mac, :unix, or nil" + (condp + #(<= 0 (.indexOf %2 %1)) + (.toLowerCase (System/getProperty "os.name")) + "win" :win + "mac" :mac + "nix" :unix + "nux" :unix + nil)) + +(defn- open + "Open the given file (a string, File, or file URI) in the default + application for the current desktop environment. Returns nil" + [f] + (let [f (file f)] + ;; There's an 'open' method in java.awt.Desktop but it hangs on Windows + ;; using Clojure Box and turns the process into a GUI process on Max OS X. + ;; Maybe it's ok for Linux? + (do + (condp = (os) + :mac (sh "open" (str f)) + :win (sh "cmd" (str "/c start " (-> f .toURI .toURL str))) + :else (sh "xdg-open" (str f))) + nil))) + +(defn- open-data + "Write the given data (string or bytes) to a temporary file with the + given extension (string or keyword, with or without the dot) and then open + it in the default application for that extension in the current desktop + environment. Returns nil" + [data ext] + (let [ext (name ext) + ext (if (= \. (first ext)) ext (str \. ext)) + tmp (java.io.File/createTempFile (subs ext 1) ext)] + (with-open [w (if (string? data) + (java.io.FileWriter. tmp) + (java.io.FileOutputStream. tmp))] + (.write w data)) + (open tmp))) + +(defn view + "Converts graph g to a temporary PNG file using GraphViz and opens it + in the current desktop environment's default viewer for PNG files. + Requires GraphViz's 'dot' (or a specified algorithm) to be installed in + the shell's path. Possible algorithms include :dot, :neato, :fdp, :sfdp, + :twopi, and :circo" + [g & {:keys [alg] :or {alg "dot"} :as opts}] + (let [dot (apply dot-str g (apply concat opts)) + {png :out} (sh (name alg) "-Tpng" :in dot :out-enc :bytes)] + (open-data png :png))) diff --git a/src/loom/io/ubigraph.clj b/src/loom/io/ubigraph.clj new file mode 100644 index 0000000..ab37b96 --- /dev/null +++ b/src/loom/io/ubigraph.clj @@ -0,0 +1,56 @@ +(ns ^{:doc "API for Ubigraph" + :author "Justin Kramer"} + loom.io.ubigraph + (:use [loom.graph :only [add-nodes* add-edges*]] + [loom.alg-generic :only [trace-path]] + [robert.hooke :only [add-hook]]) + (:import [org.apache.xmlrpc.client XmlRpcClient XmlRpcClientConfigImpl] + [org.apache.xmlrpc XmlRpcException])) + +(def ^{:private true} client + (let [config (doto (XmlRpcClientConfigImpl.) + (.setServerURL (java.net.URL. "http://127.0.0.1:20738/RPC2")))] + (doto (XmlRpcClient.) + (.setConfig config)))) + +(defn call [op & args] + "Executes a Ubigraph operation via XML-RPC" + (try + (.execute client (str "ubigraph." (name op)) args) + (catch Exception e (throw (RuntimeException. e))))) + +(def node->id (atom {})) +(def edge->id (atom {})) + +(defn clear + [] + (call :clear) + (reset! node->id {}) + (reset! edge->id {})) + +(defn hook + "Hooks the Graph protocol functions into Ubigraph" + [] + (letfn [(show-nodes [nodes] + (doseq [n nodes] + (when-not (@node->id n) + (let [id (call :new_vertex)] + (swap! node->id assoc n (Integer. id))))))] + (alter-var-root + #'add-nodes* + (fn [f] + (fn [g nodes] + (show-nodes nodes) + (f g nodes)))) + (alter-var-root + #'add-edges* + (fn [f] + (fn [g edges] + (doseq [[n1 n2] edges] + (when-not (@node->id n1) + (show-nodes [n1])) + (when-not (@node->id n2) + (show-nodes [n2])) + (call :new_edge (@node->id n1) (@node->id n2)) + (f g edges))))))) + diff --git a/src/loom/label.clj b/src/loom/label.clj new file mode 100644 index 0000000..a7543f8 --- /dev/null +++ b/src/loom/label.clj @@ -0,0 +1,66 @@ +(ns ^{:doc "Graph label protocol and implementations for records from loom.graph" + :author "Justin Kramer"} + loom.label + (:use [loom.attr :only [add-attr remove-attr attr]]) + (:import [loom.graph SimpleGraph SimpleDigraph + SimpleWeightedGraph SimpleWeightedDigraph + FlyGraph FlyDigraph WeightedFlyGraph WeightedFlyDigraph])) + +(defprotocol LabeledGraph + (add-label [g node label] [g n1 n2 label] "Add a label to node or edge") + (remove-label [g node] [g n1 n2] "Remove a label from a node or edge") + (label [g node] [g n1 n2] "Return the label on a node or edge")) + +(def default-labeled-graph-impl + {:add-label (fn + ([g node label] + (add-attr g node :label label)) + ([g n1 n2 label] + (add-attr g n1 n2 :label label))) + :remove-label (fn + ([g node] + (remove-attr g node :label)) + ([g n1 n2] + (remove-attr g n1 n2 :label))) + :label (fn + ([g node] + (attr g node :label)) + ([g n1 n2] + (attr g n1 n2 :label)))}) + +(extend SimpleGraph + LabeledGraph + default-labeled-graph-impl) + +(extend SimpleDigraph + LabeledGraph + default-labeled-graph-impl) + +(extend SimpleWeightedGraph + LabeledGraph + default-labeled-graph-impl) + +(extend SimpleWeightedDigraph + LabeledGraph + default-labeled-graph-impl) + +(extend FlyGraph + LabeledGraph + default-labeled-graph-impl) + +(extend FlyDigraph + LabeledGraph + default-labeled-graph-impl) + +(extend WeightedFlyGraph + LabeledGraph + default-labeled-graph-impl) + +(extend WeightedFlyDigraph + LabeledGraph + default-labeled-graph-impl) + +(defn labeled? + "Return true if g satisfies LabeledGraph" + [g] + (satisfies? LabeledGraph g)) \ No newline at end of file diff --git a/src/loom/multigraph.clj b/src/loom/multigraph.clj new file mode 100644 index 0000000..503c895 --- /dev/null +++ b/src/loom/multigraph.clj @@ -0,0 +1,5 @@ +(ns ^{:doc "Multigraph record" + :author "Justin Kramer"} + loom.multigraph) + +;; TODO \ No newline at end of file diff --git a/test/loom/test/alg.clj b/test/loom/test/alg.clj new file mode 100644 index 0000000..0b485f1 --- /dev/null +++ b/test/loom/test/alg.clj @@ -0,0 +1,102 @@ +(ns loom.test.alg + (:use [loom.graph] :reload) + (:use [loom.alg] + [clojure.test])) + +;; http://en.wikipedia.org/wiki/Dijkstra's_algorithm +(def g1 + (weighted-graph + [1 2 7] [1 3 9] [1 6 14] [2 3 10] [2 4 15] + [3 4 11] [3 6 2] [4 5 6] [5 6 9])) + +;; http://www.algolist.com/Dijkstra's_algorithm +(def g2 + (weighted-graph + [:r :g 10] [:r :b 5] [:r :o 8] [:g :b 3] [:b :p 7] [:p :o 2])) + +;; http://fr.wikipedia.org/wiki/Algorithme_de_Dijkstra +(def g4 + (weighted-graph + [:a :b 85] + [:b :f 80] + [:f :i 250] + [:i :j 84] + [:a :c 217] + [:c :g 186] + [:c :h 103] + [:d :h 183] + [:h :j 167] + [:a :e 173] + [:e :j 502])) + +;; Algorithm Design Manual +(def g5 + (digraph {:a [:b :c] + :b [:c :d] + :c [:e :f] + :d [] + :e [:d] + :f [:e] + :g [:a :f]})) + +(def g6 (graph [0 1] [1 2] [1 3] [2 4] [3 4] [0 5])) + +(def g7 (digraph [1 2] [2 3] [3 1] [5 6] [6 7])) + +(def g8 (graph {1 [2 3 4] 5 [6 7 8]})) + +(deftest depth-first-test + (are [expected got] (= expected got) + #{1 2 3 5 6 7} (set (pre-traverse g7)) + #{1 2 3} (set (pre-traverse g7 1)) + #{1 2 3 4 5 6 7 8} (set (pre-traverse g8)) + #{1 2 3 4 5 6 7 8} (set (post-traverse g8)) + [:d :e :f :c :b :a :g] (post-traverse g5 :g) + false (not (some #{(post-traverse g7 1)} [[3 2 1] [2 3 1]])) + #{1 2 3 4 5 6 7 8} (set (nodes (digraph (pre-span g8)))) + #{2 3 4} (set (neighbors (digraph (pre-span g8)) 1)) + #{1 5} (set (neighbors (digraph (pre-span g6)) 0)) + true (let [span (digraph (pre-span g6))] + (and (or (= #{3} (set (neighbors span 4))) + (= #{2} (set (neighbors span 4)))) + (or (= #{3} (set (neighbors span 1))) + (= #{2} (set (neighbors span 1)))))) + [:g :a :b :c :f :e :d] (topsort g5) + nil (topsort g7) + [5 6 7] (topsort g7 5))) + +(deftest breadth-first-test + (are [expected got] (= expected got) + #{1 2 3 5 6 7} (set (bf-traverse g7)) + #{1 2 3} (set (bf-traverse g7 1)) + #{1 2 3 4 5 6 7 8} (set (bf-traverse g8)) + #{1 2 3 4 5 6 7 8} (set (nodes (digraph (bf-span g8)))) + #{2 3} (set (neighbors (digraph (bf-span g6)) 1)) + false (not (some #{(bf-traverse (remove-nodes g6 5))} + [[0 1 2 3 4] [0 1 3 2 4]])) + [:a :e :j] (bf-path g4 :a :j) + [:a :e :j] (bf-path-bi g4 :a :j))) + +(deftest dijkstra-test + (are [expected got] (= expected got) + [:a :c :h :j] (dijkstra-path g4 :a :j) + [[:a :c :h :j] 487] (dijkstra-path-dist g4 :a :j) + [[:r :o :p] 10] (dijkstra-path-dist g2 :r :p) + #{:r :g :b :o :p} (set (map first (dijkstra-traverse g2))) + {:r {:o 8 :b 5} :b {:g 8} :o {:p 10}} (dijkstra-span g2 :r))) + +(deftest connections-test + (are [expected got] (= expected got) + [#{1 2 3 4} #{5 6 7 8} #{9}] (map set (connected-components + (add-nodes g8 9))) + [#{:r :g :b :o :p}] (map set (connected-components g2)) + #{1 2 3 4 5 6 7 8} (set (nodes (connect g8))) + #{:r :g :b :o :p} (set (nodes (connect g2))))) + +(deftest other-stuff-test + (are [expected got] (= expected got) + [:a :c :h :j] (shortest-path g4 :a :j) + [:a :e :j] (shortest-path (graph g4) :a :j) + #{9 10} (set (loners (add-nodes g8 9 10))) + ;; TODO: the rest + )) diff --git a/test/loom/test/graph.clj b/test/loom/test/graph.clj new file mode 100644 index 0000000..c9486c3 --- /dev/null +++ b/test/loom/test/graph.clj @@ -0,0 +1,251 @@ +(ns loom.test.graph + (:use [loom.graph] :reload) + (:use [clojure.test])) + +(deftest simple-graph-test + (let [g1 (graph [1 2] [1 3] [2 3] 4) + g2 (graph {1 [2 3] 2 [3] 4 []}) + g3 (graph g1) + g4 (graph g3 (digraph [5 6]) [7 8] 9) + g5 (graph)] + (testing "Construction, nodes, edges" + (are [expected got] (= expected got) + #{1 2 3 4} (set (nodes g1)) + #{[1 2] [2 1] [1 3] [3 1] [2 3] [3 2]} (set (edges g1)) + (set (nodes g2)) (set (nodes g1)) + (set (edges g2)) (set (edges g1)) + (set (nodes g3)) (set (nodes g1)) + (set (nodes g3)) (set (nodes g1)) + #{1 2 3 4 5 6 7 8 9} (set (nodes g4)) + #{[1 2] [2 1] [1 3] [3 1] [2 3] + [3 2] [5 6] [6 5] [7 8] [8 7]} (set (edges g4)) + #{} (set (nodes g5)) + #{} (set (edges g5)) + true (has-node? g1 4) + true (has-edge? g1 1 2) + false (has-node? g1 5) + false (has-edge? g1 4 1))) + (testing "Neighbors" + (are [expected got] (= expected got) + #{2 3} (set (neighbors g1 1)) + #{1 2} (set (neighbors g1 3)) + #{} (set (neighbors g1 4)) + 2 (degree g1 1) + 2 (degree g1 3) + 0 (degree g1 4))) + (testing "Add & remove" + (are [expected got] (= expected got) + #{1 2 3 4 5} (set (nodes (add-nodes g1 5))) + #{:a :b :c} (set (nodes (add-nodes g5 :a :b :c))) + #{{:id 1} {:id 2}} (set (nodes (add-nodes g5 {:id 1} {:id 2}))) + #{[1 2] [2 1]} (set (edges (add-edges g5 [1 2]))) + #{1 2} (set (nodes (remove-nodes g1 3 4))) + #{[1 2] [2 1]} (set (edges (remove-nodes g1 3 4))) + #{1 2 3 4} (set (nodes (remove-edges g1 [1 2] [2 1] [1 3] [3 1]))) + #{[2 3] [3 2]} (set (edges (remove-edges g1 [1 2] [2 1] [1 3] [3 1]))))))) + +(deftest simple-digraph-test + (let [g1 (digraph [1 2] [1 3] [2 3] 4) + g2 (digraph {1 [2 3] 2 [3] 4 []}) + g3 (digraph g1) + g4 (digraph g3 (graph [5 6]) [7 8] 9) + g5 (digraph) + g6 (transpose g1)] + (testing "Construction, nodes, edges" + (are [expected got] (= expected got) + #{1 2 3 4} (set (nodes g1)) + #{1 2 3 4} (set (nodes g6)) + #{[1 2] [1 3] [2 3]} (set (edges g1)) + #{[2 1] [3 1] [3 2]} (set (edges g6)) + (set (nodes g2)) (set (nodes g1)) + (set (edges g2)) (set (edges g1)) + (set (nodes g3)) (set (nodes g1)) + (set (nodes g3)) (set (nodes g1)) + #{1 2 3 4 5 6 7 8 9} (set (nodes g4)) + #{[1 2] [1 3] [2 3] [5 6] [6 5] [7 8]} (set (edges g4)) + #{} (set (nodes g5)) + #{} (set (edges g5)) + true (has-node? g1 4) + true (has-edge? g1 1 2) + false (has-node? g1 5) + false (has-edge? g1 2 1))) + (testing "Neighbors" + (are [expected got] (= expected got) + #{2 3} (set (neighbors g1 1)) + #{} (set (neighbors g1 3)) + #{} (set (neighbors g1 4)) + 2 (degree g1 1) + 0 (degree g1 3) + 0 (degree g1 4) + #{1 2} (set (incoming g1 3)) + #{} (set (incoming g1 1)) + 2 (in-degree g1 3) + 0 (in-degree g1 1) + #{1 2} (set (neighbors g6 3)) + #{} (set (neighbors g6 1)) + 2 (degree g6 3) + 0 (degree g6 1))) + (testing "Add & remove" + (are [expected got] (= expected got) + #{1 2 3 4 5} (set (nodes (add-nodes g1 5))) + #{:a :b :c} (set (nodes (add-nodes g5 :a :b :c))) + #{{:id 1} {:id 2}} (set (nodes (add-nodes g5 {:id 1} {:id 2}))) + #{[1 2]} (set (edges (add-edges g5 [1 2]))) + #{1 2} (set (nodes (remove-nodes g1 3 4))) + #{[1 2]} (set (edges (remove-nodes g1 3 4))) + #{1 2 3 4} (set (nodes (remove-edges g1 [1 2] [1 3]))) + #{[2 3]} (set (edges (remove-edges g1 [1 2] [1 3]))))))) + +(deftest simple-weighted-graph-test + (let [g1 (weighted-graph [1 2 77] [1 3 88] [2 3 99] 4) + g2 (weighted-graph {1 {2 77 3 88} 2 {3 99} 4 []}) + g3 (weighted-graph g1) + g4 (weighted-graph g3 (weighted-digraph [5 6 88]) [7 8] 9) + g5 (weighted-graph)] + (testing "Construction, nodes, edges" + (are [expected got] (= expected got) + #{1 2 3 4} (set (nodes g1)) + #{[1 2] [2 1] [1 3] [3 1] [2 3] [3 2]} (set (edges g1)) + (set (nodes g2)) (set (nodes g1)) + (set (edges g2)) (set (edges g1)) + (set (nodes g3)) (set (nodes g1)) + (set (nodes g3)) (set (nodes g1)) + #{1 2 3 4 5 6 7 8 9} (set (nodes g4)) + #{[1 2] [2 1] [1 3] [3 1] [2 3] + [3 2] [5 6] [6 5] [7 8] [8 7]} (set (edges g4)) + #{} (set (nodes g5)) + #{} (set (edges g5)) + true (has-node? g1 4) + true (has-edge? g1 1 2) + false (has-node? g1 5) + false (has-edge? g1 4 1))) + (testing "Neighbors" + (are [expected got] (= expected got) + #{2 3} (set (neighbors g1 1)) + #{1 2} (set (neighbors g1 3)) + #{} (set (neighbors g1 4)) + 2 (degree g1 1) + 2 (degree g1 3) + 0 (degree g1 4))) + (testing "Add & remove" + (are [expected got] (= expected got) + #{1 2 3 4 5} (set (nodes (add-nodes g1 5))) + #{:a :b :c} (set (nodes (add-nodes g5 :a :b :c))) + #{{:id 1} {:id 2}} (set (nodes (add-nodes g5 {:id 1} {:id 2}))) + #{[1 2] [2 1]} (set (edges (add-edges g5 [1 2]))) + #{1 2} (set (nodes (remove-nodes g1 3 4))) + #{[1 2] [2 1]} (set (edges (remove-nodes g1 3 4))) + #{1 2 3 4} (set (nodes (remove-edges g1 [1 2] [2 1] [1 3] [3 1]))) + #{[2 3] [3 2]} (set (edges (remove-edges g1 [1 2] [2 1] [1 3] [3 1]))))) + (testing "Weight" + (are [expected got] (= expected got) + 77 (weight g1 1 2) + 77 (weight g2 1 2) + 77 (weight g3 1 2) + 88 (weight g4 6 5) + 1 (weight g4 7 8))))) + +(deftest simple-weighted-digraph-test + (let [g1 (weighted-digraph [1 2 77] [1 3 88] [2 3 99] 4) + g2 (weighted-digraph {1 {2 77 3 88} 2 {3 99} 4 []}) + g3 (weighted-digraph g1) + g4 (weighted-digraph g3 (weighted-graph [5 6 88]) [7 8] 9) + g5 (weighted-digraph) + g6 (transpose g1)] + (testing "Construction, nodes, edges" + (are [expected got] (= expected got) + #{1 2 3 4} (set (nodes g1)) + #{1 2 3 4} (set (nodes g6)) + #{[1 2] [1 3] [2 3]} (set (edges g1)) + #{[2 1] [3 1] [3 2]} (set (edges g6)) + (set (nodes g2)) (set (nodes g1)) + (set (edges g2)) (set (edges g1)) + (set (nodes g3)) (set (nodes g1)) + (set (nodes g3)) (set (nodes g1)) + #{1 2 3 4 5 6 7 8 9} (set (nodes g4)) + #{[1 2] [1 3] [2 3] [5 6] [6 5] [7 8]} (set (edges g4)) + #{} (set (nodes g5)) + #{} (set (edges g5)) + true (has-node? g1 4) + true (has-edge? g1 1 2) + false (has-node? g1 5) + false (has-edge? g1 2 1))) + (testing "Neighbors" + (are [expected got] (= expected got) + #{2 3} (set (neighbors g1 1)) + #{} (set (neighbors g1 3)) + #{} (set (neighbors g1 4)) + 2 (degree g1 1) + 0 (degree g1 3) + 0 (degree g1 4) + #{1 2} (set (incoming g1 3)) + #{} (set (incoming g1 1)) + 2 (in-degree g1 3) + 0 (in-degree g1 1) + #{1 2} (set (neighbors g6 3)) + #{} (set (neighbors g6 1)) + 2 (degree g6 3) + 0 (degree g6 1))) + (testing "Add & remove" + (are [expected got] (= expected got) + #{1 2 3 4 5} (set (nodes (add-nodes g1 5))) + #{:a :b :c} (set (nodes (add-nodes g5 :a :b :c))) + #{{:id 1} {:id 2}} (set (nodes (add-nodes g5 {:id 1} {:id 2}))) + #{[1 2]} (set (edges (add-edges g5 [1 2]))) + #{1 2} (set (nodes (remove-nodes g1 3 4))) + #{[1 2]} (set (edges (remove-nodes g1 3 4))) + #{1 2 3 4} (set (nodes (remove-edges g1 [1 2] [1 3]))) + #{[2 3]} (set (edges (remove-edges g1 [1 2] [1 3]))))) + (testing "Weight" + (are [expected got] (= expected got) + 77 (weight g1 1 2) + 77 (weight g2 1 2) + 77 (weight g3 1 2) + 77 (weight g6 2 1) + 88 (weight g4 6 5) + 1 (weight g4 7 8))))) + +(deftest fly-graph-test + (let [fg1 (fly-graph :nodes [1 2 3] + :neighbors #(if (= 3 %) [1] [(inc %)]) + :weight (constantly 88)) + fg2 (fly-graph :neighbors #(if (= 3 %) [1] [(inc %)]) + :start 1)] + (testing "Construction, nodes, edges" + (are [expected got] (= expected got) + #{1 2 3} (set (nodes fg1)) + #{1 2 3} (set (nodes fg2)) + #{[1 2] [2 3] [3 1]} (set (edges fg1)) + #{[1 2] [2 3] [3 1]} (set (edges fg2)) + 88 (weight fg1 1 2))) + ;; TODO: finish + )) + +(deftest utilities-test + (testing "Predicates" + (are [expected got] (= expected got) + true (every? true? (map graph? [(graph [1 2]) + (digraph [1 2]) + (weighted-graph [1 2]) + (weighted-digraph [1 2]) + (reify Graph)])) + true (every? true? (map directed? [(digraph [1 2]) + (weighted-digraph [1 2]) + (reify Digraph)])) + true (every? true? (map weighted? [(weighted-graph [1 2]) + (weighted-digraph [1 2]) + (reify WeightedGraph)])))) + (testing "Adders" + (let [g (weighted-digraph [1 2] [2 3] [3 1]) + sg (subgraph g [1 2]) + pg (add-path (digraph) 1 2 3 4 5) + cg (add-cycle (digraph) 1 2 3)] + (are [expected got] (= expected got) + #{1 2} (set (nodes sg)) + #{[1 2]} (set (edges sg)) + true (graph? sg) + true (directed? sg) + true (weighted? sg) + #{[1 2] [2 3] [3 4] [4 5]} (set (edges pg)) + #{[1 2] [2 3] [3 1]} (set (edges cg)))))) +