Skip to content

Instantly share code, notes, and snippets.

@cgrand

cgrand/tarjan.clj

Last active November 18, 2020 03:08
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save cgrand/5188919 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save cgrand/5188919 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. cgrand revised this gist Mar 18, 2013. 1 changed file with 8 additions and 11 deletions.
    19 changes: 8 additions & 11 deletions tarjan.clj
    View file
    Original file line number Diff line number Diff line change
    @@ -1,13 +1,13 @@
    ;; Relaize that only the stack size matters, env now maps nodes to "low" or nil.
    ;; Now, replace the loop by more telling operations.

    (defn tarjan
    "Returns the strongly connected components of a graph specified by its nodes
    and a successor function succs from node to nodes.
    The used algorithm is Tarjan's one."
    [nodes succs]
    (letfn [(sc [env node]
    ; env is a map from nodes to stack length or nil, nil means the node is known to belong to another SCC
    ; there are two special keys: ::stack for the current stack and ::sccs for the current set of SCCs
    ; env is a map from nodes to stack length or nil, nil means the node is known to belong to another SCC
    ; there are two special keys: ::stack for the current stack and ::sccs for the current set of SCCs
    #_{:post [(contains? % node)]}
    (if (contains? env node)
    env
    @@ -19,16 +19,13 @@
    (assoc env node (min (or (env succ) n) (env node)))))
    env (succs node))]
    (if (= n (env node)) ; no link below us in the stack, call it a SCC
    (loop [scc #{} nodes (::stack env) env env]
    (let [curr (peek nodes)
    scc (conj scc curr)
    env (assoc env curr nil)] ; clear all stack lengths for this SCC's nodes since this SCC is done
    (if (= curr node)
    (assoc env ::stack stack ::sccs (conj (::sccs env) scc))
    (recur scc (pop nodes) env))))
    (let [nodes (::stack env)
    scc (set (take (- (count nodes) n) nodes))
    env (reduce #(assoc %1 %2 nil) env scc)] ; clear all stack lengths for these nodes since this SCC is done
    (assoc env ::stack stack ::sccs (conj (::sccs env) scc)))
    env))))]
    (::sccs (reduce sc {::stack () ::sccs #{}} nodes))))

    => (def g {:c #{:d} :a #{:b :c} :b #{:a :c}})
    => (tarjan (keys g) g)
    #{#{:c} #{:d} #{:a :b}}
    #{#{:c} #{:d} #{:a :b}}
  2. cgrand revised this gist Mar 18, 2013. 1 changed file with 18 additions and 16 deletions.
    34 changes: 18 additions & 16 deletions tarjan.clj
    View file
    Original file line number Diff line number Diff line change
    @@ -1,32 +1,34 @@
    ;; having a map with only one entry is a bit of a waste, so env now directly maps a node
    ;; to a "lowest" stack or nil if not "on stack" anymore
    ;; Relaize that only the stack size matters, env now maps nodes to "low" or nil.

    (defn tarjan [nodes succs]
    (defn tarjan
    "Returns the strongly connected components of a graph specified by its nodes
    and a successor function succs from node to nodes.
    The used algorithm is Tarjan's one."
    [nodes succs]
    (letfn [(sc [env node]
    ; env is a map from nodes to stack length or nil, nil means the node is known to belong to another SCC
    ; there are two special keys: ::stack for the current stack and ::sccs for the current set of SCCs
    #_{:post [(contains? % node)]}
    (if (contains? env node)
    env
    (let [stack (::stack env)
    env (assoc env node stack ::stack (conj stack node))
    (let [stack (::stack env)
    n (count stack)
    env (assoc env node n ::stack (conj stack node))
    env (reduce (fn [env succ]
    (let [env (sc env succ)]
    (if-let [stack (env succ)]
    (assoc env node
    (min-key count stack (env node)))
    env)))
    env (succs node))]
    (if (= stack (env node))
    (assoc env node (min (or (env succ) n) (env node)))))
    env (succs node))]
    (if (= n (env node)) ; no link below us in the stack, call it a SCC
    (loop [scc #{} nodes (::stack env) env env]
    (let [curr (peek nodes)
    scc (conj scc curr)
    env (assoc env curr nil)]
    env (assoc env curr nil)] ; clear all stack lengths for this SCC's nodes since this SCC is done
    (if (= curr node)
    (-> env
    (update-in [::sccs] conj scc)
    (assoc ::stack stack))
    (assoc env ::stack stack ::sccs (conj (::sccs env) scc))
    (recur scc (pop nodes) env))))
    env))))]
    (::sccs (reduce sc {::stack () ::sccs #{}} nodes))))

    => (def g {:c #{:d} :a #{:b :c} :b #{:a :c}})
    => (tarjan (keys g) g)
    #{#{:c} #{:d} #{:a :b}}
    #{#{:c} #{:d} #{:a :b}}
  3. cgrand revised this gist Mar 18, 2013. 1 changed file with 17 additions and 18 deletions.
    35 changes: 17 additions & 18 deletions tarjan.clj
    View file
    Original file line number Diff line number Diff line change
    @@ -1,33 +1,32 @@
    ;; switch to explicit lists, instead of implicit chaining
    ;; the explicit list is the the "lowest" stack so :low is not needed anymore
    ;; having a map with only one entry is a bit of a waste, so env now directly maps a node
    ;; to a "lowest" stack or nil if not "on stack" anymore

    (defn tarjan [nodes succs]
    (letfn [(sc [env node]
    (if (env node)
    (if (contains? env node)
    env
    (let [prevs (::prevs env)
    env (assoc env node {:prevs prevs}
    ::prevs (conj prevs node))
    (let [stack (::stack env)
    env (assoc env node stack ::stack (conj stack node))
    env (reduce (fn [env succ]
    (let [env (sc env succ)
    prevs (:prevs (env succ) prevs)]
    (update-in env [node :prevs]
    (partial min-key count) prevs)))
    env (succs node))
    prevs' (:prevs (env node))]
    (if (= prevs prevs')
    (loop [scc #{} nodes (::prevs env) env env]
    (let [env (sc env succ)]
    (if-let [stack (env succ)]
    (assoc env node
    (min-key count stack (env node)))
    env)))
    env (succs node))]
    (if (= stack (env node))
    (loop [scc #{} nodes (::stack env) env env]
    (let [curr (peek nodes)
    scc (conj scc curr)
    env (update-in env [curr] dissoc :prevs)]
    env (assoc env curr nil)]
    (if (= curr node)
    (-> env
    (update-in [::sccs] conj scc)
    (assoc ::prevs prevs))
    (assoc ::stack stack))
    (recur scc (pop nodes) env))))
    env))))]
    (::sccs (reduce sc {::prevs () ::sccs #{}} nodes))))
    (::sccs (reduce sc {::stack () ::sccs #{}} nodes))))

    => (def g {:c #{:d} :a #{:b :c} :b #{:a :c}})
    => (tarjan (keys g) g)
    #{#{:c} #{:d} #{:a :b}}
    #{#{:c} #{:d} #{:a :b}}
  4. cgrand revised this gist Mar 18, 2013. 1 changed file with 18 additions and 17 deletions.
    35 changes: 18 additions & 17 deletions tarjan.clj
    View file
    Original file line number Diff line number Diff line change
    @@ -1,32 +1,33 @@
    ;; initial translation, with an implicit list through ::top and :prev chaining
    ;; env maps from nodes to {:low n :prev other-node} -- to the exceptions of special keys
    ;; switch to explicit lists, instead of implicit chaining
    ;; the explicit list is the the "lowest" stack so :low is not needed anymore

    (defn tarjan [nodes succs]
    (letfn [(sc [env node]
    (if (env node)
    env
    (let [n (::next env)
    env (assoc env node {:low n :prev (::top env)}
    ::next (inc n) ::top node)
    (let [prevs (::prevs env)
    env (assoc env node {:prevs prevs}
    ::prevs (conj prevs node))
    env (reduce (fn [env succ]
    (let [env (sc env succ)
    low (:low (env succ) n)]
    (update-in env [node :low] min low)))
    prevs (:prevs (env succ) prevs)]
    (update-in env [node :prevs]
    (partial min-key count) prevs)))
    env (succs node))
    low (:low (env node))]
    (if (= n low)
    (loop [scc #{} curr (::top env) env env]
    (let [scc (conj scc curr)
    prev (:prev (env curr))
    env (update-in env [curr] dissoc :low)]
    prevs' (:prevs (env node))]
    (if (= prevs prevs')
    (loop [scc #{} nodes (::prevs env) env env]
    (let [curr (peek nodes)
    scc (conj scc curr)
    env (update-in env [curr] dissoc :prevs)]
    (if (= curr node)
    (-> env
    (update-in [::sccs] conj scc)
    (assoc ::top prev))
    (recur scc prev env))))
    (assoc ::prevs prevs))
    (recur scc (pop nodes) env))))
    env))))]
    (::sccs (reduce sc {::top ::bottom ::next 0 ::sccs #{}} nodes))))
    (::sccs (reduce sc {::prevs () ::sccs #{}} nodes))))

    => (def g {:c #{:d} :a #{:b :c} :b #{:a :c}})
    => (tarjan (keys g) g)
    #{#{:c} #{:d} #{:a :b}}
    #{#{:c} #{:d} #{:a :b}}
  5. cgrand created this gist Mar 18, 2013.
    32 changes: 32 additions & 0 deletions tarjan.clj
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,32 @@
    ;; initial translation, with an implicit list through ::top and :prev chaining
    ;; env maps from nodes to {:low n :prev other-node} -- to the exceptions of special keys

    (defn tarjan [nodes succs]
    (letfn [(sc [env node]
    (if (env node)
    env
    (let [n (::next env)
    env (assoc env node {:low n :prev (::top env)}
    ::next (inc n) ::top node)
    env (reduce (fn [env succ]
    (let [env (sc env succ)
    low (:low (env succ) n)]
    (update-in env [node :low] min low)))
    env (succs node))
    low (:low (env node))]
    (if (= n low)
    (loop [scc #{} curr (::top env) env env]
    (let [scc (conj scc curr)
    prev (:prev (env curr))
    env (update-in env [curr] dissoc :low)]
    (if (= curr node)
    (-> env
    (update-in [::sccs] conj scc)
    (assoc ::top prev))
    (recur scc prev env))))
    env))))]
    (::sccs (reduce sc {::top ::bottom ::next 0 ::sccs #{}} nodes))))

    => (def g {:c #{:d} :a #{:b :c} :b #{:a :c}})
    => (tarjan (keys g) g)
    #{#{:c} #{:d} #{:a :b}}