Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Generalized weight-aggregation functions instead of only + #79

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Generalized weight-aggregation functions instead of only + #79

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
5af8eed
Generalized weight-aggregation functions instead of only `+`
alexandergunnarson Jan 27, 2016
d371bf0
Fixed arity problem with `bf-all-pairs-shortest-paths`
alexandergunnarson Jan 27, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
164 changes: 84 additions & 80 deletions src/loom/alg.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -138,13 +138,11 @@ can use these functions."
"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
(graph/successors g) (graph/weight g) (first (nodes g))))
([g start]
(gen/dijkstra-traverse (graph/successors g) (graph/weight g) start vector))
([g start f]
(gen/dijkstra-traverse (graph/successors g) (graph/weight g) start f)))
([g ] (gen/dijkstra-traverse (graph/successors g) (graph/weight g)
(first (nodes g))))
([g start ] (gen/dijkstra-traverse (graph/successors g) (graph/weight g) start))
([g start f ] (gen/dijkstra-traverse (graph/successors g) (graph/weight g) start f))
([g start f waf] (gen/dijkstra-traverse (graph/successors g) (graph/weight g) start f waf)))

(defn dijkstra-span
"Finds all shortest distances from start. Returns a map in the
Expand All @@ -166,32 +164,33 @@ can use these functions."
[g start end]
(first (dijkstra-path-dist g start end)))

#?(:clj
(defn- can-relax-edge?
"Tests for whether we can improve the shortest path to v found so far
by going through u."
[[u v :as edge] weight costs]
[[u v :as edge] weight costs waf]
(let [vd (get costs v)
ud (get costs u)
sum (+ ud weight)]
(> vd sum)))
aggregated (waf ud weight)]
(> vd aggregated))))

(defn- relax-edge
"If there's a shorter path from s to v via u,
update our map of estimated path costs and
map of paths from source to vertex v"
[[u v :as edge] weight [costs paths :as estimates]]
[[u v :as edge] weight [costs paths :as estimates] waf]
(let [ud (get costs u)
sum (+ ud weight)]
(if (can-relax-edge? edge weight costs)
[(assoc costs v sum) (assoc paths v u)]
aggregated (waf ud weight)]
(if (can-relax-edge? edge weight costs waf)
[(assoc costs v aggregated) (assoc paths v u)]
estimates)))

(defn- relax-edges
"Performs edge relaxation on all edges in weighted directed graph"
[g start estimates]
[g start estimates waf]
(->> (edges g)
(reduce (fn [estimates [u v :as edge]]
(relax-edge edge (graph/weight g u v) estimates))
(relax-edge edge (graph/weight g u v) estimates waf))
estimates)))

(defn- init-estimates
Expand Down Expand Up @@ -220,36 +219,37 @@ can use these functions."
paths and their costs if no negative-weight cycle that is reachable
from the source exists, and false otherwise, indicating that no
solution exists."
[g start]
(let [initial-estimates (init-estimates g start)
;;relax-edges is calculated for all edges V-1 times
[costs paths] (reduce (fn [estimates _]
(relax-edges g start estimates))
initial-estimates
(-> g nodes count dec range))
edges (edges g)]
(if (some
(fn [[u v :as edge]]
(can-relax-edge? edge (graph/weight g u v) costs))
edges)
false
[costs
(->> (keys paths)
;;remove vertices that are unreachable from source
(remove #(= #?(:clj Double/POSITIVE_INFINITY
:cljs js/Infinity)
(get costs %)))
(reduce
(fn [final-paths v]
(assoc final-paths v
;; follows the parent pointers
;; to construct path from source to node v
(loop [node v
path ()]
(if node
(recur (get paths node) (cons node path))
path))))
{}))])))
([g start] (bellman-ford g start +))
([g start waf]
(let [initial-estimates (init-estimates g start)
;;relax-edges is calculated for all edges V-1 times
[costs paths] (reduce (fn [estimates _]
(relax-edges g start estimates waf))
initial-estimates
(-> g nodes count dec range))
edges (edges g)]
(if (some
(fn [[u v :as edge]]
(can-relax-edge? edge (graph/weight g u v) costs waf))
edges)
false
[costs
(->> (keys paths)
;;remove vertices that are unreachable from source
(remove #(= #?(:clj Double/POSITIVE_INFINITY
:cljs js/Infinity)
(get costs %)))
(reduce
(fn [final-paths v]
(assoc final-paths v
;; follows the parent pointers
;; to construct path from source to node v
(loop [node v
path ()]
(if node
(recur (get paths node) (cons node path))
path))))
{}))]))))

(defn dag?
"Returns true if g is a directed acyclic graph"
Expand Down Expand Up @@ -285,18 +285,20 @@ can use these functions."

(defn- bellman-ford-transform
"Helper function for Johnson's algorithm. Uses Bellman-Ford to remove negative weights."
[wg]
(let [q (first (drop-while (partial graph/has-node? wg) (repeatedly gensym)))
es (for [v (graph/nodes wg)] [q v 0])
bf-results (bellman-ford (graph/add-edges* wg es) q)]
(if bf-results
(let [[dist-q _] bf-results
new-es (map (juxt first second (fn [[u v]]
(+ (weight wg u v) (- (dist-q u)
(dist-q v)))))
(graph/edges wg))]
(graph/add-edges* wg new-es))
false)))
([wg] (bellman-ford-transform +))
([wg waf]
(let [q (first (drop-while (partial graph/has-node? wg) (repeatedly gensym)))
es (for [v (graph/nodes wg)] [q v 0])
bf-results (bellman-ford (graph/add-edges* wg es) q)]
(if bf-results
(let [[dist-q _] bf-results
new-es (map (juxt first second (fn [[u v]]
(waf (weight wg u v)
((gen/inverse waf) (dist-q u)
(dist-q v)))))
(graph/edges wg))]
(graph/add-edges* wg new-es))
false))))

