Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

initial commit

  • Loading branch information...
commit a8301f09c90d904d72c677823d07b68236845a31 0 parents
Justin Kramer authored September 18, 2010
4  .gitignore
... ...
@@ -0,0 +1,4 @@
  1
+pom.xml
  2
+*jar
  3
+lib
  4
+classes
140  README.md
Source Rendered
... ...
@@ -0,0 +1,140 @@
  1
+# Loom
  2
+
  3
+This library isn't ready for consumption yet. The API is still in flux. Even the name may change.
  4
+
  5
+That said, feedback welcome.
  6
+
  7
+## Usage
  8
+
  9
+### Leiningen/Clojars [group-id/name version]
  10
+
  11
+    [none yet -- see above]
  12
+
  13
+### Namespaces
  14
+
  15
+    loom.graph - records & constructors
  16
+    loom.alg   - algorithms (see also loom.alg-generic)
  17
+    loom.gen   - graph generators
  18
+    loom.attr  - graph attributes
  19
+    loom.label - graph labels
  20
+    loom.io    - read, write, and view graphs in external formats
  21
+
  22
+### Basics
  23
+
  24
+Create a graph:
  25
+
  26
+    ;; Initialize with any of: edges, adacency lists, nodes, other graphs
  27
+    (def g (graph [1 2] [2 3] {3 [4] 5 [6 7]} 7 8 9))
  28
+    (def dg (digraph g))
  29
+    (def wg (weighted-graph {:a {:b 10 :c 20} :c {:d 30} :e {:b 5 :d 5}}))
  30
+    (def wdg (weighted-digraph [:a :b 10] [:a :c 20] [:c :d 30] [:d :b 10]))
  31
+    (def rwg (gen-rand (weighted-graph) 10 20 :max-weight 100))
  32
+    (def fg (fly-graph :neighbors range :weight (constantly 77)))
  33
+
  34
