Skip to content
Fetching contributors… Cannot retrieve contributors at this time
335 lines (310 sloc) 12.5 KB
 (ns ^{:doc "Graph algorithms for use on any type of graph" :author "Justin Kramer"} loom.alg-generic) ;;; ;;; 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 #{}}}] (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] (conj seen start)))) ;; TODO: graph-seq, analog of tree-seq (defn pre-span "Return a depth-first spanning tree of the form {node [successors]}" [neighbors start & {:keys [seen return-seen] :or {seen #{}}}] (loop [seen seen preds {start nil} stack [start]] (if (empty? stack) ;; TODO: this is awkward, devise something better (if return-seen [(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 return-seen] :or {seen #{}}}] ;; For most graphs, being lazy wouldn't matter (loop [seen seen result [] stack [start]] (if (empty? stack) (if return-seen [result seen] 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 ;;; (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 depth) for each node traversed. Otherwise, returns a lazy seq of the nodes. When :when is provided, filters neighbors with (f neighbor predecessor depth)." [neighbors start & {:keys [f when seen]}] (let [f (or f (fn [n p d] n)) nbr-pred (or when (constantly true))] (letfn [(step [queue preds] (when-let [[node depth] (peek queue)] (cons (f node preds depth) (lazy-seq (let [nbrs (->> (neighbors node) (remove #(contains? preds %)) (filter #(nbr-pred % node (inc depth))))] (step (into (pop queue) (for [nbr nbrs] [nbr (inc depth)])) (reduce #(assoc %1 %2 node) preds nbrs)))))))] (step (conj clojure.lang.PersistentQueue/EMPTY [start 0]) (if (map? seen) (assoc seen start nil) (into {start nil} (for [s seen] [s nil]))))))) (defn bf-span "Return a breadth-first spanning tree of the form {node [successors]}" [neighbors start & {:keys [seen]}] (preds->span (last (bf-traverse neighbors start :f (fn [_ pm _] pm) :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 & {:as opts}] (let [opts (merge opts {:f vector})] (when-let [preds (some (fn [[_ pm _]] (when (pm end) pm)) (apply bf-traverse neighbors start (apply concat opts)))] (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), outgoing and incoming being functions which return adjacent nodes. Can be much faster than a unidirectional search on certain types of graphs" [outgoing incoming start end] (let [done? (atom false) preds1 (atom {}) ;from start to end preds2 (atom {}) ;from end to start search (fn [nbrs n preds] (dorun (take-while (fn [_] (not @done?)) (bf-traverse nbrs n :f (fn [_ pm _] (reset! preds pm)))))) search1 (future (search outgoing start preds1)) search2 (future (search incoming end preds2)) ;; TODO: watchers? find-intersects #(shared-keys @preds1 @preds2)] (loop [intersects (find-intersects)] (if (or (seq intersects) (future-done? search1) (future-done? search2)) (do (reset! done? true) (cond (seq intersects) (let [intersect (apply min-key #(+ (count (trace-path @preds1 %)) (count (trace-path @preds2 %))) intersects)] (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-intersects)))))) ;; FIXME: Decide whether this can be optimized and is worth keeping #_(defn bf-path-bi2 "Non-threaded version of bf-path-bi. Tends to be slower." [outgoing incoming start end] (loop [preds {start nil} succs {end nil} q1 [start] q2 [end]] (when (and (seq q1) (seq q2)) (if (<= (count q1) (count q2)) (let [pairs (for [node q1 nbr (outgoing node) :when (not (contains? preds nbr))] [nbr node]) preds (into preds pairs) q1 (map first pairs)] (if-let [i (some #(when (contains? succs %) %) q1)] (concat (reverse (trace-path preds i)) (rest (trace-path succs i))) (recur preds succs q1 q2))) (let [pairs (for [node q2 nbr (incoming node) :when (not (contains? succs nbr))] [nbr node]) succs (into succs pairs) q2 (map first pairs)] (if-let [i (some #(when (contains? preds %) %) q2)] (concat (reverse (trace-path preds i)) (rest (trace-path succs i))) (recur preds succs q1 q2))))))) ;;; ;;; 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))))))
You can’t perform that action at this time.