(defn johnson
"Finds all-pairs shortest paths using Bellman-Ford to remove any negative edges before
Expand All @@ -307,35 +309,37 @@ can use these functions."
to use breadth-first spans for a graph with a uniform edge weight rather than Dijkstra's algorithm.
Most callers should use shortest-paths and allow the most efficient implementation be selected
for the graph."
[g]
(let [g (if (and (weighted? g) (some (partial > 0) (map (graph/weight g) (graph/edges g))))
(bellman-ford-transform g)
g)]
(if (false? g)
false
(let [dist (if (weighted? g)
(weight g)
(fn [u v] (when (graph/has-edge? g u v) 1)))]
(reduce (fn [acc node]
(assoc acc node (gen/dijkstra-span (successors g) dist node)))
{}
(nodes g))))))
([g] (johnson g +))
([g waf]
(let [g (if (and (weighted? g) (some (partial > 0) (map (graph/weight g) (graph/edges g))))
(bellman-ford-transform g waf)
g)]
(if (false? g)
false
(let [dist (if (weighted? g)
(weight g)
(fn [u v] (when (graph/has-edge? g u v) 1)))]
(reduce (fn [acc node]
(assoc acc node (gen/dijkstra-span (successors g) dist node waf)))
{}
(nodes g)))))))

(defn bf-all-pairs-shortest-paths
"Uses bf-span on each node in the graph."
[g]
(reduce (fn [spans node]
(assoc spans node (bf-span g node)))
{}
(nodes g)))
([g]
(reduce (fn [spans node]
(assoc spans node (bf-span g node)))
{}
(nodes g))))

(defn all-pairs-shortest-paths
"Finds all-pairs shortest paths in a graph. Uses Johnson's algorithm for weighted graphs
which is efficient for sparse graphs. Breadth-first spans are used for unweighted graphs."
[g]
(if (weighted? g)
(johnson g)
(bf-all-pairs-shortest-paths g)))
([g] (all-pairs-shortest-paths g +))
([g waf]
(if (weighted? g)
(johnson g waf)
(bf-all-pairs-shortest-paths g))))

(defn connected-components
"Returns the connected components of graph g as a vector of vectors. If g
Expand Down
67 changes: 57 additions & 10 deletions src/loom/alg_generic.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,50 @@
(:refer-clojure :exclude [ancestors])
(:import [java.util Arrays]))

;;;
;;; Weight-aggregation functions and inverses
;;;

(def inverse-map ; some better way of doing this?
{+ -
- +
/ *
* /})

(defn inverse
"Gets the inverse of the function `f`."
{:tests '{(inverse +) -
(inverse *) /}
:todo "Make this better. E.g. intelligent inverse of more
complex functions"}
[f]
(or (get inverse-map f)
(throw (#?(:clj IllegalArgumentException.
:cljs js/Error.)
(str "Inverse not defined for function: " (str f))))))

(def ^{:doc "Base values for operators.
E.g. "}
base-map
{+ 0
- 0
/ 1
* 1})

(defn base
"Gets the identity-base for the given function `f`.

For instance:
The identity-base of the `+` function is 0: (= x (+ x 0)).
By contrast, that of the `*` function is 1: (= x (* x 0))"
{:tests '{(base +) 0
(base *) 1}}
[f]
(or (get base-map f)
(throw (#?(:clj IllegalArgumentException.
:cljs js/Error.)
(str "Base not defined for function: " (str f))))))

;;;
;;; Utility functions
;;;
Expand Down Expand Up @@ -353,6 +397,8 @@
([successors dist start]
(dijkstra-traverse successors dist start vector))
([successors dist start f]
(dijkstra-traverse successors dist start f +))
([successors dist start f waf]
(letfn [(step [[state pq]]
(when-let [[dist-su _ u :as fpq] (first pq)]
(cons
Expand All @@ -372,26 +418,27 @@
(conj pq [dist-suv (hash v) v])]))))
[state (disj pq fpq)]
(successors u)))))))]
(step [{start [0 nil]}
(step [{start [(base waf) 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])]))))
(sorted-set [(base waf) (hash start) start])]))))

(defn dijkstra-span
"Finds all shortest distances from start, where successors and dist
are functions called as (successors node) and (dist node1 node2).
Returns a map in the format {node {successor distance}}"
[successors dist start]
(reduce
(fn [span [n [d p]]]
(if p
(assoc-in span [p n] d)
span))
{}
(second (last (dijkstra-traverse successors dist start)))))
([successors dist start] (dijkstra-span successors dist start +))
([successors dist start waf]
(reduce
(fn [span [n [d p]]]
(if p
(assoc-in span [p n] d)
span))
{}
(second (last (dijkstra-traverse successors dist start vector waf))))))

(defn dijkstra-path-dist
"Finds the shortest path from start to end, where successors and dist
Expand Down