+If you have [GraphViz](http://www.graphviz.org) installed, and its binaries are in the path, you can view graphs with <code>loom.io/view</code>:
  35
+
  36
+    (view wdg) ;opens image in default image viewer
  37
+    
  38
+Inspect:
  39
+
  40
+    (nodes g)
  41
+    => #{1 2 3 4 5 6 7 8 9}
  42
+    
  43
+    (edges wdg)
  44
+    => ([:a :c] [:a :b] [:c :d] [:d :b])
  45
+    
  46
+    (neighbors g 3)
  47
+    => #{2 4}
  48
+    
  49
+    (incoming wdg :b)
  50
+    => #{:a :d}
  51
+    
  52
+    (degree g 3)
  53
+    => 2
  54
+    
  55
+    (in-degree wdg :b)
  56
+    => 2
  57
+    
  58
+    (weight wg :a :c)
  59
+    => 20
  60
+    
  61
+    (map (juxt graph? directed? weighted?) [g wdg])
  62
+    => ([true false false] [true true true])
  63
+    
  64
+Add/remove items (graphs are immutable, of course, so these return new graphs):
  65
+
  66
+    (add-nodes g "foobar" {:name "baz"} [1 2 3])
  67
+    
  68
+    (add-edges g [10 11] ["foobar" {:name "baz"}])
  69
+    
  70
+    (add-edges wg [:e :f 40] [:f :g 50]) ;weighted edges
  71
+    
  72
+    (remove-nodes g 1 2 3)
  73
+
  74
+    (remove-edges g [1 2] [2 3])
  75
+    
  76
+    (subgraph g [5 6 7])
  77
+
  78
+Traverse a graph:
  79
+
  80
+    (bf-traverse g) ;lazy
  81
+    => (9 8 5 6 7 1 2 3 4)
  82
+    
  83
+    (bf-traverse g 1)
  84
+    => (1 2 3 4)
  85
+    
  86
+    (pre-traverse wdg) ;lazy
  87
+    => (:a :b :c :d)
  88
+    
  89
+    (post-traverse wdg) ;not lazy
  90
+    => (:b :d :c :a)
  91
+    
  92
+    (topsort wdg)
  93
+    => (:a :c :d :b)
  94
+
  95
+Pathfinding:
  96
+
  97
+    (bf-path g 1 4)
  98
+    => (1 2 3 4)
  99
+    
  100
+    (bf-path-bi g 1 4) ;bidirectional, parallel
  101
+    => (1 2 3 4)
  102
+    
  103
+    (dijkstra-path wg :a :d)
  104
+    => (:a :b :e :d)
  105
+    
  106
+    (dijkstra-path-dist wg :a :d)
  107
+    => [(:a :b :e :d) 20]
  108
+
  109
+Other stuff:
  110
+
  111
+    (connected-components g)
  112
+    => [[1 2 3 4] [5 6 7] [8] [9]]
  113
+
  114
+    (bf-span wg :a)
  115
+    => {:c [:d], :b [:e], :a [:b :c]}
  116
+
  117
+    (pre-span wg :a)
  118
+    => {:a [:b], :b [:e], :e [:d], :d [:c]}
  119
+    
  120
+    (dijkstra-span wg :a)
  121
+    => {:a {:b 10, :c 20}, :b {:e 15}, :e {:d 20}}
  122
+
  123
+TODO: link to autodocs
  124
+
  125
+## Dependencies
  126
+
  127
+There is (optional) support for visualization via [GrapViz](http://graphviz.org).
  128
+
  129
+## TODO
  130
+
  131
+* Solidify basic API, guarantees
  132
+* Implement more algorithms
  133
+* Test & profile more with big, varied graphs
  134
+* Multigraphs, hypergraphs, adjacency matrix-based graphs?
  135
+
  136
+## License
  137
+
  138
+Copyright (C) 2010 Justin Kramer jkkramer@gmail.com
  139
+
  140
+Distributed under the Eclipse Public License, the same as Clojure.
11  project.clj
... ...
@@ -0,0 +1,11 @@
  1
+(defproject loom "0.1.0-SNAPSHOT"
  2
+  :description "Graph library for Clojure"
  3
+  :author "Justin Kramer"
  4
+  :dependencies [[org.clojure/clojure "1.3.0-master-SNAPSHOT"]
  5
+                 [org.apache.xmlrpc/xmlrpc-client "3.1.3"]
  6
+                 [robert/hooke "1.0.2"]
  7
+                 ;[org.clojure.contrib/priority-map "1.3.0-SNAPSHOT"]
  8
+                 ;[vijual "0.1.0-SNAPSHOT"]
  9
+                 ]
  10
+  :dev-dependencies [[swank-clojure "1.3.0-SNAPSHOT"]]
  11
+  :jvm-opts ["-Xmx1g"])
234  src/loom/alg.clj
... ...
@@ -0,0 +1,234 @@
  1
+(ns ^{:doc "Graph algorithms. Any graph record/type that satisfies the
  2
+Graph, Digraph, or WeightedGraph protocols (as appropriate per algorithm)
  3
+can use these functions."
  4
+      :author "Justin Kramer"}
  5
+  loom.alg
  6
+  (:require [loom.alg-generic :as gen])
  7
+  (:use [loom.graph
  8
+         :only [add-edges nodes edges neighbors weight incoming degree
  9
+                in-degree weighted? directed? graph]
  10
+         :rename {neighbors nb weight wt}]
  11
+        [loom.alg-generic :only [trace-path]]))
  12
+
  13
+;;;
  14
+;;; Convenience wrappers for loom.alg-generic functions
  15
+;;;
  16
+
  17
+(defn- traverse-all
  18
+  [nodes traverse]
  19
+  (second
  20
+   (reduce
  21
+    (fn [[seen trav] n]
  22
+      (if (seen n)
  23
+        [seen trav]
  24
+        (let [ctrav (traverse n :seen (conj seen n))]
  25
+          [(into seen ctrav) (concat ctrav trav)])))
  26
+    [#{} []]
  27
+    nodes)))
  28
+
  29
+;;TODO: options: :incoming, :when
  30
+(defn pre-traverse
  31
+  "Traverses graph g depth-first from start. Returns a lazy seq of nodes.
  32
+  When no starting node is provided, traverses the entire graph, connected
  33
+  or not."
  34
+  ([g]
  35
+     (traverse-all (nodes g) (partial gen/pre-traverse (nb g))))
  36
+  ([g start]
  37
+     (gen/pre-traverse (nb g) start)))
  38
+
  39
+(defn pre-span
  40
+  "Return a depth-first spanning tree of the form {node [successors]}"
  41
+  ([g]
  42
+     (second
  43
+      (reduce
  44
+       (fn [[seen span] n]
  45
+         (if (seen n)
  46
+           [seen span]
  47
+           (let [[cspan cseen] (gen/pre-span (nb g) n :seen seen)]
  48
+             [(clojure.set/union seen cseen) (merge span {n []} cspan)])))
  49
+       [#{} {}]
  50
+       (nodes g))))
  51
+  ([g start]
  52
+     (gen/pre-span (nb g) start)))
  53
+
  54
+(defn post-traverse
  55
+  "Traverses graph g depth-first, post-order from start. Returns a
  56
+  vector of the nodes."
  57
+  ([g]
  58
+     (traverse-all (nodes g) (partial gen/post-traverse (nb g))))
  59
+  ([g start]
  60
+     (gen/post-traverse (nb g) start)))
  61
+
  62
+(defn topsort
  63
+  "Topological sort of a directed acyclic graph (DAG). Returns nil if
  64
+  g contains any cycles."
  65
+  ([g]
  66
+     (loop [seen #{}
  67
+            result ()
  68
+            [n & ns] (seq (nodes g))]
  69
+       (if-not n
  70
+         result
  71
+         (if (seen n)
  72
+           (recur seen result ns)
  73
+           (when-let [cresult (gen/topsort-component (nb g) n seen seen)]
  74
+             (recur (into seen cresult) (concat cresult result) ns))))))
  75
+  ([g start]
  76
+     (gen/topsort-component (nb g) start)))
  77
+
  78
+(defn bf-traverse
  79
+  "Traverses graph g breadth-first from start. When f is provided, returns
  80
+  a lazy seq of (f node predecessor-map) for each node traversed. Otherwise,
  81
+  returns a lazy seq of the nodes."
  82
+  ([g]
  83
+     (traverse-all (nodes g) (partial gen/bf-traverse (nb g))))
  84
+  ([g start]
  85
+     (gen/bf-traverse (nb g) start))
  86
+  ([g start & {:as opts}]
  87
+     (apply gen/bf-traverse (nb g) start (apply concat opts))))
  88
+
  89
+(defn bf-span
  90
+  "Return a breadth-first spanning tree of the form {node [successors]}"
  91
+  ([g]
  92
+     (second
  93
+      (reduce
  94
+       (fn [[seen span] n]
  95
+         (if (seen n)
  96
+           [seen span]
  97
+           (let [cspan (gen/bf-span (nb g) n :seen seen)]
  98
+             ;; FIXME: very inefficient
  99
+             [(into seen (concat (keys cspan) (apply concat (vals cspan))))
  100
+              (merge span {n []} cspan)])))
  101
+       [#{} {}]
  102
+       (nodes g))))
  103
+  ([g start]
  104
+     (gen/bf-span (nb g) start)))
  105
+
  106
+(defn bf-path
  107
+  "Return a path from start to end with the fewest hops (i.e. irrespective
  108
+  of edge weights)"
  109
+  [g start end]
  110
+  (gen/bf-path (nb g) start end))
  111
+
  112
+(defn bf-path-bi
  113
+  "Using a bidirectional breadth-first search, finds a path from start to
  114
+  end with the fewest hops (i.e. irrespective of edge weights). Can be much
  115
+  faster than a unidirectional search on certain types of graphs"
  116
+  [g start end]
  117
+  (gen/bf-path-bi (nb g) start end))
  118
+
  119
+(defn dijkstra-traverse
  120
+  "Returns a lazy-seq of [current-node state] where state is a map in the
  121
+  format {node [distance predecessor]}. When f is provided, returns
  122
+  a lazy-seq of (f node state) for each node"
  123
+  ([g]
  124
+     (gen/dijkstra-traverse (nb g) (wt g) (first (nodes g))))
  125
+  ([g start]
  126
+     (gen/dijkstra-traverse (nb g) (wt g) start vector))
  127
+  ([g start f]
  128
+     (gen/dijkstra-traverse (nb g) (wt g) start f)))
  129
+
  130
+(defn dijkstra-span
  131
+  "Finds all shortest distances from start. Returns a map in the format
  132
+  {node {successor distance}}"
  133
+  ([g]
  134
+     (gen/dijkstra-span (nb g) (wt g) (first (nodes g))))
  135
+  ([g start]
  136
+     (gen/dijkstra-span (nb g) (wt g) start)))
  137
+
  138
+(defn dijkstra-path-dist
  139
+  "Finds the shortest path from start to end. Returns a vector:
  140
+  [path distance]"
  141
+  [g start end]
  142
+  (gen/dijkstra-path-dist (nb g) (wt g) start end))
  143
+
  144
+(defn dijkstra-path
  145
+  "Finds the shortest path from start to end"
  146
+  [g start end]
  147
+  (first (dijkstra-path-dist g start end)))
  148
+
  149
+
  150
+;;;
  151
+;;; Graph algorithms
  152
+;;;
  153
+
  154
+(defn shortest-path
  155
+  "Finds the shortest path from start to end in graph g, using Dijkstra's
  156
+  algorithm if the graph is weighted, breadth-first search otherwise."
  157
+  [g start end]
  158
+  (if (weighted? g)
  159
+    (dijkstra-path g start end)
  160
+    (bf-path g start end)))
  161
+
  162
+(defn longest-shortest-path
  163
+  "Finds the longest shortest path beginning at start, using Dijkstra's
  164
+  algorithm if the graph is weighted, bread-first search otherwise."
  165
+  [g start]
  166
+  (reverse
  167
+   (if (weighted? g)
  168
+     (reduce
  169
+      (fn [path1 [n state]]
  170
+        (let [path2 (trace-path (comp second state) n)]
  171
+          (if (< (count path1) (count path2)) path2 path1)))
  172
+      [start]
  173
+      (dijkstra-traverse g start vector))
  174
+     (reduce
  175
+      (fn [path1 [n predmap]]
  176
+        (let [path2 (trace-path predmap n)]
  177
+          (if (< (count path1) (count path2)) path2 path1)))
  178
+      [start]
  179
+      (bf-traverse g start vector)))))
  180
+
  181
+(defn connected-components
  182
+  "Return the connected components of undirected graph g as a vector of vectors"
  183
+  [g]
  184
+  (first
  185
+   (reduce
  186
+    (fn [[cc seen] n]
  187
+      (if (seen n)
  188
+        [cc seen]
  189
+        (let [c (vec (gen/bf-traverse (nb g) n :seen seen))]
  190
+          [(conj cc c) (into seen c)])))
  191
+    [[] #{}]
  192
+    (nodes g))))
  193
+
  194
+;; TODO: weak & strong cc
  195
+
  196
+(defn connect
  197
+  "Return graph g with all connected components connected to each other"
  198
+  [g]
  199
+  (reduce add-edges g (partition 2 1 (map first (connected-components g)))))
  200
+
  201
+(defn density
  202
+  "Return the density of graph g"
  203
+  [g & {:keys [loops] :or {loops false}}]
  204
+  (let [order (count (nodes g))]
  205
+    (/ (count (edges g))
  206
+       (* order (if loops
  207
+                  order
  208
+                  (dec order))))))
  209
+
  210
+(defn loners
  211
+  "Return nodes with no connections to other nodes (i.e., isolated nodes)"
  212
+  [g]
  213
+  (let [degree-total (if (directed? g)
  214
+                       #(+ (in-degree g %) (degree g %))
  215
+                       #(degree g %))]
  216
+    (filter (comp zero? degree-total) (nodes g))))
  217
+
  218
+(defn distinct-edges
  219
+  "Distinct edges of g. Only useful for undirected graphs"
  220
+  [g]
  221
+  (if (directed? g)
  222
+    (edges g)
  223
+    (second
  224
+     (reduce
  225
+      (fn [[seen es] e]
  226
+        (let [eset (set (take 2 e))]
  227
+          (if (seen eset)
  228
+            [seen es]
  229
+            [(conj seen eset)
  230
+             (conj es e)])))
  231
+      [#{} []]
  232
+      (edges g)))))
  233
+
  234
+;; TODO: MST, coloring, bipartite, matching, etc etc
289  src/loom/alg_generic.clj
... ...
@@ -0,0 +1,289 @@
  1
+(ns ^{:doc "Graph algorithms for use on any type of graph"
  2
+      :author "Justin Kramer"}
  3
+  loom.alg-generic
  4
+  (:use [loom.io.ubigraph :only [call]]))
  5
+
  6
+;;;
  7
+;;; Utility functions
  8
+;;;
  9
+
  10
+(defn trace-path
  11
+  "Using a map of nodes-to-preds, traces a node's family tree back to the
  12
+  source. Cycles are not accounted for."
  13
+  [preds node]
  14
+  (take-while identity (iterate preds node)))
  15
+
  16
+(defn preds->span
  17
+  "Converts a map of the form {node predecessor} to a spanning tree of the
  18
+  form {node [successors]}"
  19
+  [preds]
  20
+  (reduce
  21
+   (fn [span [n p]]
  22
+     (if p
  23
+       (assoc span p (conj (span p []) n))
  24
+       span))
  25
+   {} preds))
  26
+
  27
+;;;
  28
+;;; Depth-first traversal
  29
+;;;
  30
+
  31
+(defn pre-traverse
  32
+  "Traverses a graph depth-first preorder from start, neighbors being a
  33
+  function that returns adjacent nodes. Returns a lazy seq of nodes."
  34
+  [neighbors start & {:keys [seen] :or {seen #{start}}}]
  35
+  (letfn [(step [stack seen]
  36
+            (when-let [node (peek stack)]
  37
+              (cons
  38
+               node
  39
+               (lazy-seq
  40
+                (let [nbrs (remove seen (neighbors node))]
  41
+                  (step (into (pop stack) nbrs)
  42
+                        (into seen nbrs)))))))]
  43
+    (step [start]
  44
+          seen)))
  45
+
  46
+(defn pre-span
  47
+  "Return a depth-first spanning tree of the form {node [successors]}"
  48
+  [neighbors start & {:keys [seen]}]
  49
+  (let [seen-start seen]
  50
+    (loop [seen (or seen-start #{})
  51
+           preds {start nil}
  52
+           stack [start]]
  53
+      (if (empty? stack)
  54
+        (if seen-start
  55
+          [(preds->span preds) seen]
  56
+          (preds->span preds))
  57
+        (let [v (peek stack)
  58
+              seen (conj seen v)]
  59
+          (if-let [u (first (remove seen (neighbors v)))]
  60
+            (recur seen (assoc preds u v) (conj stack u))
  61
+            (recur seen preds (pop stack))))))))
  62
+
  63
+(defn post-traverse
  64
+  "Traverses a graph depth-first postorder from start, neighbors being a
  65
+  function that returns adjacent nodes. Returns a vector"
  66
+  [neighbors start & {:keys [seen] :or {seen #{}}}]
  67
+  ;; For most graphs, being lazy wouldn't matter
  68
+  (loop [seen seen
  69
+         result []
  70
+         stack [start]]
  71
+    (if (empty? stack)
  72
+      result
  73
+      (let [v (peek stack)
  74
+            seen (conj seen v)
  75
+            nbrs (remove seen (neighbors v))]
  76
+        (if (empty? nbrs)
  77
+          (recur seen (conj result v) (pop stack))
  78
+          (recur seen result (conj stack (first nbrs))))))))
  79
+
  80
+(defn topsort-component
  81
+  "Topological sort of a component of a (presumably) directed graph.
  82
+  Returns nil if the graph contains any cycles. See loom.alg/topsort
  83
+  for a complete topological sort"
  84
+  ([neighbors start]
  85
+     (topsort-component neighbors start #{} #{}))
  86
+  ([neighbors start seen explored]
  87
+     (loop [seen seen
  88
+            explored explored
  89
+            result ()
  90
+            stack [start]]
  91
+       (if (empty? stack)
  92
+         result
  93
+         (if (explored (peek stack))
  94
+           (recur seen explored result (pop stack))
  95
+           (let [v (peek stack)
  96
+                 seen (conj seen v)
  97
+                 us (remove explored (neighbors v))]
  98
+             (if (seq us)
  99
+               (when-not (some seen us)
  100
+                 (recur seen explored result (into stack us)))
  101
+               (recur seen (conj explored v) (conj result v) (pop stack)))))))))
  102
+
  103
+;;;
  104
+;;; Breadth-first traversal
  105
+;;;
  106
+
  107
+;; TODO: depth limiter
  108
+;; TODO: per-level filters a la gremlin?
  109
+
  110
+(defn bf-traverse
  111
+  "Traverses a graph breadth-first from start, neighbors being a
  112
+  function that returns adjacent nodes. When f is provided, returns
  113
+  a lazy seq of (f node predecessor-map) for each node traversed. Otherwise,
  114
+  returns a lazy seq of the nodes."
  115
+  [neighbors start & {:keys [f seen] :or {f (fn [n p] n)}}]
  116
+  (letfn [(step [queue preds]
  117
+            (when-let [node (peek queue)]
  118
+              (let [nbrs (remove #(contains? preds %) (neighbors node))]
  119
+                (cons (f node preds)
  120
+                      (lazy-seq
  121
+                       (step (into (pop queue) nbrs)
  122
+                             (reduce #(assoc %1 %2 node) preds nbrs)))))))]
  123
+    (step (conj clojure.lang.PersistentQueue/EMPTY start)
  124
+          (if seen
  125
+            (into {start nil} (for [s seen] [s nil]))
  126
+            {start nil}))))
  127
+
  128
+(defn bf-span
  129
+  "Return a breadth-first spanning tree of the form {node [successors]}"
  130
+  [neighbors start & {:keys [seen]}]
  131
+  (preds->span
  132
+   (bf-traverse neighbors start
  133
+                :f (fn [n pm] [n (pm n)])
  134
+                :seen seen)))
  135
+
  136
+(defn bf-path
  137
+  "Return a path from start to end with the fewest hops (i.e. irrespective
  138
+  of edge weights), neighbors being a function that returns adjacent nodes"
  139
+  [neighbors start end]
  140
+  (when-let [preds (some (fn [[_ p]] (when (p end) p))
  141
+                         (bf-traverse neighbors start :f vector))]
  142
+    (reverse (trace-path preds end))))
  143
+
  144
+(defn- shared-keys
  145
+  "Return a lazy-seq of the keys that exist in both m1 and m2"
  146
+  [m1 m2]
  147
+  (if (< (count m2) (count m1))
  148
+    (recur m2 m1)
  149
+    (filter (partial contains? m2) (keys m1))))
  150
+
  151
+(defn bf-path-bi
  152
+  "Using a bidirectional breadth-first search, finds a path from start to
  153
+  end with the fewest hops (i.e. irrespective of edge weights), neighbors
  154
+  being a function which returns adjacent nodes. Can be much faster than
  155
+  a unidirectional search on certain types of graphs"
  156
+  [neighbors start end]
  157
+  ;; TODO: make this work better with directed graphs using incoming fn
  158
+  (let [done? (atom false)
  159
+        preds1 (atom {})
  160
+        preds2 (atom {})
  161
+        find-intersect #(first (shared-keys @preds1 @preds2))
  162
+        search (fn [n preds]
  163
+                 (dorun
  164
+                  (take-while
  165
+                   (fn [_] (not @done?))
  166
+                   (bf-traverse neighbors n :f #(reset! preds %2)))))
  167
+        search1 (future (search start preds1))
  168
+        search2 (future (search end preds2))]
  169
+    (loop [intersect (find-intersect)]
  170
+      (if (or intersect (future-done? search1)) ;; (future-done? search2)
  171
+        (do
  172
+          (reset! done? true)
  173
+          (cond
  174
+           intersect (concat
  175
+                      (reverse (trace-path @preds1 intersect))
  176
+                      (rest (trace-path @preds2 intersect)))
  177
+           (@preds1 end) (reverse (trace-path @preds1 end))
  178
+           (@preds2 start) (trace-path @preds2 start)))
  179
+        (recur (find-intersect))))))
  180
+
  181
+;;;
  182
+;;; Dijkstra
  183
+;;;
  184
+
  185
+(defn dijkstra-traverse
  186
+  "Returns a lazy-seq of [current-node state] where state is a map in the
  187
+  format {node [distance predecessor]}. When f is provided, returns
  188
+  a lazy-seq of (f node state) for each node"
  189
+  ([neighbors dist start]
  190
+     (dijkstra-traverse neighbors dist start vector))
  191
+  ([neighbors dist start f]
  192
+     (letfn [(step [[state pq]]
  193
+               (when-let [[dist-su _ u :as fpq] (first pq)]
  194
+                 (cons
  195
+                  (f u state)
  196
+                  (lazy-seq
  197
+                   (step
  198
+                    (reduce
  199
+                     (fn [[state pq] v]
  200
+                       (let [dist-suv (+ dist-su (dist u v))
  201
+                             dist-sv (first (state v))]
  202
+                         (if (and dist-sv (>= dist-suv dist-sv))
  203
+                           [state pq]
  204
+                           (let [pq (if dist-sv
  205
+                                      (disj pq [dist-sv (hash v) v])
  206
+                                      pq)]
  207
+                             [(assoc state v [dist-suv u])
  208
+                              (conj pq [dist-suv (hash v) v])]))))
  209
+                     [state (disj pq fpq)]
  210
+                     (neighbors u)))))))]
  211
+       (step [{start [0 nil]}
  212
+              ;; Poor man's priority queue. Caveats:
  213
+              ;; 1) Have to keep it in sync with current state
  214
+              ;; 2) Have to include hash codes for non-Comparable items
  215
+              ;; 3) O(logn) operations
  216
+              ;; Tried clojure.contrib.priority-map but it wasn't any faster
  217
+              (sorted-set [0 (hash start) start])]))))
  218
+
  219
+(defn dijkstra-span
  220
+  "Finds all shortest distances from start, where neighbors and dist
  221
+  are functions called as (neighbors node) and (dist node1 node2).
  222
+  Returns a map in the format {node {successor distance}}"
  223
+  [neighbors dist start]
  224
+  (reduce
  225
+   (fn [span [n [d p]]]
  226
+     (if p
  227
+       (assoc-in span [p n] d)
  228
+       span))
  229
+   {}
  230
+   (second (last (dijkstra-traverse neighbors dist start)))))
  231
+
  232
+(defn dijkstra-path-dist
  233
+  "Finds the shortest path from start to end, where neighbors and dist
  234
+  are functions called as (neighbors node) and (dist node1 node2).
  235
+  Returns a vector: [path distance]"
  236
+  [neighbors dist start end]
  237
+  (if-let [[_ end-state] (first (filter
  238
+                                 (fn [[node _]] (= end node))
  239
+                                 (dijkstra-traverse neighbors dist start)))]
  240
+    [(reverse (trace-path (comp second end-state) end))
  241
+     (first (end-state end))]))
  242
+
  243
+(defn dijkstra-path
  244
+  "Finds the shortest path from start to end, where neighbors and dist
  245
+  are functions called as (neighbors node) and (dist node1 node2)"
  246
+  [neighbors dist start end]
  247
+  (first (dijkstra-path-dist neighbors dist start end)))
  248
+
  249
+;; FIXME: Research proper way to do this
  250
+#_(defn dijkstra-path-dist-bi
  251
+  "Finds a path -- not necessarily the shortest -- from start to end
  252
+  birectionally, where neighbors and dist are functions called as
  253
+  (neighbors node) and (dist node1 node2). Returns a vector: [path distance]"
  254
+  [neighbors dist start end]
  255
+  ;; TODO: make this work better with directed graphs (incoming fn)
  256
+  (let [done? (atom false)
  257
+        processed1 (atom #{})
  258
+        processed2 (atom #{})
  259
+        state1 (atom nil)
  260
+        state2 (atom nil)
  261
+        find-intersect (fn [] (some #(when (@processed1 %) %) @processed2))
  262
+        search (fn [n processed state]
  263
+                 (dorun
  264
+                  (take-while
  265
+                   (fn [_] (not @done?))
  266
+                   (dijkstra-traverse neighbors dist n 
  267
+                                      #(do
  268
+                                         (swap! processed conj %1)
  269
+                                         (reset! state %2))))))
  270
+        search1 (future (search start processed1 state1))
  271
+        search2 (future (search end processed2 state2))]
  272
+    (loop [intersect (find-intersect)]
  273
+      (if (or intersect (future-done? search1))
  274
+        (do
  275
+          (prn intersect)
  276
+          (reset! done? true)
  277
+          (cond
  278
+           intersect [(concat
  279
+                       (reverse (trace-path (comp second @state1) intersect))
  280
+                       (rest (trace-path (comp second @state2) intersect)))
  281
+                      (+ (first (@state1 intersect))
  282
+                         (first (@state2 intersect)))]
  283
+           (@state1 end) [(reverse (trace-path (comp second @state1) end))
  284
+                          (first (@state1 end))]
  285
+           (@state2 start) [(trace-path (comp second @state2) start)
  286
+                            (first (@state2 start))]))
  287
+          
  288
+        (recur (find-intersect))))))
  289
+
136  src/loom/attr.clj
... ...
@@ -0,0 +1,136 @@
  1
+(ns ^{:doc "Graph attribute protocol and implementations for records from
  2
+loom.graph. Common uses for attributes include labels and styling (color,
  3
+thickness, etc)."
  4
+      :author "Justin Kramer"}
  5
+  loom.attr
  6
+  (use [loom.graph :only [directed? nodes edges]])
  7
+  (:import [loom.graph SimpleGraph SimpleDigraph
  8
+            SimpleWeightedGraph SimpleWeightedDigraph
  9
+            FlyGraph FlyDigraph WeightedFlyGraph WeightedFlyDigraph]))
  10
+
  11
+(defprotocol AttrGraph
  12
+  (add-attr [g node k v] [g n1 n2 k v] "Add an attribute to node or edge")
  13
+  (remove-attr [g node k] [g n1 n2 k] "Remove an attribute from a node or edge")
  14
+  (attr [g node k] [g n1 n2 k] "Return the attribute on a node or edge")
  15
+  (attrs [g node] [g n1 n2] "Return all attributes on a node or edge"))
  16
+
  17
+(def default-attr-graph-impl
  18
+  {:add-attr (fn
  19
+               ([g node k v]
  20
+                  (assoc-in g [:attrs node k] v))
  21
+               ([g n1 n2 k v]
  22
+                  (let [g (assoc-in g [:attrs n1 ::edge-attrs n2 k] v)
  23
+                        g (if (directed? g) g
  24
+                              (assoc-in g [:attrs n2 ::edge-attrs n1 k] v))]
  25
+                    g)))
  26
+   :remove-attr (fn
  27
+                  ([g node k]
  28
+                     (update-in g [:attrs node] dissoc k))
  29
+                  ([g n1 n2 k]
  30
+                     (update-in g [:attrs n1 ::edge-attrs n2] dissoc k)))
  31
+   :attr (fn
  32
+           ([g node k]
  33
+              (get-in g [:attrs node k]))
  34
+           ([g n1 n2 k]
  35
+              (get-in g [:attrs n1 ::edge-attrs n2 k])))
  36
+   :attrs (fn
  37
+            ([g node]
  38
+               (dissoc (get-in g [:attrs node]) ::edge-attrs))
  39
+            ([g n1 n2]
  40
+               (get-in g [:attrs n1 ::edge-attrs n2])))})
  41
+
  42
+(extend SimpleGraph
  43
+  AttrGraph
  44
+  default-attr-graph-impl)
  45
+
  46
+(extend SimpleDigraph
  47
+  AttrGraph
  48
+  default-attr-graph-impl)
  49
+
  50
+(extend SimpleWeightedGraph
  51
+  AttrGraph
  52
+  default-attr-graph-impl)
  53
+
  54
+(extend SimpleWeightedDigraph
  55
+  AttrGraph
  56
+  default-attr-graph-impl)
  57
+
  58
+(extend FlyGraph
  59
+  AttrGraph
  60
+  default-attr-graph-impl)
  61
+
  62
+(extend FlyDigraph
  63
+  AttrGraph
  64
+  default-attr-graph-impl)
  65
+
  66
+(extend WeightedFlyGraph
  67
+  AttrGraph
  68
+  default-attr-graph-impl)
  69
+
  70
+(extend WeightedFlyDigraph
  71
+  AttrGraph
  72
+  default-attr-graph-impl)
  73
+
  74
+(defn attr?
  75
+  "Return true if g satisfies AttrGraph"
  76
+  [g]
  77
+  (satisfies? AttrGraph g))
  78
+
  79
+(defn add-attr-to-nodes
  80
+  "Adds an attribute to the given nodes"
  81
+  [g k v nodes]
  82
+  (reduce
  83
+   (fn [g n]
  84
+     (add-attr g n k v))
  85
+   g nodes))
  86
+
  87
+(defn add-attr-to-edges
  88
+  "Adds an attribute to the given nodes"
  89
+  [g k v edges]
  90
+  (reduce
  91
+   (fn [g [n1 n2]]
  92
+     (add-attr g n1 n2 k v))
  93
+   g edges))
  94
+
  95
+(defn add-attr-to-all
  96
+  "Adds an attribute to all nodes and edges"
  97
+  [g k v]
  98
+  (-> g
  99
+      (add-attr-to-nodes k v (nodes g))
  100
+      (add-attr-to-edges k v (edges g))))
  101
+
  102
+(defn add-attrs-to-all
  103
+  "Adds attributes to all nodes and edges"
  104
+  [g & kvs]
  105
+  (reduce
  106
+   (fn [g [k v]]
  107
+     (-> g
  108
+         (add-attr-to-nodes k v (nodes g))
  109
+         (add-attr-to-edges k v (edges g))))
  110
+   g (partition 2 1 kvs)))
  111
+
  112
+
  113
+(defn hilite
  114
+  "Adds a red :color attribute to a node or edge"
  115
+  ([g node]
  116
+     (-> g
  117
+         (add-attr node :color :red)
  118
+         (add-attr node :fontcolor :red)
  119
+         (add-attr node :fillcolor "#ffeeee")
  120
+         (add-attr node :style "filled,bold")))
  121
+  ([g n1 n2]
  122
+     (-> g
  123
+         (add-attr n1 n2 :color :red)
  124
+         (add-attr n1 n2 :fontcolor :red)
  125
+         (add-attr n1 n2 :style :bold))))
  126
+
  127
+(defn hilite-path
  128
+  "Hilites nodes and edges along a path"
  129
+  [g path]
  130
+  (reduce
  131
+   (fn [g [n1 n2]]
  132
+     (-> g
  133
+         (hilite n1)
  134
+         (hilite n2)
  135
+         (hilite n1 n2)))
  136
+   g (partition 2 1 path)))
54  src/loom/gen.clj
... ...
@@ -0,0 +1,54 @@
  1
+(ns ^{:doc "Graph-generating functions"
  2
+      :author "Justin Kramer"}
  3
+  loom.gen
  4
+  (:use [loom.graph :only [weighted? directed? add-nodes* add-edges*]]))
  5
+
  6
+(defn gen-rand
  7
+  "Adds num-nodes nodes and approximately num-edges edges to graph g. Nodes
  8
+  used for each edge are chosen at random and may be chosen more than once."
  9
+  [g num-nodes num-edges & {:keys [min-weight max-weight loops seed]
  10
+                            :or {min-weight 1
  11
+                                 max-weight 1
  12
+                                 loops false
  13
+                                 seed (System/nanoTime)}}]
  14
+  (let [rnd (java.util.Random. seed)
  15
+        rand-w #(+ (.nextInt rnd (- max-weight min-weight)) min-weight)
  16
+        rand-n #(.nextInt rnd num-nodes)
  17
+        weighted? (weighted? g)
  18
+        nodes (range num-nodes)
  19
+        edges (for [_ (range num-edges)
  20
+                    :let [n1 (rand-n) n2 (rand-n)]
  21
+                    :when (or loops (not= n1 n2))]
  22
+                (if weighted?
  23
+                  [n1 n2 (rand-w)]
  24
+                  [n1 n2]))]
  25
+    (-> g
  26
+        (add-nodes* nodes)
  27
+        (add-edges* edges))))
  28
+
  29
+(defn gen-rand-p
  30
+  "Adds num-nodes nodes to graph g with the probably p of an edge between
  31
+  each node."
  32
+  [g num-nodes p & {:keys [min-weight max-weight loops seed]
  33
+                    :or {min-weight 1
  34
+                         max-weight 1
  35
+                         loops false
  36
+                         seed (System/nanoTime)}}]
  37
+  (let [rnd (java.util.Random. seed)
  38
+        rand-w #(+ (.nextInt rnd (- max-weight min-weight)) min-weight)
  39
+        directed? (directed? g)
  40
+        weighted? (weighted? g)
  41
+        nodes (range num-nodes)
  42
+        edges (for [n1 nodes n2 nodes
  43
+                    :when (and (if directed?
  44
+                                 (or loops (not= n1 n2))
  45
+                                 (or (> n1 n2)
  46
+                                     (and loops (= n1 n2))))
  47
+                               (> p (.nextDouble rnd)))]
  48
+                (if weighted?
  49
+                  [n1 n2 (rand-w)]
  50
+                  [n1 n2]))]
  51
+    (-> g
  52
+        (add-nodes* nodes)
  53
+        (add-edges* edges))))
  54
+
459  src/loom/graph.clj
... ...
@@ -0,0 +1,459 @@
  1
+(ns ^{:doc "Defines protocols for graphs, digraphs, and weighted graphs.
  2
+
  3
+Also provides record implementations and constructors for simple graphs --
  4
+weighted, unweighted, directed, and undirected. The implementations are based
  5
+on adjacency lists."
  6
+      :author "Justin Kramer"}
  7
+  loom.graph
  8
+  (:use [loom.alg-generic :only [bf-traverse]]))
  9
+
  10
+;(set! *warn-on-reflection* true)
  11
+
  12
+;;;
  13
+;;; Protocols
  14
+;;;
  15
+
  16
+(defprotocol Graph
  17
+  (add-nodes* [g nodes] "Add nodes to graph g. See add-nodes")
  18
+  (add-edges* [g edges] "Add edges to graph g. See add-edges")
  19
+  (remove-nodes* [g nodes] "Remove nodes from graph g. See remove-nodes")
  20
+  (remove-edges* [g edges] "Removes edges from graph g. See remove-edges")
  21
+  (remove-all [g] "Removes all nodes and edges from graph g")
  22
+  (nodes [g] "Return a collection of the nodes in graph g")
  23
+  (edges [g] "Edges in g. May return each edge twice in an undirected graph")
  24
+  (has-node? [g node] "Return true when node is in g")
  25
+  (has-edge? [g n1 n2] "Return true when edge [n1 n2] is in g")
  26
+  (neighbors [g] [g node] "Return adjacent nodes, or (partial neighbors g)")
  27
+  (degree [g node] "Return the number of nodes adjacent to node"))
  28
+
  29
+(defprotocol Digraph
  30
+  (incoming [g node] "Return direct predecessors of node")
  31
+  (in-degree [g node] "Return the number direct predecessors to node")
  32
+  (transpose [g] "Return a graph with all edges reversed"))
  33
+
  34
+(defprotocol WeightedGraph
  35
+  (weight [g] [g n1 n2] "Return weight of edge [n1 n2] or (partial weight g)"))
  36
+
  37
+;; Variadic wrappers
  38
+
  39
+(defn add-nodes
  40
+  "Add nodes to graph g. Nodes can be any type of object"
  41
+  [g & nodes]
  42
+  (add-nodes* g nodes))
  43
+
  44
+(defn add-edges
  45
+  "Add edges to graph g. For unweighted graphs, edges take the form [n1 n2].
  46
+  For weighted graphs, edges take the form [n1 n2 weight] or [n1 n2], the
  47
+  latter defaulting to a weight of 1"
  48
+  [g & edges]
  49
+  (add-edges* g edges))
  50
+
  51
+(defn remove-nodes
  52
+  "Remove nodes from graph g"
  53
+  [g & nodes]
  54
+  (remove-nodes* g nodes))
  55
+
  56
+(defn remove-edges
  57
+  "Remove edges from graph g. Do not include weights"
  58
+  [g & edges]
  59
+  (remove-edges* g edges))
  60
+
  61
+;;;
  62
+;;; Records for simple graphs -- one edge per vertex pair/direction,
  63
+;;; loops allowed
  64
+;;;
  65
+;; TODO: allow custom weight fn?
  66
+
  67
+(defrecord SimpleGraph [nodeset adj])
  68
+(defrecord SimpleDigraph [nodeset adj in])
  69
+(defrecord SimpleWeightedGraph [nodeset adj])
  70
+(defrecord SimpleWeightedDigraph [nodeset adj in])
  71
+
  72
+(def ^{:doc "Weight used when none is given for edges in weighted graphs"}
  73
+  *default-weight* 1)
  74
+
  75
+(def default-graph-impls
  76
+  {:all
  77
+   {:nodes (fn [g]
  78
+             (:nodeset g))
  79
+    :edges (fn [g]
  80
+             (for [n1 (nodes g)
  81
+                   n2 (neighbors g n1)]
  82
+               [n1 n2]))
  83
+    :has-node? (fn [g node]
  84
+                 (contains? (:nodeset g) node))
  85
+    :has-edge? (fn [g n1 n2]
  86
+                 (contains? (get-in g [:adj n1]) n2))
  87
+    :degree (fn [g node]
  88
+              (count (get-in g [:adj node])))}
  89
+
  90
+   ;; Unweighted graphs store adjacencies as {node #{neighbor}}
  91
+   :unweighted
  92
+   {:add-nodes* (fn [g nodes]
  93
+                  (reduce
  94
+                   (fn [g n]
  95
+                     (-> g
  96
+                         (update-in [:nodeset] conj n)
  97
+                         (assoc-in [:adj n] (or ((:adj g) n) #{}))))
  98
+                   g nodes))
  99
+    :neighbors (fn
  100
+                 ([g] (partial neighbors g))
  101
+                 ([g node] (get-in g [:adj node])))}
  102
+   
  103
+   ;; Weighted graphs store adjacencies as {node {neighbor weight}}
  104
+   :weighted
  105
+   {:add-nodes* (fn [g nodes]
  106
+                  (reduce
  107
+                   (fn [g n]
  108
+                     (-> g
  109
+                         (update-in [:nodeset] conj n)
  110
+                         (assoc-in [:adj n] (or ((:adj g) n) {}))))
  111
+                   g nodes))
  112
+    :neighbors (fn
  113
+                 ([g] (partial neighbors g))
  114
+                 ([g node] (keys (get-in g [:adj node]))))}})
  115
+
  116
+(def default-digraph-impl
  117
+  {:incoming (fn [g node]
  118
+               (get-in g [:in node]))
  119
+   :in-degree (fn [g node]
  120
+                (count (get-in g [:in node])))})
  121
+
  122
+(def default-weighted-graph-impl
  123
+  {:weight (fn
  124
+             ([g] (partial weight g))
  125
+             ([g n1 n2] (get-in g [:adj n1 n2])))})
  126
+
  127
+(defn- remove-adj-nodes [m nodes adjacents remove-fn]
  128
+  (reduce
  129
+   (fn [m n]
  130
+     (if (m n)
  131
+       (update-in m [n] #(apply remove-fn % nodes))
  132
+       m))
  133
+   (apply dissoc m nodes)
  134
+   adjacents))
  135
+
  136
+(extend SimpleGraph
  137
+  Graph
  138
+  (assoc (apply merge (map default-graph-impls [:all :unweighted]))
  139
+
  140
+    :add-edges*
  141
+    (fn [g edges]
  142
+      (reduce
  143
+       (fn [g [n1 n2]]
  144
+         (-> g
  145
+             (update-in [:nodeset] conj n1 n2)
  146
+             (update-in [:adj n1] (fnil conj #{}) n2)
  147
+             (update-in [:adj n2] (fnil conj #{}) n1)))
  148
+       g edges))
  149
+    
  150
+    :remove-nodes*
  151
+    (fn [g nodes]
  152
+      (let [nbrs (mapcat #(neighbors g %) nodes)]
  153
+        (-> g
  154
+            (update-in [:nodeset] #(apply disj % nodes))
  155
+            (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs disj)))))
  156
+    
  157
+    :remove-edges*
  158
+    (fn [g edges]
  159
+      (reduce
  160
+       (fn [g [n1 n2]]
  161
+         (-> g
  162
+             (update-in [:adj n1] disj n2)
  163
+             (update-in [:adj n2] disj n1)))
  164
+       g edges))
  165
+
  166
+    :remove-all
  167
+    (fn [g]
  168
+      (assoc g :nodeset #{} :adj {}))))
  169
+
  170
+(extend SimpleDigraph
  171
+  Graph
  172
+  (assoc (apply merge (map default-graph-impls [:all :unweighted]))
  173
+    
  174
+    :add-edges*
  175
+    (fn [g edges]
  176
+      (reduce
  177
+       (fn [g [n1 n2]]
  178
+         (-> g
  179
+             (update-in [:nodeset] conj n1 n2)
  180
+             (update-in [:adj n1] (fnil conj #{}) n2)
  181
+             (update-in [:in n2] (fnil conj #{}) n1)))
  182
+       g edges))
  183
+    
  184
+    :remove-nodes*
  185
+    (fn [g nodes]
  186
+      (let [ins (mapcat #(incoming g %) nodes)
  187
+            outs (mapcat #(neighbors g %) nodes)]
  188
+        (-> g
  189
+            (update-in [:nodeset] #(apply disj % nodes))
  190
+            (assoc :adj (remove-adj-nodes (:adj g) nodes ins disj))
  191
+            (assoc :in (remove-adj-nodes (:in g) nodes outs disj)))))
  192
+    
  193
+    :remove-edges*
  194
+    (fn [g edges]
  195
+      (reduce
  196
+       (fn [g [n1 n2]]
  197
+         (-> g
  198
+             (update-in [:adj n1] disj n2)
  199
+             (update-in [:in n2] disj n1)))
  200
+       g edges))
  201
+
  202
+    :remove-all
  203
+    (fn [g]
  204
+      (assoc g :nodeset #{} :adj {} :in {})))
  205
+
  206
+  Digraph
  207
+  (assoc default-digraph-impl
  208
+    :transpose (fn [g]
  209
+                 (assoc g :adj (:in g) :in (:adj g)))))
  210
+
  211
+(extend SimpleWeightedGraph
  212
+  Graph
  213
+  (assoc (apply merge (map default-graph-impls [:all :weighted]))
  214
+
  215
+    :add-edges*
  216
+    (fn [g edges]
  217
+      (reduce
  218
+       (fn [g [n1 n2 & [w]]]
  219
+         (-> g
  220
+             (update-in [:nodeset] conj n1 n2)
  221
+             (assoc-in [:adj n1 n2] (or w *default-weight*))
  222
+             (assoc-in [:adj n2 n1] (or w *default-weight*))))
  223
+       g edges))
  224
+    
  225
+    :remove-nodes*
  226
+    (fn [g nodes]
  227
+      (let [nbrs (mapcat #(neighbors g %) nodes)]
  228
+        (-> g
  229
+            (update-in [:nodeset] #(apply disj % nodes))
  230
+            (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs dissoc)))))
  231
+    
  232
+    :remove-edges*
  233
+    (fn [g edges]
  234
+      (reduce
  235
+       (fn [g [n1 n2]]
  236
+         (-> g
  237
+             (update-in [:adj n1] dissoc n2)
  238
+             (update-in [:adj n2] dissoc n1)))
  239
+       g edges))
  240
+
  241
+    :remove-all
  242
+    (fn [g]
  243
+      (assoc g :nodeset #{} :adj {})))
  244
+  
  245
+  WeightedGraph
  246
+  default-weighted-graph-impl)
  247
+
  248
+(extend SimpleWeightedDigraph
  249
+  Graph
  250
+  (assoc (apply merge (map default-graph-impls [:all :weighted]))
  251
+    
  252
+    :add-edges*
  253
+    (fn [g edges]
  254
+      (reduce
  255
+       (fn [g [n1 n2 & [w]]]
  256
+         (-> g
  257
+             (update-in [:nodeset] conj n1 n2)
  258
+             (assoc-in [:adj n1 n2] (or w *default-weight*))
  259
+             (update-in [:in n2] (fnil conj #{}) n1)))
  260
+       g edges))
  261
+    
  262
+    :remove-nodes*
  263
+    (fn [g nodes]
  264
+      (let [ins (mapcat #(incoming g %) nodes)
  265
+            outs (mapcat #(neighbors g %) nodes)]
  266
+        (-> g
  267
+            (update-in [:nodeset] #(apply disj % nodes))
  268
+            (assoc :adj (remove-adj-nodes (:adj g) nodes ins dissoc))
  269
+            (assoc :in (remove-adj-nodes (:in g) nodes outs disj)))))
  270
+    
  271
+    :remove-edges*
  272
+    (fn [g edges]
  273
+      (reduce
  274
+       (fn [g [n1 n2]]
  275
+         (-> g
  276
+             (update-in [:adj n1] dissoc n2)
  277
+             (update-in [:in n2] disj n1)))
  278
+       g edges))
  279
+
  280
+    :remove-all
  281
+    (fn [g]
  282
+      (assoc g :nodeset #{} :adj {}) :in {}))
  283
+
  284
+  Digraph
  285
+  (assoc default-digraph-impl
  286
+    :transpose (fn [g]
  287
+                 (reduce (fn [tg [n1 n2]]
  288
+                             (add-edges* tg [[n2 n1 (weight g n1 n2)]]))
  289
+                         (assoc g :adj {} :in {})
  290
+                         (edges g))))
  291
+  
  292
+  WeightedGraph
  293
+  default-weighted-graph-impl)
  294
+
  295
+;;;
  296
+;;; FlyGraph -- a read-only, ad-hoc graph which uses provided functions to
  297
+;;; return values for nodes, edges, etc. Members which are not functions get
  298
+;;; returned as-is. Edges will be inferred if nodes and neighbors are provided.
  299
+;;; Nodes and edges will be inferred if neighbors and start are provided.
  300
+;;;
  301
+
  302
+(defn- call-or-return [f & args]
  303
+  (if (or (fn? f)
  304
+          (and (instance? clojure.lang.IFn f) (seq args)))
  305
+    (apply f args)
  306
+    f))
  307
+
  308
+(def ^{:private true} default-flygraph-graph-impl
  309
+  {:nodes (fn [g]
  310
+            (if (or (:fnodes g) (not (:start g)))
  311
+              (call-or-return (:fnodes g))
  312
+              (bf-traverse (neighbors g) (:start g))))
  313
+   :edges (fn [g]
  314
+            (if (:fedges g)
  315
+              (call-or-return (:fedges g))
  316
+              (for [n (nodes g)
  317
+                    nbr (neighbors g n)]
  318
+                [n nbr])))
  319
+   :neighbors (fn
  320
+                ([g] (partial neighbors g))
  321
+                ([g node] (call-or-return (:fneighbors g) node)))})
  322
+
  323
+(def ^{:private true} default-flygraph-digraph-impl
  324
+  {:incoming (fn [g node] (call-or-return (:fincoming g) node))})
  325
+
  326
+(def ^{:private true} default-flygraph-weighted-impl
  327
+  {:weight (fn [g n1 n2] (call-or-return (:fweight g) n1 n2))})
  328
+
  329
+(defrecord FlyGraph [fnodes fedges fneighbors start])
  330
+(defrecord FlyDigraph [fnodes fedges fneighbors fincoming start])
  331
+(defrecord WeightedFlyGraph [fnodes fedges fneighbors fweight start])
  332
+(defrecord WeightedFlyDigraph [fnodes fedges fneighbors fincoming fweight start])
  333
+
  334
+(extend FlyGraph
  335
+  Graph default-flygraph-graph-impl)
  336
+
  337