Chapter 20 — Elementary Graph Algorithms
CLRS, fourth edition · Lean 4 formalization
The proofs below use the models and assumptions described in the scope and implementation notes.
Imports
import Mathlib20.1. Representing Graphs
This section defines the finite-graph model used by the Chapter 20 algorithm track. A graph is a finite vertex set together with an adjacency function. Undirected graphs are obtained by requiring symmetric adjacency.
The main concepts are:
-
Graph V: a directed graph on vertex typeV. -
Graph.Adj u v: there is a directed edge fromutov. -
Graph.IsWalk p:pis a non-empty list of vertices where each consecutive pair is an edge. -
Graph.IsPath p: a walk with no repeated vertices. -
Graph.IsCycle p u v: a non-trivial closed path built from a path fromutovplus the edgev → u. -
Graph.Reachable u v: the reflexive-transitive closure of adjacency. -
Graph.ConnectedComponent u: the set of vertices reachable fromu.
We define reachability as the reflexive-transitive closure of adjacency; this makes reflexivity and transitivity immediate and keeps the first pass simple. The equivalence with the existence of a walk will be proved once the model is stable.
namespace CLRSnamespace Chapter22A finite directed graph: a vertex set plus an adjacency function.
We require adjacency to be empty outside the vertex set, so every edge has both
endpoints in vertices.
structure Graph (V : Type) [DecidableEq V] where
vertices : Finset V
adj : V → Finset V
adj_sub : ∀ v ∈ vertices, adj v ⊆ vertices
adj_outside : ∀ v ∉ vertices, adj v = ∅namespace Graphvariable {V : Type} [DecidableEq V] (G : Graph V)
Directed adjacency: v is a neighbor of u.
def Adj (u v : V) : Prop := v ∈ G.adj u
If u is adjacent to v, then u is a vertex of the graph.
theorem adj_mem_left {u v : V} (hadj : G.Adj u v) : u ∈ G.vertices := by
by_contra h
have : G.adj u = ∅ := G.adj_outside u h
simp [Adj, this] at hadj
If u is adjacent to v, then v is a vertex of the graph.
theorem adj_mem_right {u v : V} (hadj : G.Adj u v) : v ∈ G.vertices := by
have hu := G.adj_mem_left hadj
exact G.adj_sub u hu hadjA walk is a non-empty vertex list where each consecutive pair is an edge.
def IsWalk (p : List V) : Prop :=
p ≠ [] ∧ (∀ v ∈ p, v ∈ G.vertices) ∧ List.IsChain (fun x y => y ∈ G.adj x) p
p is a walk from u to v.
def IsWalkFromTo (p : List V) (u v : V) : Prop :=
G.IsWalk p ∧ p.head? = some u ∧ p.getLast? = some vA path is a walk with no repeated vertices.
def IsPath (p : List V) : Prop :=
G.IsWalk p ∧ p.Nodup
A cycle is a non-trivial closed path: at least one edge and no repeated
internal vertices. We represent it as a path from u to v together with an
edge v → u.
def IsCycle (p : List V) (u v : V) : Prop :=
G.IsPath p ∧ p.head? = some u ∧ p.getLast? = some v ∧ v ≠ u ∧ u ∈ G.adj vReachability: reflexive-transitive closure of the adjacency relation.
def Reachable (u v : V) : Prop :=
Relation.ReflTransGen G.Adj u v
The connected component of u is the set of vertices reachable from u.
It is a Set rather than a Finset because the decidable
characterisation of reachability will come from an explicit graph-search
algorithm in later sections.
A single-vertex list is a walk iff the vertex belongs to the graph.
-- Basic facts about walks.
theorem isWalk_singleton {u : V} (hu : u ∈ G.vertices) : G.IsWalk [u] := by
constructor
· simp
constructor
· intro v hv
simp at hv
rwa [hv]
· simpAdjacency implies a two-vertex walk.
theorem isWalk_pair {u v : V} (hu : u ∈ G.vertices) (hadj : G.Adj u v) :
G.IsWalk [u, v] := by
have hv : v ∈ G.vertices := G.adj_sub u hu hadj
constructor
· simp
constructor
· intro a ha
simp at ha
cases ha with
| inl h => rwa [h]
| inr h => rwa [h]
· simp [Adj] at hadj ⊢
exact hadjReachability is reflexive.
-- Reachability is a preorder on vertices.
theorem reachable_refl (u : V) : G.Reachable u u :=
Relation.ReflTransGen.reflReachability is transitive.
theorem reachable_trans {u v w : V}
(huv : G.Reachable u v) (hvw : G.Reachable v w) : G.Reachable u w :=
Relation.ReflTransGen.trans huv hvwAn edge implies reachability in one step.
theorem reachable_adj {u v : V} (hadj : G.Adj u v) : G.Reachable u v :=
Relation.ReflTransGen.tail Relation.ReflTransGen.refl hadjEvery vertex reachable from a vertex of the graph is again a vertex of the graph.
theorem reachable_mem_vertices {u v : V} (hu : u ∈ G.vertices) (h : G.Reachable u v) :
v ∈ G.vertices := by
induction h with
| refl => exact hu
| tail _ hadj _ih => exact G.adj_mem_right hadj
The total number of directed edges of G, counted as the sum of
out-degrees over the vertex set.
An undirected graph has symmetric adjacency.
In an undirected graph, reachability is symmetric.
theorem reachable_symm {G : Graph V} (hund : G.Undirected)
{u v : V} (huv : G.Reachable u v) : G.Reachable v u := by
induction huv with
| refl =>
exact Relation.ReflTransGen.refl
| tail hxy hyz ih =>
have hadj' : G.Adj _ _ := (hund _ _).mp hyz
exact Relation.ReflTransGen.trans
(Relation.ReflTransGen.tail Relation.ReflTransGen.refl hadj') ihend Graphend Chapter22end CLRSImports
import Mathlib
import CLRSLean.FourthEdition.Chapter_20.Section_20_1_Representing_Graphs20.2. Breadth-First Search
This section gives executable breadth-first-search procedures on the finite graph model from Section 20.1. The basic search is proved sound and complete for reachability. A CLRS-labelled version additionally records distances and predecessors; its distances are proved to be unweighted shortest-path lengths, and its parent pointers are proved to form a rooted predecessor tree spanning exactly the reachable vertices.
The algorithm maintains a set of visited vertices and a FIFO queue. Each step
pops a vertex u from the queue and enqueues every neighbor of u
that has not been visited yet. Because the vertex set is finite, a fuel
argument equal to the number of vertices is enough to ensure termination.
The main correctness theorems are bfsState_distance_eq_some_iff,
bfsState_isBFSPredecessorTree, and the combined
bfsState_correct.
Internal BFS helper returning both the visited set and the remaining queue. One step pops the front of the queue, marks its unvisited neighbors, and appends them to the queue. The function is fuelled by a natural number.
noncomputable def bfsAux' (G : Graph V) (fuel : Nat) (visited : Finset V) (queue : List V) : Finset V × List V :=
match fuel with
| 0 => (visited, queue)
| fuel + 1 =>
match queue with
| [] => (visited, [])
| u :: rest =>
let newNeighbors := (G.adj u).filter (fun v => v ∉ visited)
bfsAux' G fuel (visited ∪ newNeighbors) (rest ++ newNeighbors.toList)One step of BFS returns only the visited set.
bfsAux is the public interface: it is the first projection of bfsAux'.
noncomputable def bfsAux (G : Graph V) (fuel : Nat) (visited : Finset V) (queue : List V) : Finset V :=
(bfsAux' G fuel visited queue).1
Breadth-first search from a source vertex s.
Returns the set of vertices visited by BFS. The source must belong to the graph.
noncomputable def bfs (G : Graph V) (s : V) (_hs : s ∈ G.vertices) : Finset V :=
bfsAux G G.vertices.card ({s} : Finset V) [s]
Soundness invariant for Graph.bfsAux': every visited vertex and every
queued vertex is reachable from the source.
def BFSInvariant (s : V) (visited : Finset V) (queue : List V) : Prop :=
(∀ v ∈ visited, G.Reachable s v) ∧ (∀ v ∈ queue, G.Reachable s v)The BFS step preserves the soundness invariant.
theorem bfsInvariant_step {s u : V} {rest : List V} {visited : Finset V}
(hinv : G.BFSInvariant s visited (u :: rest)) :
G.BFSInvariant s
(visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) := by
rcases hinv with ⟨hvisited, hqueue⟩
constructor
· -- visited vertices remain reachable
intro v hv
simp [Finset.mem_filter] at hv
rcases hv with (h | ⟨hadj, _⟩)
· exact hvisited v h
· have hu : G.Reachable s u := hqueue u (by simp)
exact G.reachable_trans hu (G.reachable_adj hadj)
· -- queued vertices remain reachable
intro v hv
simp [List.mem_append, Finset.mem_toList, Finset.mem_filter] at hv
rcases hv with (h | ⟨hadj, _⟩)
· exact hqueue v (by simp [h])
· have hu : G.Reachable s u := hqueue u (by simp)
exact G.reachable_trans hu (G.reachable_adj hadj)
Graph.bfsAux' only returns vertices that are reachable from the
source.
theorem bfsAux'_sound {s : V} (fuel : Nat) (visited : Finset V) (queue : List V)
(hinv : G.BFSInvariant s visited queue) :
∀ v ∈ (bfsAux' G fuel visited queue).1, G.Reachable s v := by
induction fuel generalizing visited queue with
| zero =>
intro v hv
simp [bfsAux'] at hv
exact hinv.1 v hv
| succ n ih =>
intro v hv
cases queue with
| nil =>
simp [bfsAux'] at hv
exact hinv.1 v hv
| cons u rest =>
simp [bfsAux'] at hv
exact ih (visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList)
(bfsInvariant_step G hinv) v hv
Graph.bfsAux only returns vertices that are reachable from the
source.
theorem bfsAux_sound {s : V} (fuel : Nat) (visited : Finset V) (queue : List V)
(hinv : G.BFSInvariant s visited queue) :
∀ v ∈ bfsAux G fuel visited queue, G.Reachable s v := by
intro v hv
simp [bfsAux] at hv ⊢
exact bfsAux'_sound G fuel visited queue hinv v hv
Every vertex reported by Graph.bfs is reachable from the source.
theorem bfs_sound {s : V} (_hs : s ∈ G.vertices) {v : V}
(hv : v ∈ bfs G s _hs) : G.Reachable s v := by
have h : ∀ v ∈ bfs G s _hs, G.Reachable s v := by
intro v hv
simp [bfs] at hv
apply bfsAux_sound G G.vertices.card {s} [s] _ v hv
constructor
· intro x hx
simp at hx
rw [hx]
exact G.reachable_refl s
· intro x hx
simp at hx
rw [hx]
exact G.reachable_refl s
exact h v hv
The visited set returned by Graph.bfsAux' is monotone in the input
visited set: every vertex already visited stays visited.
-- =============================================================================
-- Completeness: every reachable vertex is visited
-- =============================================================================
theorem bfsAux'_visited_monotone {fuel : Nat} {visited : Finset V} {queue : List V} {v : V}
(hv : v ∈ visited) : v ∈ (bfsAux' G fuel visited queue).1 := by
induction fuel generalizing visited queue with
| zero =>
simp [bfsAux']
exact hv
| succ n ih =>
cases queue with
| nil =>
simp [bfsAux']
exact hv
| cons u rest =>
simp [bfsAux']
apply ih
simp [hv]Closure invariant for BFS: every processed vertex (visited but no longer in the queue) has all of its neighbors already visited.
def BFSClosedInv (G : Graph V) (visited : Finset V) (queue : List V) : Prop :=
∀ u ∈ visited, u ∉ queue → ∀ v ∈ G.adj u, v ∈ visitedQueue invariant for BFS: every queued vertex is already marked visited.
def BFSQueueInv (_G : Graph V) (visited : Finset V) (queue : List V) : Prop :=
∀ v ∈ queue, v ∈ visitedThe closure invariant is preserved by one BFS step.
theorem bfsClosedInv_step {u : V} {rest : List V} {visited : Finset V}
(hclosed : BFSClosedInv G visited (u :: rest)) :
BFSClosedInv G
(visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) := by
intro x hx hxnotin v hvx
simp [BFSClosedInv] at hclosed
simp [Finset.mem_union, Finset.mem_filter] at hx
rcases hx with (hx | ⟨hxadj, hxnvis⟩)
· -- x was already visited before this step
by_cases hxu : x = u
· -- x = u, so all its neighbors (including v) are now visited
rw [hxu] at hvx
simp [hvx]
by_cases h : v ∈ visited <;> simp [h]
· -- x ≠ u
by_cases hxrest : x ∈ rest
· -- x is still in the new queue, no obligation
exfalso
simp [hxrest] at hxnotin
· -- x has been processed before; its neighbors were already visited
have hxnotin' : x ∉ u :: rest := by
simp [hxu, hxrest]
have hxne : x ≠ u := by
intro h
apply hxnotin'
simp [h]
have hxnrest : x ∉ rest := by
intro h
apply hxnotin'
simp [h]
have : v ∈ visited := hclosed x hx hxne hxnrest v hvx
simp [this]
· -- x is newly discovered, so it is enqueued and we have no obligation
exfalso
have : x ∈ rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList := by
simp [hxadj, hxnvis]
contradictionThe queue invariant is preserved by one BFS step.
theorem bfsQueueInv_step {u : V} {rest : List V} {visited : Finset V}
(hqueue : G.BFSQueueInv visited (u :: rest)) :
G.BFSQueueInv
(visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) := by
intro x hx
simp [BFSQueueInv] at hqueue
rcases hqueue with ⟨hu, hrest⟩
simp [List.mem_append, Finset.mem_toList, Finset.mem_filter] at hx
rcases hx with (hx | ⟨hxadj, hxnvis⟩)
· -- x was already in the rest of the queue
have : x ∈ visited := hrest x hx
simp [this]
· -- x is a newly enqueued neighbor of u
simp [hxadj, hxnvis]Termination measure for BFS: length of the queue plus the number of unvisited vertices. It decreases by exactly one on every productive step.
def bfsMeasure (G : Graph V) (visited : Finset V) (queue : List V) : Nat :=
queue.length + (G.vertices \ visited).cardA productive BFS step strictly decreases the measure by one.
theorem bfsMeasure_decreasing {u : V} {rest : List V} {visited : Finset V} :
bfsMeasure G (visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList)
= bfsMeasure G visited (u :: rest) - 1 := by
set newNeighbors := (G.adj u).filter (fun v => v ∉ visited)
simp [bfsMeasure]
have hsub : newNeighbors ⊆ G.vertices \ visited := by
intro x hx
simp [newNeighbors, Finset.mem_filter, Finset.mem_sdiff] at hx ⊢
constructor
· exact G.adj_sub u (G.adj_mem_left (show G.Adj u x by simp [Adj] at hx ⊢; exact hx.1)) hx.1
· exact hx.2
have heq : G.vertices \ (visited ∪ newNeighbors) = (G.vertices \ visited) \ newNeighbors := by
ext x
simp
tauto
have hcard : ((G.vertices \ visited) \ newNeighbors).card =
(G.vertices \ visited).card - newNeighbors.card := by
have h1 : ((G.vertices \ visited) \ newNeighbors).card =
(G.vertices \ visited).card - (newNeighbors ∩ (G.vertices \ visited)).card := by
rw [Finset.card_sdiff]
have h2 : newNeighbors ∩ (G.vertices \ visited) = newNeighbors := by
ext x
simp [Finset.mem_sdiff]
intro h
have := hsub h
simp [Finset.mem_sdiff] at this
exact this
rw [h1, h2]
have hle : newNeighbors.card ≤ (G.vertices \ visited).card := Finset.card_le_card hsub
rw [heq, hcard]
omega
With enough fuel, Graph.bfsAux' empties the queue.
theorem bfsAux'_queue_empty {fuel : Nat} {visited : Finset V} {queue : List V}
(hmeas : bfsMeasure G visited queue ≤ fuel) :
(bfsAux' G fuel visited queue).2 = [] := by
induction fuel generalizing visited queue with
| zero =>
simp [bfsMeasure] at hmeas
cases queue with
| nil => simp [bfsAux']
| cons u rest => simp at hmeas
| succ n ih =>
cases queue with
| nil =>
simp [bfsAux']
| cons u rest =>
simp [bfsAux']
have hmeas' : bfsMeasure G (visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) ≤ n := by
rw [bfsMeasure_decreasing G]
omega
exact ih hmeas'
With enough fuel, Graph.bfsAux' preserves the closure invariant.
theorem bfsAux'_closed {fuel : Nat} {visited : Finset V} {queue : List V}
(hclosed : G.BFSClosedInv visited queue) (hmeas : bfsMeasure G visited queue ≤ fuel) :
G.BFSClosedInv (bfsAux' G fuel visited queue).1 (bfsAux' G fuel visited queue).2 := by
induction fuel generalizing visited queue with
| zero =>
simp [bfsAux']
exact hclosed
| succ n ih =>
cases queue with
| nil =>
simp [bfsAux']
exact hclosed
| cons u rest =>
simp [bfsAux']
have hclosed' : G.BFSClosedInv
(visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) :=
bfsClosedInv_step G hclosed
have hmeas' : bfsMeasure G (visited ∪ (G.adj u).filter (fun v => v ∉ visited))
(rest ++ ((G.adj u).filter (fun v => v ∉ visited)).toList) ≤ n := by
rw [bfsMeasure_decreasing G]
omega
exact ih hclosed' hmeas'
Every vertex visited by Graph.bfs has all of its neighbors visited.
This is the key lemma for completeness.
theorem bfs_closed {s : V} (_hs : s ∈ G.vertices) :
∀ u ∈ bfs G s _hs, ∀ v ∈ G.adj u, v ∈ bfs G s _hs := by
simp [bfs, bfsAux]
have hclosed : G.BFSClosedInv ({s} : Finset V) [s] := by
intro u hu huin v hv
simp at hu huin
rw [hu] at huin
contradiction
have hmeas : bfsMeasure G ({s} : Finset V) [s] ≤ G.vertices.card := by
simp [bfsMeasure]
have hcard : (G.vertices \ ({s} : Finset V)).card = G.vertices.card - 1 := by
rw [Finset.sdiff_singleton_eq_erase]
apply Finset.card_erase_of_mem
exact _hs
rw [hcard]
have hpos : G.vertices.card ≥ 1 := by
apply Finset.one_le_card.mpr
use s
omega
have hclosed' := bfsAux'_closed G hclosed hmeas
have hempty := bfsAux'_queue_empty G hmeas
rw [hempty] at hclosed'
intro u hu v hv
exact hclosed' u hu (by simp) v hv
Every vertex reachable from the source is reported by Graph.bfs.
theorem bfs_complete {s : V} (_hs : s ∈ G.vertices) {v : V} (hreach : G.Reachable s v) :
v ∈ bfs G s _hs := by
-- Helper: once a vertex is in the BFS visited set, all vertices reachable from
-- it remain in that same visited set.
have hclosure {src u w : V} (_hsrc : src ∈ G.vertices) (hu : u ∈ bfs G src _hsrc)
(hw : G.Reachable u w) : w ∈ bfs G src _hsrc := by
induction hw with
| refl => exact hu
| tail _ hadj ih => exact bfs_closed G _hsrc _ ih _ hadj
-- Main proof by head induction on the reachability witness.
induction hreach using Relation.ReflTransGen.head_induction_on with
| refl =>
apply bfsAux'_visited_monotone G
simp
| @head a c h' h ih =>
have _hc : c ∈ G.vertices := G.adj_sub a (G.adj_mem_left h') h'
have hcv : v ∈ bfs G c _hc := ih _hc
have _ha : a ∈ G.vertices := G.adj_mem_left h'
have ha_bfs : a ∈ bfs G a _ha := by
apply bfsAux'_visited_monotone G
simp
have hc_in_a : c ∈ bfs G a _ha := bfs_closed G _ha a ha_bfs c h'
have hreach_c_v : G.Reachable c v := G.bfs_sound _hc hcv
exact hclosure _ha hc_in_a hreach_c_v
Reachability by exactly n directed edges.
-- =============================================================================
-- CLRS distance and predecessor state
-- =============================================================================
inductive ReachableIn (G : Graph V) (s : V) : V → Nat → Prop where
| refl : G.ReachableIn s s 0
| tail {u v : V} {n : Nat} :
G.ReachableIn s u n → G.Adj u v → G.ReachableIn s v (n + 1)
A natural number is the unweighted shortest-path distance from s to
v when it is attained by a walk and lower-bounds every other such walk.
def IsShortestDistance (G : Graph V) (s v : V) (distance : Nat) : Prop :=
G.ReachableIn s v distance ∧
∀ length, G.ReachableIn s v length → distance ≤ lengthExact-length reachability implies ordinary reachability.
theorem ReachableIn.reachable {s v : V} {n : Nat}
(h : G.ReachableIn s v n) : G.Reachable s v := by
induction h with
| refl => exact G.reachable_refl s
| tail hreach hadj ih => exact G.reachable_trans ih (G.reachable_adj hadj)A shortest-distance witness always gives ordinary reachability.
theorem IsShortestDistance.reachable {s v : V} {n : Nat}
(h : G.IsShortestDistance s v n) : G.Reachable s v :=
h.1.reachable G
Mutable CLRS BFS state. A vertex is discovered exactly when it belongs to
visited; distance and parent record its first discovery.
structure BFSState (V : Type) [DecidableEq V] where
visited : Finset V
queue : List V
distance : V → Option Nat
parent : V → Option Vnamespace BFSStateNumeric level used by the queue invariants. It is only inspected for discovered vertices, where the distance is known to be present.
end BFSStateInitial labelled BFS state.
noncomputable def bfsStateInit (s : V) : BFSState V where
visited := {s}
queue := [s]
distance := fun v => if v = s then some 0 else none
parent := fun _ => none
As-yet undiscovered out-neighbors of u.
noncomputable def bfsNewNeighbors (G : Graph V) (state : BFSState V) (u : V) : Finset V :=
(G.adj u).filter (fun v => v ∉ state.visited)
Process the front vertex u, assigning distance d[u] + 1 and
parent u to every newly discovered neighbor.
noncomputable def bfsStateAdvance (G : Graph V) (state : BFSState V)
(u : V) (rest : List V) : BFSState V :=
let newNeighbors := bfsNewNeighbors G state u
let nextDistance := state.level u + 1
{
visited := state.visited ∪ newNeighbors
queue := rest ++ newNeighbors.toList
distance := fun v =>
if v ∈ newNeighbors then some nextDistance else state.distance v
parent := fun v =>
if v ∈ newNeighbors then some u else state.parent v
}Fuelled labelled BFS.
noncomputable def bfsStateAux (G : Graph V) : Nat → BFSState V → BFSState V
| 0, state => state
| fuel + 1, state =>
match state.queue with
| [] => state
| u :: rest => bfsStateAux G fuel (bfsStateAdvance G state u rest)CLRS BFS result with distances and predecessor pointers.
noncomputable def bfsState (G : Graph V) (s : V) (_hs : s ∈ G.vertices) : BFSState V :=
bfsStateAux G G.vertices.card (bfsStateInit s)The labelled BFS has exactly the same visited-set and queue evolution as the already verified reachability-only BFS.
theorem bfsStateAux_search_eq (fuel : Nat) (state : BFSState V) :
let result := bfsStateAux G fuel state
(result.visited, result.queue) =
bfsAux' G fuel state.visited state.queue := by
induction fuel generalizing state with
| zero => simp [bfsStateAux, bfsAux']
| succ fuel ih =>
cases hqueue : state.queue with
| nil => simp [bfsStateAux, bfsAux', hqueue]
| cons u rest =>
simp only [bfsStateAux, bfsAux', hqueue]
simpa [bfsStateAdvance, bfsNewNeighbors] using
ih (bfsStateAdvance G state u rest)
The final labelled BFS discovers exactly the vertices returned by
Graph.bfs.
theorem bfsState_visited_eq_bfs {s : V} (hs : s ∈ G.vertices) :
(bfsState G s hs).visited = bfs G s hs := by
have h := bfsStateAux_search_eq G G.vertices.card (bfsStateInit s)
have hfirst := congrArg Prod.fst h
simpa [bfsState, bfs, bfsAux, bfsStateInit] using hfirstThe final labelled BFS has exhausted its queue.
theorem bfsState_queue_empty {s : V} (hs : s ∈ G.vertices) :
(bfsState G s hs).queue = [] := by
have h := bfsStateAux_search_eq G G.vertices.card (bfsStateInit s)
have hsecond := congrArg Prod.snd h
have hmeasure : bfsMeasure G ({s} : Finset V) [s] ≤ G.vertices.card := by
simp [bfsMeasure]
have hcard : (G.vertices \ ({s} : Finset V)).card = G.vertices.card - 1 := by
rw [Finset.sdiff_singleton_eq_erase]
exact Finset.card_erase_of_mem hs
rw [hcard]
have hpositive : 1 ≤ G.vertices.card := Finset.one_le_card.mpr ⟨s, hs⟩
omega
have hempty := bfsAux'_queue_empty G hmeasure
simpa [bfsState, bfsStateInit] using hsecond.trans hemptyInvariant connecting the FIFO search state to CLRS distance and predecessor labels. The queue is ordered by nondecreasing level and spans at most two consecutive levels; processed edges already satisfy the shortest-path upper bound needed at termination.
structure BFSDistanceInvariant (G : Graph V) (s : V) (state : BFSState V) : Prop where
closed : G.BFSClosedInv state.visited state.queue
queued : G.BFSQueueInv state.visited state.queue
source_distance : state.distance s = some 0
source_parent : state.parent s = none
distance_iff_visited : ∀ v, v ∈ state.visited ↔ ∃ d, state.distance v = some d
distance_zero : ∀ v, state.distance v = some 0 → v = s
parent_exists : ∀ v, v ∈ state.visited → v ≠ s → ∃ u, state.parent v = some u
parent_unvisited : ∀ v, v ∉ state.visited → state.parent v = none
parent_step : ∀ u v, state.parent v = some u →
G.Adj u v ∧ ∃ d, state.distance u = some d ∧ state.distance v = some (d + 1)
queue_ordered : state.queue.Pairwise (fun u v => state.level u ≤ state.level v)
visited_span : ∀ u rest, state.queue = u :: rest →
∀ v ∈ state.visited, state.level v ≤ state.level u + 1
processed_edge : ∀ u ∈ state.visited, u ∉ state.queue →
∀ v, G.Adj u v → state.level v ≤ state.level u + 1@[simp]
theorem mem_bfsNewNeighbors_iff {state : BFSState V} {u v : V} :
v ∈ bfsNewNeighbors G state u ↔ G.Adj u v ∧ v ∉ state.visited := by
simp [bfsNewNeighbors, Adj]Processing a vertex does not change labels of already discovered vertices.
theorem bfsStateAdvance_distance_of_visited {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ state.visited) :
(bfsStateAdvance G state u rest).distance v = state.distance v := by
have hvnew : v ∉ bfsNewNeighbors G state u := by
simp [mem_bfsNewNeighbors_iff, hv]
simp [bfsStateAdvance, hvnew]
theorem bfsStateAdvance_parent_of_visited {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ state.visited) :
(bfsStateAdvance G state u rest).parent v = state.parent v := by
have hvnew : v ∉ bfsNewNeighbors G state u := by
simp [mem_bfsNewNeighbors_iff, hv]
simp [bfsStateAdvance, hvnew]theorem bfsStateAdvance_level_of_visited {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ state.visited) :
(bfsStateAdvance G state u rest).level v = state.level v := by
simp [BFSState.level, bfsStateAdvance_distance_of_visited G hv]Every newly discovered vertex receives the front vertex's level plus one and records the front vertex as its parent.
theorem bfsStateAdvance_distance_of_new {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ bfsNewNeighbors G state u) :
(bfsStateAdvance G state u rest).distance v = some (state.level u + 1) := by
simp [bfsStateAdvance, hv]theorem bfsStateAdvance_parent_of_new {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ bfsNewNeighbors G state u) :
(bfsStateAdvance G state u rest).parent v = some u := by
simp [bfsStateAdvance, hv]theorem bfsStateAdvance_level_of_new {state : BFSState V} {u v : V}
{rest : List V} (hv : v ∈ bfsNewNeighbors G state u) :
(bfsStateAdvance G state u rest).level v = state.level u + 1 := by
simp [BFSState.level, bfsStateAdvance_distance_of_new G hv]The initial labelled state satisfies all distance and predecessor invariants.
theorem bfsDistanceInvariant_init {s : V} :
G.BFSDistanceInvariant s (bfsStateInit s) := by
constructor <;> simp [BFSClosedInv, BFSQueueInv, bfsStateInit, BFSState.level]One FIFO step preserves the distance and predecessor invariant.
theorem bfsDistanceInvariant_step {s u : V} {rest : List V} {state : BFSState V}
(hqueue : state.queue = u :: rest)
(hinv : G.BFSDistanceInvariant s state) :
G.BFSDistanceInvariant s (bfsStateAdvance G state u rest) := by
have hu_queue : u ∈ state.queue := by simp [hqueue]
have hu_visited : u ∈ state.visited := hinv.queued u hu_queue
have hu_not_new : u ∉ bfsNewNeighbors G state u := by
simp [mem_bfsNewNeighbors_iff, hu_visited]
have hclosed : G.BFSClosedInv state.visited (u :: rest) := by
simpa [hqueue] using hinv.closed
have hqueued : G.BFSQueueInv state.visited (u :: rest) := by
simpa [hqueue] using hinv.queued
have hs_visited : s ∈ state.visited :=
(hinv.distance_iff_visited s).2 ⟨0, hinv.source_distance⟩
have hs_not_new : s ∉ bfsNewNeighbors G state u := by
simp [mem_bfsNewNeighbors_iff, hs_visited]
have hordered : (u :: rest).Pairwise
(fun a b => state.level a ≤ state.level b) := by
simpa [hqueue] using hinv.queue_ordered
constructor
· simpa [bfsStateAdvance, bfsNewNeighbors] using
(bfsClosedInv_step G hclosed)
· simpa [bfsStateAdvance, bfsNewNeighbors] using
(bfsQueueInv_step G hqueued)
· simpa [bfsStateAdvance, hs_not_new] using hinv.source_distance
· simpa [bfsStateAdvance, hs_not_new] using hinv.source_parent
· intro v
constructor
· intro hv
change v ∈ state.visited ∪ bfsNewNeighbors G state u at hv
rcases Finset.mem_union.mp hv with hvold | hvnew
· rcases (hinv.distance_iff_visited v).1 hvold with ⟨d, hd⟩
exact ⟨d, by simpa [bfsStateAdvance_distance_of_visited G hvold] using hd⟩
· exact ⟨state.level u + 1, bfsStateAdvance_distance_of_new G hvnew⟩
· rintro ⟨d, hd⟩
by_cases hvnew : v ∈ bfsNewNeighbors G state u
· exact Finset.mem_union_right _ hvnew
· have hdold : state.distance v = some d := by
simpa [bfsStateAdvance, hvnew] using hd
exact Finset.mem_union_left _ ((hinv.distance_iff_visited v).2 ⟨d, hdold⟩)
· intro v hvzero
by_cases hvnew : v ∈ bfsNewNeighbors G state u
· have := bfsStateAdvance_distance_of_new G (rest := rest) hvnew
rw [hvzero] at this
simp at this
· have hvold : state.distance v = some 0 := by
simpa [bfsStateAdvance, hvnew] using hvzero
exact hinv.distance_zero v hvold
· intro v hv hvs
change v ∈ state.visited ∪ bfsNewNeighbors G state u at hv
rcases Finset.mem_union.mp hv with hvold | hvnew
· rcases hinv.parent_exists v hvold hvs with ⟨p, hp⟩
exact ⟨p, by simpa [bfsStateAdvance_parent_of_visited G hvold] using hp⟩
· exact ⟨u, bfsStateAdvance_parent_of_new G hvnew⟩
· intro v hv
have hvold : v ∉ state.visited := by
intro h
exact hv (Finset.mem_union_left _ h)
have hvnew : v ∉ bfsNewNeighbors G state u := by
intro h
exact hv (Finset.mem_union_right _ h)
simpa [bfsStateAdvance, hvnew] using hinv.parent_unvisited v hvold
· intro p v hp
by_cases hvnew : v ∈ bfsNewNeighbors G state u
· have hp_eq : p = u := by
have hnewParent := bfsStateAdvance_parent_of_new G (rest := rest) hvnew
rw [hp] at hnewParent
exact Option.some.inj hnewParent
subst p
have hadj : G.Adj u v := (mem_bfsNewNeighbors_iff G).1 hvnew |>.1
rcases (hinv.distance_iff_visited u).1 hu_visited with ⟨d, hd⟩
have hlevel : state.level u = d := by simp [BFSState.level, hd]
refine ⟨hadj, d, ?_, ?_⟩
simpa [bfsStateAdvance_distance_of_visited G hu_visited] using hd
simpa [hlevel] using bfsStateAdvance_distance_of_new G (rest := rest) hvnew
· have hpold : state.parent v = some p := by
simpa [bfsStateAdvance, hvnew] using hp
rcases hinv.parent_step p v hpold with ⟨hadj, d, hdp, hdv⟩
have hp_visited : p ∈ state.visited :=
(hinv.distance_iff_visited p).2 ⟨d, hdp⟩
have hv_visited : v ∈ state.visited :=
(hinv.distance_iff_visited v).2 ⟨d + 1, hdv⟩
refine ⟨hadj, d, ?_, ?_⟩
· simpa [bfsStateAdvance_distance_of_visited G hp_visited] using hdp
· simpa [bfsStateAdvance_distance_of_visited G hv_visited] using hdv
· change (rest ++ (bfsNewNeighbors G state u).toList).Pairwise
(fun a b => (bfsStateAdvance G state u rest).level a ≤
(bfsStateAdvance G state u rest).level b)
rw [List.pairwise_append]
refine ⟨?_, ?_, ?_⟩
· have hrest := hordered.tail
rw [List.pairwise_iff_get] at hrest ⊢
intro i j hij
have hi_visited : rest.get i ∈ state.visited := hqueued _ (by simp)
have hj_visited : rest.get j ∈ state.visited := hqueued _ (by simp)
rw [bfsStateAdvance_level_of_visited G (rest := rest) hi_visited,
bfsStateAdvance_level_of_visited G (rest := rest) hj_visited]
exact hrest i j hij
· apply List.pairwise_of_reflexive_of_forall_ne
intro a ha b hb _
have ha_new : a ∈ bfsNewNeighbors G state u := Finset.mem_toList.mp ha
have hb_new : b ∈ bfsNewNeighbors G state u := Finset.mem_toList.mp hb
rw [bfsStateAdvance_level_of_new G ha_new,
bfsStateAdvance_level_of_new G hb_new]
· intro a ha b hb
have ha_visited : a ∈ state.visited := hqueued a (by simp [ha])
have hb_new : b ∈ bfsNewNeighbors G state u := Finset.mem_toList.mp hb
rw [bfsStateAdvance_level_of_visited G ha_visited,
bfsStateAdvance_level_of_new G hb_new]
exact hinv.visited_span u rest hqueue a ha_visited
· intro front tail hnext_queue v hv
have hv_union : v ∈ state.visited ∪ bfsNewNeighbors G state u := by
simpa [bfsStateAdvance] using hv
have hv_bound : (bfsStateAdvance G state u rest).level v ≤ state.level u + 1 := by
rcases Finset.mem_union.mp hv_union with hvold | hvnew
· rw [bfsStateAdvance_level_of_visited G hvold]
exact hinv.visited_span u rest hqueue v hvold
· rw [bfsStateAdvance_level_of_new G hvnew]
cases rest with
| nil =>
have hlist : (bfsNewNeighbors G state u).toList = front :: tail := by
simpa [bfsStateAdvance] using hnext_queue
have hfront_new : front ∈ bfsNewNeighbors G state u := by
apply Finset.mem_toList.mp
rw [hlist]
simp
rw [bfsStateAdvance_level_of_new G hfront_new]
omega
| cons next remaining =>
have hlist : next :: (remaining ++ (bfsNewNeighbors G state u).toList) =
front :: tail := by
simpa [bfsStateAdvance] using hnext_queue
have hfront : front = next := by
injection hlist with hhead _
exact hhead.symm
subst front
have hnext_visited : next ∈ state.visited := hqueued next (by simp)
have hu_le_next : state.level u ≤ state.level next :=
List.rel_of_pairwise_cons hordered (by simp)
rw [bfsStateAdvance_level_of_visited G hnext_visited]
omega
· intro x hx hnotin y hxy
have hx_union : x ∈ state.visited ∪ bfsNewNeighbors G state u := by
simpa [bfsStateAdvance] using hx
rcases Finset.mem_union.mp hx_union with hxold | hxnew
· by_cases hxu : x = u
· subst x
by_cases hyold : y ∈ state.visited
· rw [bfsStateAdvance_level_of_visited G hyold,
bfsStateAdvance_level_of_visited G hu_visited]
exact hinv.visited_span u rest hqueue y hyold
· have hynew : y ∈ bfsNewNeighbors G state u :=
(mem_bfsNewNeighbors_iff G).2 ⟨hxy, hyold⟩
rw [bfsStateAdvance_level_of_new G hynew,
bfsStateAdvance_level_of_visited G hu_visited]
· have hx_not_rest : x ∉ rest := by
intro hxrest
apply hnotin
change x ∈ rest ++ (bfsNewNeighbors G state u).toList
exact List.mem_append_left _ hxrest
have hx_not_queue : x ∉ state.queue := by
rw [hqueue]
simp [hxu, hx_not_rest]
have hyold : y ∈ state.visited := hclosed x hxold (by
simp [hxu, hx_not_rest]) y hxy
rw [bfsStateAdvance_level_of_visited G hyold,
bfsStateAdvance_level_of_visited G hxold]
exact hinv.processed_edge x hxold hx_not_queue y hxy
· exfalso
apply hnotin
change x ∈ rest ++ (bfsNewNeighbors G state u).toList
exact List.mem_append_right _ (Finset.mem_toList.mpr hxnew)Every fuelled execution preserves the distance invariant.
theorem bfsDistanceInvariant_aux {s : V} (fuel : Nat) (state : BFSState V)
(hinv : G.BFSDistanceInvariant s state) :
G.BFSDistanceInvariant s (bfsStateAux G fuel state) := by
induction fuel generalizing state with
| zero => simpa [bfsStateAux]
| succ fuel ih =>
cases hqueue : state.queue with
| nil => simpa [bfsStateAux, hqueue]
| cons u rest =>
simp only [bfsStateAux, hqueue]
exact ih (bfsStateAdvance G state u rest)
(bfsDistanceInvariant_step G hqueue hinv)The final CLRS BFS state satisfies the distance invariant.
theorem bfsState_distanceInvariant {s : V} (hs : s ∈ G.vertices) :
G.BFSDistanceInvariant s (bfsState G s hs) := by
simpa [bfsState] using
(bfsDistanceInvariant_aux G G.vertices.card (bfsStateInit s)
(bfsDistanceInvariant_init G))Ordinary reachability is equivalent to exact reachability for some finite number of edges.
theorem reachable_iff_exists_reachableIn {s v : V} :
G.Reachable s v ↔ ∃ n, G.ReachableIn s v n := by
constructor
· intro h
induction h with
| refl => exact ⟨0, ReachableIn.refl⟩
| tail _ hadj ih =>
rcases ih with ⟨n, hn⟩
exact ⟨n + 1, ReachableIn.tail hn hadj⟩
· rintro ⟨n, h⟩
exact h.reachable GA path following the recorded parent function from the source.
inductive BFSParentPath (parent : V → Option V) (s : V) : V → Nat → Prop where
| root : BFSParentPath parent s s 0
| tail {u v : V} {n : Nat} :
BFSParentPath parent s u n → parent v = some u →
BFSParentPath parent s v (n + 1)Every distance label maintained by the invariant is witnessed by a parent path of exactly that length.
theorem BFSDistanceInvariant.parentPath_of_distance
{s : V} {state : BFSState V} (hinv : G.BFSDistanceInvariant s state)
{v : V} {distance : Nat} (hdistance : state.distance v = some distance) :
BFSParentPath state.parent s v distance := by
induction distance using Nat.strong_induction_on generalizing v with
| h distance ih =>
cases distance with
| zero =>
have hvs : v = s := hinv.distance_zero v hdistance
subst v
exact BFSParentPath.root
| succ n =>
have hv_visited : v ∈ state.visited :=
(hinv.distance_iff_visited v).2 ⟨n + 1, hdistance⟩
have hvs : v ≠ s := by
intro h
subst v
rw [hinv.source_distance] at hdistance
simp at hdistance
rcases hinv.parent_exists v hv_visited hvs with ⟨u, hparent⟩
rcases hinv.parent_step u v hparent with ⟨_, d, hdu, hdv⟩
have hdn : d = n := by
rw [hdistance] at hdv
simp at hdv
omega
subst d
exact BFSParentPath.tail (ih n (by omega) hdu) hparentParent paths in a valid BFS state are graph paths with the same number of edges.
theorem BFSDistanceInvariant.parentPath_reachableIn
{s : V} {state : BFSState V} (hinv : G.BFSDistanceInvariant s state)
{v : V} {distance : Nat} (hpath : BFSParentPath state.parent s v distance) :
G.ReachableIn s v distance := by
induction hpath with
| root => exact ReachableIn.refl
| tail hpath hparent ih =>
exact ReachableIn.tail ih (hinv.parent_step _ _ hparent).1Every recorded distance is attained by a graph path of exactly that length.
theorem bfsState_distance_reachableIn {s v : V} (hs : s ∈ G.vertices)
{distance : Nat} (hdistance : (bfsState G s hs).distance v = some distance) :
G.ReachableIn s v distance := by
have hinv := bfsState_distanceInvariant G hs
exact hinv.parentPath_reachableIn G (hinv.parentPath_of_distance G hdistance)Along any exact-length path from the source, the final BFS distance is no larger than the path length.
theorem bfsState_distance_le_of_reachableIn {s v : V} (hs : s ∈ G.vertices)
{length : Nat} (hpath : G.ReachableIn s v length) :
∃ distance, (bfsState G s hs).distance v = some distance ∧ distance ≤ length := by
let result := bfsState G s hs
have hinv : G.BFSDistanceInvariant s result := bfsState_distanceInvariant G hs
have hqueue : result.queue = [] := bfsState_queue_empty G hs
induction hpath with
| refl => exact ⟨0, hinv.source_distance, le_rfl⟩
| @tail u v n hprefix hadj ih =>
rcases ih with ⟨du, hdu, hle⟩
have hu_visited : u ∈ result.visited :=
(hinv.distance_iff_visited u).2 ⟨du, hdu⟩
have hv_visited : v ∈ result.visited :=
hinv.closed u hu_visited (by simp [hqueue]) v hadj
rcases (hinv.distance_iff_visited v).1 hv_visited with ⟨dv, hdv⟩
have hdu' : result.distance u = some du := by simpa [result] using hdu
have hu_level : result.level u = du := by simp [BFSState.level, hdu']
have hv_level : result.level v = dv := by simp [BFSState.level, hdv]
have hedge := hinv.processed_edge u hu_visited (by simp [hqueue]) v hadj
rw [hu_level, hv_level] at hedge
exact ⟨dv, hdv, by omega⟩Every present final BFS label is the unweighted shortest-path distance.
theorem bfsState_distance_isShortest {s v : V} (hs : s ∈ G.vertices)
{distance : Nat} (hdistance : (bfsState G s hs).distance v = some distance) :
G.IsShortestDistance s v distance := by
constructor
· exact bfsState_distance_reachableIn G hs hdistance
· intro length hpath
rcases bfsState_distance_le_of_reachableIn G hs hpath with ⟨d, hd, hle⟩
rw [hdistance] at hd
have : d = distance := (Option.some.inj hd).symm
omegaThe final BFS distance map is defined exactly on reachable vertices.
theorem bfsState_distance_defined_iff_reachable {s v : V} (hs : s ∈ G.vertices) :
(∃ distance, (bfsState G s hs).distance v = some distance) ↔ G.Reachable s v := by
have hinv := bfsState_distanceInvariant G hs
rw [← hinv.distance_iff_visited v, bfsState_visited_eq_bfs G hs]
constructor
· exact bfs_sound G hs
· exact bfs_complete G hsComplete iff specification for the distance returned by CLRS BFS.
theorem bfsState_distance_eq_some_iff {s v : V} (hs : s ∈ G.vertices)
{distance : Nat} :
(bfsState G s hs).distance v = some distance ↔
G.IsShortestDistance s v distance := by
constructor
· exact bfsState_distance_isShortest G hs
· intro hshortest
rcases (bfsState_distance_defined_iff_reachable G hs).2
(hshortest.reachable G) with ⟨d, hd⟩
have hd_shortest := bfsState_distance_isShortest G hs hd
have h1 : distance ≤ d := hshortest.2 d hd_shortest.1
have h2 : d ≤ distance := hd_shortest.2 distance hshortest.1
have : d = distance := Nat.le_antisymm h2 h1
simpa [this] using hdEvery recorded predecessor is a graph edge and decreases BFS distance by exactly one when followed toward the source.
-- =============================================================================
-- Predecessor-tree correctness
-- =============================================================================
theorem bfsState_parent_spec {s u v : V} (hs : s ∈ G.vertices)
(hparent : (bfsState G s hs).parent v = some u) :
G.Adj u v ∧ ∃ d,
(bfsState G s hs).distance u = some d ∧
(bfsState G s hs).distance v = some (d + 1) := by
exact (bfsState_distanceInvariant G hs).parent_step u v hparentA non-source vertex has a predecessor exactly when it is reachable.
theorem bfsState_parent_defined_iff {s v : V} (hs : s ∈ G.vertices) :
(∃ u, (bfsState G s hs).parent v = some u) ↔
G.Reachable s v ∧ v ≠ s := by
have hinv := bfsState_distanceInvariant G hs
constructor
· rintro ⟨u, hparent⟩
rcases hinv.parent_step u v hparent with ⟨_, d, _, hdv⟩
constructor
· exact (bfsState_distance_reachableIn G hs hdv).reachable G
· intro hvs
subst v
rw [hinv.source_parent] at hparent
contradiction
· rintro ⟨hreach, hvs⟩
have hv_bfs : v ∈ bfs G s hs := bfs_complete G hs hreach
have hv_visited : v ∈ (bfsState G s hs).visited := by
rw [bfsState_visited_eq_bfs G hs]
exact hv_bfs
exact hinv.parent_exists v hv_visited hvsThe root has no predecessor.
theorem bfsState_source_parent {s : V} (hs : s ∈ G.vertices) :
(bfsState G s hs).parent s = none :=
(bfsState_distanceInvariant G hs).source_parentThe parent pointers recover a source-to-vertex path whose length is the recorded distance.
theorem bfsState_parentPath {s v : V} (hs : s ∈ G.vertices) {distance : Nat}
(hdistance : (bfsState G s hs).distance v = some distance) :
BFSParentPath (bfsState G s hs).parent s v distance :=
(bfsState_distanceInvariant G hs).parentPath_of_distance G hdistanceFollowing a predecessor edge strictly increases level away from the root.
theorem bfsState_parent_level_lt {s u v : V} (hs : s ∈ G.vertices)
(hparent : (bfsState G s hs).parent v = some u) :
(bfsState G s hs).level u < (bfsState G s hs).level v := by
rcases bfsState_parent_spec G hs hparent with ⟨_, d, hdu, hdv⟩
simp [BFSState.level, hdu, hdv]The predecessor relation is acyclic.
theorem bfsState_parent_acyclic {s : V} (hs : s ∈ G.vertices) (v : V) :
¬Relation.TransGen
(fun u w => (bfsState G s hs).parent w = some u) v v := by
intro hcycle
have hlt_of_trans : ∀ {a b},
Relation.TransGen (fun u w => (bfsState G s hs).parent w = some u) a b →
(bfsState G s hs).level a < (bfsState G s hs).level b := by
intro a b h
induction h with
| single hparent => exact bfsState_parent_level_lt G hs hparent
| tail _ hparent ih =>
exact lt_trans ih (bfsState_parent_level_lt G hs hparent)
have hlt := hlt_of_trans hcycle
exact (Nat.lt_irrefl _ hlt)
Specification of a rooted predecessor tree spanning precisely the vertices
reachable from s.
structure IsBFSPredecessorTree (G : Graph V) (s : V) (state : BFSState V) : Prop where
root_parent : state.parent s = none
parent_defined_iff : ∀ v, (∃ u, state.parent v = some u) ↔
G.Reachable s v ∧ v ≠ s
parent_edge : ∀ u v, state.parent v = some u → G.Adj u v
parent_distance : ∀ u v, state.parent v = some u →
∃ d, state.distance u = some d ∧ state.distance v = some (d + 1)
parent_path : ∀ v d, state.distance v = some d →
BFSParentPath state.parent s v d
acyclic : ∀ v, ¬Relation.TransGen (fun u w => state.parent w = some u) v vThe parent pointers returned by CLRS BFS form a rooted predecessor tree on all and only reachable vertices.
theorem bfsState_isBFSPredecessorTree {s : V} (hs : s ∈ G.vertices) :
G.IsBFSPredecessorTree s (bfsState G s hs) := by
refine {
root_parent := bfsState_source_parent G hs
parent_defined_iff := fun v => bfsState_parent_defined_iff G hs
parent_edge := ?_
parent_distance := ?_
parent_path := ?_
acyclic := bfsState_parent_acyclic G hs
}
· intro u v hparent
exact (bfsState_parent_spec G hs hparent).1
· intro u v hparent
exact (bfsState_parent_spec G hs hparent).2
· intro v d hd
exact bfsState_parentPath G hs hdCombined shortest-distance and predecessor-tree specification.
def IsCorrectBFSState (G : Graph V) (s : V) (state : BFSState V) : Prop :=
(∀ v d, state.distance v = some d ↔ G.IsShortestDistance s v d) ∧
G.IsBFSPredecessorTree s stateThe labelled FIFO implementation satisfies the full CLRS BFS specification.
theorem bfsState_correct {s : V} (hs : s ∈ G.vertices) :
G.IsCorrectBFSState s (bfsState G s hs) := by
constructor
· intro v d
exact bfsState_distance_eq_some_iff G hs
· exact bfsState_isBFSPredecessorTree G hsThe work already performed by BFS before a given state: every vertex that has left the queue counts one dequeue operation plus one adjacency-list scan per out-neighbor. Dequeued vertices are exactly the visited vertices that are no longer in the queue.
-- =============================================================================
-- Cost layer: O(V + E) running time
-- =============================================================================
noncomputable def bfsWork (G : Graph V) (visited : Finset V) (queue : List V) : Nat :=
(visited \ queue.toFinset).card +
∑ v ∈ (visited \ queue.toFinset), (G.adj v).cardDequeuing a vertex advances the work measure by exactly one dequeue plus the scanned out-degree of that vertex.
theorem bfsWork_step {u : V} {rest : List V} {state : BFSState V}
(hu : u ∈ state.visited) (hu_rest : u ∉ rest) :
bfsWork G (bfsStateAdvance G state u rest).visited (bfsStateAdvance G state u rest).queue
= bfsWork G state.visited (u :: rest) + 1 + (G.adj u).card := by
have hnot_vis {x : V} (hx : x ∈ bfsNewNeighbors G state u) : x ∉ state.visited :=
(mem_bfsNewNeighbors_iff G).1 hx |>.2
have huN : u ∉ bfsNewNeighbors G state u := by
intro huN
exact (hnot_vis huN) hu
have hdequeued : (state.visited ∪ bfsNewNeighbors G state u) \ (rest.toFinset ∪ bfsNewNeighbors G state u) =
insert u (state.visited \ insert u rest.toFinset) := by
ext x
by_cases hxN : x ∈ bfsNewNeighbors G state u
· simp [hxN, hnot_vis hxN]
intro hxu
rw [hxu] at hxN
exact huN hxN
· simp [hxN]
constructor
· rintro ⟨hxv, hxr⟩
by_cases hxu : x = u
· exact Or.inl hxu
· exact Or.inr ⟨hxv, hxu, hxr⟩
· rintro (hxu | ⟨hxv, _hxne, hxr⟩)
· subst hxu
exact ⟨hu, hu_rest⟩
· exact ⟨hxv, hxr⟩
simp [bfsWork, bfsStateAdvance]
rw [hdequeued]
have huA : u ∉ state.visited \ insert u rest.toFinset := by simp
simp [huA]
omegaThe successor queue of a BFS step stays duplicate-free.
theorem bfsStateAdvance_queue_nodup {state : BFSState V} {u : V} {rest : List V}
(hnodup : (u :: rest).Nodup) (hqueue : G.BFSQueueInv state.visited (u :: rest)) :
(bfsStateAdvance G state u rest).queue.Nodup := by
let N : Finset V := bfsNewNeighbors G state u
have hrest : rest.Nodup := (List.nodup_cons.mp hnodup).2
have hN : N.toList.Nodup := Finset.nodup_toList N
have hdisjoint : ∀ a ∈ rest, ∀ b ∈ N.toList, a ≠ b := by
intro a ha b hb hab
rw [← hab] at hb
have havis : a ∈ state.visited := hqueue a (by simp [ha])
have haN : a ∈ N := Finset.mem_toList.mp hb
have hanotvis : a ∉ state.visited := (mem_bfsNewNeighbors_iff G).1 haN |>.2
exact hanotvis havis
have hnodup' : (rest ++ N.toList).Nodup := by
rw [List.nodup_append]
exact ⟨hrest, hN, hdisjoint⟩
simpa [bfsStateAdvance, N] using hnodup'
Fuelled labelled BFS that also accumulates the total work. Each step that
processes the front vertex u costs one dequeue plus one adjacency-list
scan per out-neighbor of u.
noncomputable def bfsStateAuxWithCost (G : Graph V) : Nat → BFSState V → BFSState V × Nat
| 0, state => (state, 0)
| fuel + 1, state =>
match state.queue with
| [] => (state, 0)
| u :: rest =>
let (state', cost) := bfsStateAuxWithCost G fuel (bfsStateAdvance G state u rest)
(state', 1 + (G.adj u).card + cost)Erasing the cost recovers the plain fuelled labelled BFS.
theorem bfsStateAuxWithCost_result (fuel : Nat) (state : BFSState V) :
(bfsStateAuxWithCost G fuel state).1 = bfsStateAux G fuel state := by
induction fuel generalizing state with
| zero => simp [bfsStateAuxWithCost, bfsStateAux]
| succ n ih =>
cases hqueue : state.queue with
| nil => simp [bfsStateAuxWithCost, bfsStateAux, hqueue]
| cons u rest =>
simp [bfsStateAuxWithCost, bfsStateAux, hqueue]
exact ih (bfsStateAdvance G state u rest)The cost accumulated by a fuelled run equals the increase in the BFS work measure over the run.
theorem bfsStateAuxWithCost_cost_eq (fuel : Nat) (state : BFSState V)
(hqueue : G.BFSQueueInv state.visited state.queue)
(hnodup : state.queue.Nodup) :
(bfsStateAuxWithCost G fuel state).2 + bfsWork G state.visited state.queue
= bfsWork G (bfsStateAuxWithCost G fuel state).1.visited
(bfsStateAuxWithCost G fuel state).1.queue := by
induction fuel generalizing state with
| zero => simp [bfsStateAuxWithCost]
| succ n ih =>
cases hq : state.queue with
| nil => simp [bfsStateAuxWithCost, hq]
| cons u rest =>
have hqcond : state.queue = u :: rest := hq
have hqinv : G.BFSQueueInv state.visited (u :: rest) := by simpa [hqcond] using hqueue
have hnd : (u :: rest).Nodup := by simpa [hqcond] using hnodup
have hqueue' : G.BFSQueueInv (bfsStateAdvance G state u rest).visited
(bfsStateAdvance G state u rest).queue := by
simpa [bfsStateAdvance, bfsNewNeighbors] using bfsQueueInv_step G hqinv
have hnodup' : (bfsStateAdvance G state u rest).queue.Nodup := by
simpa using bfsStateAdvance_queue_nodup (G := G) hnd hqinv
have hih := ih (bfsStateAdvance G state u rest) hqueue' hnodup'
have hu_mem_queue : u ∈ state.queue := by simp [hqcond]
have hu : u ∈ state.visited := hqueue u hu_mem_queue
have hu_rest : u ∉ rest := (List.nodup_cons.mp hnd).1
have hwork := bfsWork_step (G := G) (state := state) (u := u) (rest := rest) hu hu_rest
simp [bfsStateAuxWithCost, hq]
rw [← hih]
rw [hwork]
omegaThe final visited set of BFS is contained in the vertex set.
theorem bfsState_visited_subset {s : V} (hs : s ∈ G.vertices) :
(bfsState G s hs).visited ⊆ G.vertices := by
intro v hv
rw [bfsState_visited_eq_bfs G hs] at hv
exact G.reachable_mem_vertices hs (bfs_sound G hs hv)CLRS BFS with distances, predecessors, and a work counter.
noncomputable def bfsStateWithCost (G : Graph V) (s : V) (_hs : s ∈ G.vertices) : BFSState V × Nat :=
bfsStateAuxWithCost G G.vertices.card (bfsStateInit s)
Erasing the cost recovers bfsState.
theorem bfsStateWithCost_result {s : V} (hs : s ∈ G.vertices) :
(bfsStateWithCost G s hs).1 = bfsState G s hs := by
simpa [bfsStateWithCost, bfsState] using
bfsStateAuxWithCost_result G G.vertices.card (bfsStateInit s)The initial BFS work measure is zero.
theorem bfsWork_init {s : V} :
bfsWork G (bfsStateInit s).visited (bfsStateInit s).queue = 0 := by
simp [bfsWork, bfsStateInit]
BFS running time. The instrumented breadth-first search costs at most
V + E control steps, where V is the number of vertices and E
is the number of directed edges; BFS therefore runs in O(V + E) (CLRS
Theorem 20.5).
theorem bfsStateWithCost_cost_le {s : V} (hs : s ∈ G.vertices) :
(bfsStateWithCost G s hs).2 ≤ G.vertices.card + edgeCount G := by
let res := bfsStateAuxWithCost G G.vertices.card (bfsStateInit s)
have hinit_queue : G.BFSQueueInv (bfsStateInit s).visited (bfsStateInit s).queue := by
intro v hv
simpa [BFSQueueInv, bfsStateInit] using hv
have hinit_nodup : (bfsStateInit s).queue.Nodup := by
simp [bfsStateInit]
have hcost := bfsStateAuxWithCost_cost_eq G G.vertices.card (bfsStateInit s) hinit_queue hinit_nodup
have hwork0 := bfsWork_init (G := G) (s := s)
have hqueue_empty : res.1.queue = [] := by
have h := bfsStateAuxWithCost_result G G.vertices.card (bfsStateInit s)
change res.1 = bfsStateAux G G.vertices.card (bfsStateInit s) at h
rw [h]
have hq := bfsState_queue_empty G hs
simpa [bfsState] using hq
have hsub : res.1.visited ⊆ G.vertices := by
have h := bfsStateAuxWithCost_result G G.vertices.card (bfsStateInit s)
change res.1 = bfsStateAux G G.vertices.card (bfsStateInit s) at h
rw [h]
exact bfsState_visited_subset G hs
-- cost = work(final) - work(init) = work(final)
have hcost' : res.2 = bfsWork G res.1.visited res.1.queue := by
change (bfsStateAuxWithCost G G.vertices.card (bfsStateInit s)).2 =
bfsWork G (bfsStateAuxWithCost G G.vertices.card (bfsStateInit s)).1.visited
(bfsStateAuxWithCost G G.vertices.card (bfsStateInit s)).1.queue
rw [hwork0] at hcost
simpa using hcost
rw [bfsStateWithCost]
change res.2 ≤ G.vertices.card + edgeCount G
rw [hcost', hqueue_empty]
simp [bfsWork, edgeCount]
exact Nat.add_le_add (Finset.card_le_card hsub)
(Finset.sum_le_sum_of_subset_of_nonneg hsub (by intro x hx hxs; exact Nat.zero_le _))end Graphend Chapter22end CLRSImports
import Mathlib
import CLRSLean.FourthEdition.Chapter_20.Section_20_1_Representing_Graphs20.3. Depth-First Search
This section gives a functional depth-first-search procedure on the finite graph
model from Section 20.1 and proves a basic correctness invariant: after DFS,
every vertex of the graph is black. Timestamps, parent pointers, and vertex
colors (white/gray/black) are represented as functions, so the algorithm is
noncomputable because it iterates over Finset.toList.
The white-path theorem and the discovery-state infrastructure built on this
model are proved in the companion Section_20_3_DFS.S1_WhitePath and
Section_20_3_DFS.S2_Intervals modules. The latter also proves the timestamp
form of the parenthesis theorem. The ancestor characterization and unique
tree/back/forward/cross classification are proved in the downstream companion
modules.
Implementation details
The detailed DFS proof layers remain available outside the main sidebar:
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V]Vertex colors used by DFS.
inductive Color where
| white | gray | black
deriving DecidableEq, InhabitedMutable DFS state: colors, discovery/finish times, parents, and a global clock.
structure DFSState (V : Type) [DecidableEq V] where
color : V → Color
d : V → Option Nat
f : V → Option Nat
parent : V → Option V
time : Nat
deriving Inhabitednamespace DFSStateChange the color of one vertex.
def setColor (s : DFSState V) (v : V) (c : Color) : DFSState V :=
{ s with color := fun x => if x = v then c else s.color x }
Record the discovery time of v and advance the clock.
def setDiscovery (s : DFSState V) (v : V) : DFSState V :=
{ s with d := fun x => if x = v then some s.time else s.d x, time := s.time + 1 }
Record the finish time of v and advance the clock.
def setFinish (s : DFSState V) (v : V) : DFSState V :=
{ s with f := fun x => if x = v then some s.time else s.f x, time := s.time + 1 }
Set the parent of v to u.
def setParent (s : DFSState V) (v u : V) : DFSState V :=
{ s with parent := fun x => if x = v then some u else s.parent x }@[simp]
theorem setColor_color (s : DFSState V) (v x : V) (c : Color) :
(s.setColor v c).color x = if x = v then c else s.color x := rfl@[simp]
theorem setDiscovery_color (s : DFSState V) (v x : V) :
(s.setDiscovery v).color x = s.color x := rfl@[simp]
theorem setFinish_color (s : DFSState V) (v x : V) :
(s.setFinish v).color x = s.color x := rfl@[simp]
theorem setParent_color (s : DFSState V) (v u x : V) :
(s.setParent v u).color x = s.color x := rfl@[simp]
theorem setColor_d (s : DFSState V) (v x : V) (c : Color) :
(s.setColor v c).d x = s.d x := rfl@[simp]
theorem setDiscovery_d (s : DFSState V) (v x : V) :
(s.setDiscovery v).d x = if x = v then some s.time else s.d x := rfl@[simp]
theorem setFinish_d (s : DFSState V) (v x : V) :
(s.setFinish v).d x = s.d x := rfl@[simp]
theorem setParent_d (s : DFSState V) (v u x : V) :
(s.setParent v u).d x = s.d x := rfl@[simp]
theorem setColor_f (s : DFSState V) (v x : V) (c : Color) :
(s.setColor v c).f x = s.f x := rfl@[simp]
theorem setDiscovery_f (s : DFSState V) (v x : V) :
(s.setDiscovery v).f x = s.f x := rfl@[simp]
theorem setFinish_f (s : DFSState V) (v x : V) :
(s.setFinish v).f x = if x = v then some s.time else s.f x := rfl@[simp]
theorem setParent_f (s : DFSState V) (v u x : V) :
(s.setParent v u).f x = s.f x := rfl@[simp]
theorem setColor_parent (s : DFSState V) (v x : V) (c : Color) :
(s.setColor v c).parent x = s.parent x := rfl@[simp]
theorem setDiscovery_parent (s : DFSState V) (v x : V) :
(s.setDiscovery v).parent x = s.parent x := rfl@[simp]
theorem setFinish_parent (s : DFSState V) (v x : V) :
(s.setFinish v).parent x = s.parent x := rfl@[simp]
theorem setParent_parent (s : DFSState V) (v u x : V) :
(s.setParent v u).parent x = if x = v then some u else s.parent x := rfl@[simp]
theorem setColor_time (s : DFSState V) (v : V) (c : Color) :
(s.setColor v c).time = s.time := rfl@[simp]
theorem setDiscovery_time (s : DFSState V) (v : V) :
(s.setDiscovery v).time = s.time + 1 := rfl@[simp]
theorem setFinish_time (s : DFSState V) (v : V) :
(s.setFinish v).time = s.time + 1 := rfl@[simp]
theorem setParent_time (s : DFSState V) (v u : V) :
(s.setParent v u).time = s.time := rflend DFSStatevariable (G : Graph V)
One DFS tree visit from a white source vertex u.
noncomputable def dfsVisit (fuel : Nat) (u : V) (s : DFSState V) : DFSState V :=
match fuel with
| 0 => s
| fuel + 1 =>
if s.color u = Color.white then
let s := s.setColor u Color.gray |>.setDiscovery u
let s := (G.adj u).toList.foldl (fun s' v =>
if s'.color v = Color.white then dfsVisit fuel v (s'.setParent v u) else s') s
s.setColor u Color.black |>.setFinish u
else
sInitial DFS state: all vertices are white and no times/parents are set.
def dfsInit : DFSState V := {
color := fun _ => Color.white,
d := fun _ => none,
f := fun _ => none,
parent := fun _ => none,
time := 0
}Recursive DFS over a list of starting vertices.
noncomputable def dfsFromList (fuel : Nat) : List V → DFSState V → DFSState V
| [], s => s
| u :: us, s =>
let s' := if s.color u = Color.white then dfsVisit G fuel u s else s
dfsFromList fuel us s'Depth-first search over the whole graph.
noncomputable def dfs (G : Graph V) : DFSState V :=
dfsFromList G (G.vertices.card + 1) G.vertices.toList dfsInitsection BasicPropertiesA DFS visit from a white vertex turns that vertex black (if fuel is positive).
theorem dfsVisit_blackens_u {fuel : Nat} {u : V} {s : DFSState V}
(hwhite : s.color u = Color.white) :
(dfsVisit G (fuel + 1) u s).color u = Color.black := by
simp [dfsVisit, hwhite]A DFS visit never turns a black vertex back to white or gray.
theorem dfsVisit_preserves_black {fuel : Nat} {u x : V} {s : DFSState V}
(hblack : s.color x = Color.black) :
(dfsVisit G fuel u s).color x = Color.black := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]; exact hblack
| succ n ih =>
by_cases h : s.color u = Color.white
· -- u is white: the visit processes it and its neighbors
simp [dfsVisit, h]
by_cases hxu : x = u
· subst hxu
simp
· let s1 := s.setColor u Color.gray |>.setDiscovery u
have h2 : ∀ (s1 : DFSState V), s1.color x = Color.black →
((G.adj u).toList.foldl (fun s' v =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1).color x = Color.black := by
intro s1 hs1x
induction (G.adj u).toList generalizing s1 with
| nil => simp [hs1x]
| cons w ws ih' =>
simp
split_ifs with hw
· have hsp : (s1.setParent w u).color x = Color.black := by simp [hs1x]
have hrec : (dfsVisit G n w (s1.setParent w u)).color x = Color.black :=
ih (u := w) (s := s1.setParent w u) hsp
exact ih' (dfsVisit G n w (s1.setParent w u)) hrec
· exact ih' s1 hs1x
have hs1x : s1.color x = Color.black := by
simp [s1, hxu, hblack]
simp [s1, hxu, h2 s1 hs1x]
· -- u is not white: the visit returns the state unchanged
simp [dfsVisit, h]
exact hblackA DFS visit does not introduce new gray vertices. The temporary gray on the source vertex is removed before the call returns.
theorem dfsVisit_no_new_gray {fuel : Nat} {u : V} {s : DFSState V} (w : V) :
(dfsVisit G fuel u s).color w = Color.gray → s.color w = Color.gray := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases h : s.color u = Color.white
· -- u is white: the visit processes it and its neighbors
simp [dfsVisit, h]
by_cases hwu : w = u
· -- the final step turns u black, so u cannot be gray in the output
subst hwu
simp
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s'
have hfold : ∀ (s1 : DFSState V),
((G.adj u).toList.foldl step s1).color w = Color.gray → s1.color w = Color.gray := by
intro s1
induction (G.adj u).toList generalizing s1 with
| nil => simp
| cons v vs ih' =>
intro hy
by_cases hv : s1.color v = Color.white
· -- v is white, so the fold first recurses into v
let s' := dfsVisit G n v (s1.setParent v u)
have hstep : step s1 v = s' := by simp [step, hv, s']
have hy' : (List.foldl step s' vs).color w = Color.gray := by
simp [List.foldl, hstep] at hy
exact hy
have hs' : s'.color w = Color.gray → s1.color w = Color.gray := by
intro hz
have hrec := ih (u := v) (s := s1.setParent v u) hz
simpa using hrec
exact hs' (ih' s' hy')
· -- v is not white, the fold leaves the state unchanged on this step
have hstep : step s1 v = s1 := by simp [step, hv]
have hy' : (List.foldl step s1 vs).color w = Color.gray := by
simp [List.foldl, hstep] at hy
exact hy
exact ih' s1 hy'
intro hw
simp [if_neg hwu] at hw
have h1 := hfold s1 hw
simp [s1, hwu] at h1
exact h1
· -- u is not white: the visit returns the state unchanged
intro hw
simp [dfsVisit, h] at hw ⊢
exact hwA DFS visit from a white input vertex leaves it white or turns it black, never gray.
theorem dfsVisit_white_stays_white_or_black {fuel : Nat} {u x : V} {s : DFSState V}
(hwhite : s.color x = Color.white) (hnblack : (dfsVisit G fuel u s).color x ≠ Color.black) :
(dfsVisit G fuel u s).color x = Color.white := by
have hng : (dfsVisit G fuel u s).color x ≠ Color.gray := by
intro h
have := dfsVisit_no_new_gray G x h
simp [hwhite] at this
cases hcolor : (dfsVisit G fuel u s).color x with
| white => rfl
| gray => contradiction
| black => contradictionIf the input has no gray vertices, the output of a DFS visit has no gray vertices either.
theorem dfsVisit_output_no_gray {fuel : Nat} {u : V} {s : DFSState V}
(h : ∀ w, s.color w = Color.white ∨ s.color w = Color.black) :
∀ w, (dfsVisit G fuel u s).color w = Color.white ∨ (dfsVisit G fuel u s).color w = Color.black := by
intro w
by_cases hgray : (dfsVisit G fuel u s).color w = Color.gray
· have h' := dfsVisit_no_new_gray G w hgray
have hw := h w
simp [h'] at hw
· cases h' : (dfsVisit G fuel u s).color w with
| gray => contradiction
| white => simp
| black => simpRecursive DFS over a list preserves black vertices.
theorem dfsFromList_preserves_black (s0 : DFSState V) (fuel : Nat) (vs : List V) {x : V}
(hblack : s0.color x = Color.black) :
(dfsFromList G fuel vs s0).color x = Color.black := by
induction vs generalizing s0 with
| nil => simpa [dfsFromList] using hblack
| cons u us ih =>
simp [dfsFromList]
split_ifs
· exact ih (dfsVisit G fuel u s0) (dfsVisit_preserves_black G hblack)
· exact ih s0 hblackA positive DFS visit from a white vertex turns that vertex black.
theorem dfsVisit_blackens_u_pos {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
(dfsVisit G fuel u s).color u = Color.black := by
cases fuel with
| zero => linarith
| succ n => exact dfsVisit_blackens_u G hwhite
One step of the inner dfsVisit fold preserves black vertices.
theorem dfsVisit_fold_step_preserves_black {n : Nat} {u x w : V} {s1 : DFSState V}
(hb : s1.color x = Color.black) :
((if s1.color w = Color.white then dfsVisit G n w (s1.setParent w u) else s1).color x = Color.black) := by
split_ifs with hw
· have hsp : (s1.setParent w u).color x = Color.black := by simp [hb]
exact dfsVisit_preserves_black G hsp
· exact hbThe inner fold of a DFS visit preserves black vertices.
theorem dfsVisit_fold_preserves_black {n : Nat} {u x : V} {s1 : DFSState V} {l : List V}
(hb : s1.color x = Color.black) :
(l.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1).color x = Color.black := by
induction l generalizing s1 with
| nil =>
exact hb
| cons w ws ih =>
simp
exact ih (dfsVisit_fold_step_preserves_black G hb)The inner fold of a DFS visit does not introduce new gray vertices.
theorem dfsVisit_fold_no_new_gray {n : Nat} {u w : V} (s1 : DFSState V) {l : List V} :
(List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 l).color w = Color.gray →
s1.color w = Color.gray := by
induction l generalizing s1 with
| nil =>
intro h
exact h
| cons v vs ih =>
simp
by_cases hv : s1.color v = Color.white
· simp [hv]
intro hw
by_cases hwv : w = v
· subst w
have hnotgray : (dfsVisit G n v (s1.setParent v u)).color v ≠ Color.gray := by
by_cases hb : (dfsVisit G n v (s1.setParent v u)).color v = Color.black
· rw [hb]; decide
· have hwhite : (dfsVisit G n v (s1.setParent v u)).color v = Color.white :=
dfsVisit_white_stays_white_or_black G (by simpa using hv) hb
rw [hwhite]; decide
have hrec : (dfsVisit G n v (s1.setParent v u)).color v = Color.gray :=
ih (dfsVisit G n v (s1.setParent v u)) hw
contradiction
· have hrec : (dfsVisit G n v (s1.setParent v u)).color w = Color.gray :=
ih (dfsVisit G n v (s1.setParent v u)) hw
have hsp : (s1.setParent v u).color w = Color.gray :=
dfsVisit_no_new_gray G w hrec
simpa [hwv] using hsp
· simp [hv]
exact ih s1Recursive DFS over a list blackens every listed vertex while preserving the white/black (no gray) invariant.
theorem dfsFromList_all_black (s0 : DFSState V)
(h0 : ∀ w, s0.color w = Color.white ∨ s0.color w = Color.black)
{fuel : Nat} (hfuel : 0 < fuel) (vs : List V) :
(∀ z ∈ vs, (dfsFromList G fuel vs s0).color z = Color.black) ∧
(∀ w, (dfsFromList G fuel vs s0).color w = Color.white ∨
(dfsFromList G fuel vs s0).color w = Color.black) := by
induction vs generalizing s0
· constructor
· simp
· intro w; exact h0 w
· rename_i head us ih
let s' := if s0.color head = Color.white then dfsVisit G fuel head s0 else s0
have hng' : ∀ w, s'.color w = Color.white ∨ s'.color w = Color.black := by
simp [s']
split_ifs with hwhite
· apply dfsVisit_output_no_gray
intro w
cases h0 w <;> simp [*]
· intro w; cases h0 w <;> simp [*]
have ⟨ih1, ih2⟩ := ih s' hng'
constructor
· intro y hy
simp at hy
rcases hy with (rfl | hy)
· -- y is the head of the list
simp [dfsFromList]
split_ifs with hwhite
· have hblack : (dfsVisit G fuel y s0).color y = Color.black := dfsVisit_blackens_u_pos G hfuel hwhite
exact dfsFromList_preserves_black G (dfsVisit G fuel y s0) fuel us hblack
· have hblack : s0.color y = Color.black := by
cases h0 y <;> tauto
exact dfsFromList_preserves_black G s0 fuel us hblack
· exact ih1 y hy
· exact ih2
After dfs, every vertex of the graph is black.
theorem dfs_all_black {v : V} (hv : v ∈ G.vertices) :
(G.dfs).color v = Color.black := by
simp [dfs, dfsInit]
have hfuel : 0 < G.vertices.card + 1 := by linarith [Finset.card_pos.mpr ⟨v, hv⟩]
have hblack := (dfsFromList_all_black G dfsInit (by simp [dfsInit]) hfuel G.vertices.toList).1
exact hblack v (by simp [hv])Timestamp invariants
section TimestampsA gray vertex that is not the source of a DFS visit remains gray.
theorem dfsVisit_preserves_gray {fuel : Nat} {u x : V} {s : DFSState V}
(hx : s.color x = Color.gray) (hne : x ≠ u) :
(dfsVisit G fuel u s).color x = Color.gray := by
induction fuel generalizing u x s with
| zero => simp [dfsVisit]; exact hx
| succ n ih =>
simp [dfsVisit]
split_ifs with hwhite
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hx1 : s1.color x = Color.gray := by
simp [s1, hx, hne]
have hx2 : s2.color x = Color.gray := by
have hfold : ∀ (l : List V) (s' : DFSState V),
s'.color x = Color.gray →
(List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).color x = Color.gray := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa
| cons v vs ih' =>
simp
by_cases hv : s'.color v = Color.white
· simp [hv]
apply ih' (dfsVisit G n v (s'.setParent v u))
have hsp : (s'.setParent v u).color x = Color.gray := by simp [hs']
have hne' : x ≠ v := by
intro h
subst x
simp [hs'] at hv
exact ih hsp hne'
· simp [hv]
exact ih' s' hs'
exact hfold (G.adj u).toList s1 hx1
have : s3.color x = Color.gray := by
simp [s3, hx2, hne]
exact this
· exact hxDuring a DFS visit, the source vertex stays gray until the final blackening step.
theorem dfsVisit_u_stays_gray {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G (fuel - 1) v (s'.setParent v u) else s') s1 (G.adj u).toList
s2.color u = Color.gray := by
cases fuel with
| zero => linarith
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
have h1 : s1.color u = Color.gray := by simp [s1]
have hfold : ∀ (l : List V) (s' : DFSState V),
s'.color u = Color.gray →
(List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).color u = Color.gray := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa
| cons v vs ih' =>
simp
by_cases hv : s'.color v = Color.white
· simp [hv]
apply ih' (dfsVisit G n v (s'.setParent v u))
have hsp : (s'.setParent v u).color u = Color.gray := by simp [hs']
have hne : u ≠ v := by
intro h
subst u
simp [hs'] at hv
exact dfsVisit_preserves_gray G hsp hne
· simp [hv]
exact ih' s' hs'
exact hfold (G.adj u).toList s1 h1
The discovery time of v in s, defaulting to 0 if it has
not been set.
The finish time of v in s, defaulting to 0 if it has
not been set.
Timestamp invariant: colors are white/gray/black, every non-white vertex has a discovery time, and every black vertex has a finish time.
def TimestampInvariant (s : DFSState V) : Prop :=
(∀ v, s.color v = Color.white ∨ s.color v = Color.gray ∨ s.color v = Color.black) ∧
(∀ v, s.color v ≠ Color.white → s.d v ≠ none) ∧
(∀ v, s.color v = Color.black → s.f v ≠ none)theorem TimestampInvariant_init : TimestampInvariant (dfsInit : DFSState V) := by
simp [TimestampInvariant, dfsInit]theorem setColor_white_preserves_TimestampInvariant {s : DFSState V} {v : V}
(hinv : TimestampInvariant s) :
TimestampInvariant (s.setColor v Color.white) := by
rcases hinv with ⟨hng, hd, hf⟩
constructor
· intro w
by_cases heq : w = v
· simp [heq]
· simp [heq]
exact hng w
constructor
· intro w h
by_cases heq : w = v
· simp [heq] at h
· simp [heq] at h ⊢
exact hd w h
· intro w h
by_cases heq : w = v
· simp [heq] at h
· simp [heq] at h ⊢
exact hf w hGraying a vertex and recording its discovery time preserves the invariant.
theorem grayAndDiscover_preserves_TimestampInvariant {s : DFSState V} {v : V}
(hinv : TimestampInvariant s) :
TimestampInvariant ((s.setColor v Color.gray).setDiscovery v) := by
rcases hinv with ⟨hng, hd, hf⟩
constructor
· intro w
by_cases heq : w = v
· simp [heq]
· simp [heq]
exact hng w
constructor
· intro w h
by_cases heq : w = v
· simp [heq]
· simp [heq] at h ⊢
exact hd w h
· intro w h
by_cases heq : w = v
· simp [heq] at h
· simp [heq] at h ⊢
exact hf w hBlackening a vertex and recording its finish time preserves the invariant.
theorem blackAndFinish_preserves_TimestampInvariant {s : DFSState V} {v : V}
(hinv : TimestampInvariant s) (hgray : s.color v = Color.gray) :
TimestampInvariant ((s.setColor v Color.black).setFinish v) := by
rcases hinv with ⟨hng, hd, hf⟩
constructor
· intro w
by_cases heq : w = v
· simp [heq]
· simp [heq]
exact hng w
constructor
· intro w h
by_cases heq : w = v
· simp [heq]
exact hd v (by simp [hgray])
· simp [heq] at h ⊢
exact hd w h
· intro w h
by_cases heq : w = v
· simp [heq]
· simp [heq] at h ⊢
exact hf w htheorem setParent_preserves_TimestampInvariant {s : DFSState V} {v p : V}
(hinv : TimestampInvariant s) :
TimestampInvariant (s.setParent v p) := by
rcases hinv with ⟨hng, hd, hf⟩
simp [TimestampInvariant]
exact ⟨hng, hd, hf⟩A DFS visit from a white vertex preserves the timestamp invariant.
theorem dfsVisit_preserves_TimestampInvariant {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hinv : TimestampInvariant s) (hwhite : s.color u = Color.white) :
TimestampInvariant (dfsVisit G fuel u s) := by
induction fuel generalizing u s hinv hwhite with
| zero => linarith
| succ n ih =>
simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
have hinv1 : TimestampInvariant s1 := grayAndDiscover_preserves_TimestampInvariant hinv
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
have hinv2 : TimestampInvariant s2 := by
have step : ∀ (s' : DFSState V) (x : V),
TimestampInvariant s' → s'.color x = Color.white →
TimestampInvariant (dfsVisit G n x (s'.setParent x u)) := by
intro s' x hinv' hx
by_cases hn0 : n = 0
· simp [hn0, dfsVisit]
exact setParent_preserves_TimestampInvariant hinv'
· exact @ih x (s'.setParent x u) (by omega) (setParent_preserves_TimestampInvariant hinv') hx
have hfold : ∀ (l : List V) (s' : DFSState V),
TimestampInvariant s' →
TimestampInvariant (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l) := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'
| cons v vs ih' =>
simp
by_cases hv : s'.color v = Color.white
· simp [hv]
exact ih' (dfsVisit G n v (s'.setParent v u)) (step s' v hs' hv)
· simp [hv]
exact ih' s' hs'
exact hfold (G.adj u).toList s1 hinv1
have hgray : s2.color u = Color.gray := by
apply dfsVisit_u_stays_gray G hfuel hwhite
exact blackAndFinish_preserves_TimestampInvariant hinv2 hgrayRecursive DFS over a list preserves the timestamp invariant.
theorem dfsFromList_preserves_TimestampInvariant {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hfuel : 0 < fuel) (hinv : TimestampInvariant s0) :
TimestampInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0
· simpa [dfsFromList]
· rename_i u us ih
simp [dfsFromList]
split_ifs with hwhite
· exact ih (dfsVisit_preserves_TimestampInvariant G hfuel hinv hwhite)
· exact ih hinv
After dfs, every vertex has a defined discovery time.
theorem dfs_d_defined {v : V} (hv : v ∈ G.vertices) :
(G.dfs).d v ≠ none := by
have hfuel : 0 < G.vertices.card + 1 := by linarith [Finset.card_pos.mpr ⟨v, hv⟩]
have hinv : TimestampInvariant G.dfs :=
dfsFromList_preserves_TimestampInvariant G hfuel TimestampInvariant_init
rcases hinv with ⟨_, hd, _⟩
have hblack := G.dfs_all_black hv
have hne : (G.dfs).color v ≠ Color.white := by simp [hblack]
exact hd v hne
After dfs, every vertex has a defined finish time.
theorem dfs_f_defined {v : V} (hv : v ∈ G.vertices) :
(G.dfs).f v ≠ none := by
have hfuel : 0 < G.vertices.card + 1 := by linarith [Finset.card_pos.mpr ⟨v, hv⟩]
have hinv : TimestampInvariant G.dfs :=
dfsFromList_preserves_TimestampInvariant G hfuel TimestampInvariant_init
rcases hinv with ⟨_, _, hf⟩
exact hf v (G.dfs_all_black hv)
A DFS visit from u does not change the color of a vertex v
that is not white at the start and is not the source u.
theorem dfsVisit_preserves_not_white {fuel : Nat} {u v : V} {s : DFSState V}
(hne : v ≠ u) (hnw : s.color v ≠ Color.white) :
(dfsVisit G fuel u s).color v ≠ Color.white := by
cases hcol : s.color v with
| white => contradiction
| gray =>
have hgray := dfsVisit_preserves_gray (fuel := fuel) G hcol hne
intro h
rw [hgray] at h
contradiction
| black =>
have hblack := dfsVisit_preserves_black (fuel := fuel) (u := u) G hcol
intro h
rw [hblack] at h
contradictionThe inner fold of a DFS visit never turns a non-white, non-source vertex white.
theorem dfsVisit_fold_preserves_not_white {n : Nat} {u v : V} (s1 : DFSState V) {l : List V}
(hne : v ≠ u) (hnw : s1.color v ≠ Color.white) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).color v ≠ Color.white := by
induction l generalizing s1 with
| nil => simpa
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne' : v ≠ w := by
intro h
subst v
contradiction
have hnw' : (s1.setParent w u).color v ≠ Color.white := by
simpa using hnw
have hrec_nw := dfsVisit_preserves_not_white (fuel := n) G hne' hnw'
exact ih (dfsVisit G n w (s1.setParent w u)) hrec_nw
· simp [hw]
exact ih s1 hnw
theorem dfsVisit_preserves_f_of_not_white {fuel : Nat} {u v : V} {s : DFSState V}
(hne : v ≠ u) (hnw : s.color v ≠ Color.white) :
(dfsVisit G fuel u s).f v = s.f v := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have h_eq : (dfsVisit G (n + 1) u s).f v = s3.f v := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [h_eq]
have h1 : s1.f v = s.f v := by simp [s1]
have h2 : s2.f v = s1.f v := by
have hfold : ∀ (l : List V) (s' : DFSState V),
s'.f v = s1.f v ∧ s'.color v ≠ Color.white →
(List.foldl (fun (s'' : DFSState V) (w : V) =>
if s''.color w = Color.white then dfsVisit G n w (s''.setParent w u) else s'') s' l).f v = s1.f v := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'.1
| cons w ws ih' =>
simp
by_cases hw : s'.color w = Color.white
· simp [hw]
apply ih'
constructor
· have hsp : (s'.setParent w u).f v = s'.f v := by simp
have hnw' : (s'.setParent w u).color v ≠ Color.white := by
simpa using hs'.2
have hne' : v ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hrec : (dfsVisit G n w (s'.setParent w u)).f v = (s'.setParent w u).f v :=
ih (u := w) (s := s'.setParent w u) hne' hnw'
rw [hrec, hsp]
exact hs'.1
· have hne' : v ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hnw' : (s'.setParent w u).color v ≠ Color.white := by
simpa using hs'.2
exact dfsVisit_preserves_not_white (fuel := n) G hne' hnw'
· simp [hw]
exact ih' s' hs'
have hs1 : s1.f v = s1.f v ∧ s1.color v ≠ Color.white := by
constructor
· rfl
· simpa [s1, hne] using hnw
exact hfold (G.adj u).toList s1 hs1
have h3 : s3.f v = s2.f v := by
simp [s3, hne]
rw [h3, h2, h1]
· simp [dfsVisit, hwhite]A DFS visit never moves the global clock backwards.
theorem dfsVisit_time_ge {fuel : Nat} {u : V} {s : DFSState V} :
(dfsVisit G fuel u s).time ≥ s.time := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
have hfold : s2.time ≥ s1.time := by
have step : ∀ (s' : DFSState V) (v : V),
(if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s').time ≥ s'.time := by
intro s' v
by_cases hv : s'.color v = Color.white
· simp [hv]
have h1 := ih (u := v) (s := s'.setParent v u)
simp at h1 ⊢
linarith
· simp [hv]
have : ∀ (l : List V) (s' : DFSState V),
(List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).time ≥ s'.time := by
intro l s'
induction l generalizing s' with
| nil => simp
| cons v vs ih' =>
simp
have hstep := step s' v
have hfold := ih' (if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s')
linarith
exact this (G.adj u).toList s1
have hs1 : s1.time = s.time + 1 := by simp [s1]
have hs3 : (s2.setColor u Color.black |>.setFinish u).time = s2.time + 1 := by simp
linarith
· simp [dfsVisit, hwhite]The inner fold of a DFS visit never moves the global clock backwards.
theorem dfsVisit_fold_time_ge {n : Nat} {u : V} (s1 : DFSState V) {l : List V} :
(List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 l).time ≥ s1.time := by
induction l generalizing s1 with
| nil => simp
| cons v vs ih =>
simp
by_cases hv : s1.color v = Color.white
· simp [hv]
have h1 := G.dfsVisit_time_ge (fuel := n) (u := v) (s := s1.setParent v u)
simp at h1
linarith [ih (dfsVisit G n v (s1.setParent v u))]
· simp [hv]
exact ih s1A DFS visit's source finishes strictly before the visit returns, i.e. before the global clock after the visit.
theorem dfsVisit_source_finish_lt_time {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
finishTime (dfsVisit G fuel u s) u < (dfsVisit G fuel u s).time := by
cases fuel with
| zero => linarith
| succ n =>
simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
simp [finishTime]A DFS visit preserves the discovery time of a vertex that is not white and not its source.
theorem dfsVisit_preserves_d_of_not_white {fuel : Nat} {u v : V} {s : DFSState V}
(hne : v ≠ u) (hnw : s.color v ≠ Color.white) :
(dfsVisit G fuel u s).d v = s.d v := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have h_eq : (dfsVisit G (n + 1) u s).d v = s3.d v := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [h_eq]
have h1 : s1.d v = s.d v := by simp [s1, hne]
have h2 : s2.d v = s1.d v := by
have hfold : ∀ (l : List V) (s' : DFSState V),
s'.d v = s1.d v ∧ s'.color v ≠ Color.white →
(List.foldl (fun (s'' : DFSState V) (w : V) =>
if s''.color w = Color.white then dfsVisit G n w (s''.setParent w u) else s'') s' l).d v = s1.d v := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'.1
| cons w ws ih' =>
simp
by_cases hw : s'.color w = Color.white
· simp [hw]
apply ih'
constructor
· have hsp : (s'.setParent w u).d v = s'.d v := by simp
have hnw' : (s'.setParent w u).color v ≠ Color.white := by
simpa using hs'.2
have hne' : v ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hrec : (dfsVisit G n w (s'.setParent w u)).d v = (s'.setParent w u).d v :=
ih (u := w) (s := s'.setParent w u) hne' hnw'
rw [hrec, hsp]
exact hs'.1
· have hne' : v ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hnw' : (s'.setParent w u).color v ≠ Color.white := by
simpa using hs'.2
exact dfsVisit_preserves_not_white (fuel := n) G hne' hnw'
· simp [hw]
exact ih' s' hs'
have hs1 : s1.d v = s1.d v ∧ s1.color v ≠ Color.white := by
constructor
· rfl
· simpa [s1, hne] using hnw
exact hfold (G.adj u).toList s1 hs1
have h3 : s3.d v = s2.d v := by
simp [s3]
rw [h3, h2, h1]
· simp [dfsVisit, hwhite]The inner fold of a DFS visit preserves the discovery time of any vertex that is not white at the start of the fold.
theorem dfsVisit_fold_preserves_d_of_not_white {n : Nat} {u v : V} (s1 : DFSState V) {l : List V}
(hnw : s1.color v ≠ Color.white) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).d v = s1.d v := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : v ≠ w := by
intro h
rw [h] at hnw
simp [hw] at hnw
have hsp : (s1.setParent w u).d v = s1.d v := by simp
have hnw' : (s1.setParent w u).color v ≠ Color.white := by simpa using hnw
have hrec : (dfsVisit G n w (s1.setParent w u)).d v = (s1.setParent w u).d v :=
G.dfsVisit_preserves_d_of_not_white hne hnw'
have hfold := ih (dfsVisit G n w (s1.setParent w u))
(dfsVisit_preserves_not_white (fuel := n) G hne hnw')
rw [hfold, hrec, hsp]
· simp [hw]
exact ih s1 hnwThe inner fold of a DFS visit preserves the finish time of any vertex that is not white at the start of the fold.
theorem dfsVisit_fold_preserves_f_of_not_white {n : Nat} {u v : V} (s1 : DFSState V) {l : List V}
(hnw : s1.color v ≠ Color.white) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).f v = s1.f v := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : v ≠ w := by
intro h
rw [h] at hnw
simp [hw] at hnw
have hsp : (s1.setParent w u).f v = s1.f v := by simp
have hnw' : (s1.setParent w u).color v ≠ Color.white := by simpa using hnw
have hrec : (dfsVisit G n w (s1.setParent w u)).f v = (s1.setParent w u).f v :=
G.dfsVisit_preserves_f_of_not_white hne hnw'
have hfold := ih (dfsVisit G n w (s1.setParent w u))
(dfsVisit_preserves_not_white (fuel := n) G hne hnw')
rw [hfold, hrec, hsp]
· simp [hw]
exact ih s1 hnwThe inner fold of a DFS visit preserves the discovery time of any already-black vertex.
theorem dfsVisit_fold_preserves_d_of_black {n : Nat} {u v : V} (s1 : DFSState V) {l : List V}
(hb : s1.color v = Color.black) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).d v = s1.d v := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : v ≠ w := by
intro h
rw [h] at hb
simp [hw] at hb
have hblack' : (s1.setParent w u).color v = Color.black := by simp [hb]
have hnw : (s1.setParent w u).color v ≠ Color.white := by
rw [hblack']
decide
have hsp : (s1.setParent w u).d v = s1.d v := by simp
have hrec_d : (dfsVisit G n w (s1.setParent w u)).d v = (s1.setParent w u).d v :=
G.dfsVisit_preserves_d_of_not_white hne hnw
have hfold :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s')
(dfsVisit G n w (s1.setParent w u)) ws).d v = (dfsVisit G n w (s1.setParent w u)).d v :=
ih (dfsVisit G n w (s1.setParent w u)) (G.dfsVisit_preserves_black hblack')
rw [hfold, hrec_d, hsp]
· simp [hw]
exact ih s1 hbThe inner fold of a DFS visit preserves the finish time of any already-black vertex.
theorem dfsVisit_fold_preserves_f_of_black {n : Nat} {u v : V} (s1 : DFSState V) {l : List V}
(hb : s1.color v = Color.black) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).f v = s1.f v := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : v ≠ w := by
intro h
rw [h] at hb
simp [hw] at hb
have hblack' : (s1.setParent w u).color v = Color.black := by simp [hb]
have hrec_black : (dfsVisit G n w (s1.setParent w u)).color v = Color.black :=
G.dfsVisit_preserves_black hblack'
have hnw : (s1.setParent w u).color v ≠ Color.white := by
rw [hblack']
decide
have hsp : (s1.setParent w u).f v = s1.f v := by simp
have hrec_f : (dfsVisit G n w (s1.setParent w u)).f v = (s1.setParent w u).f v :=
G.dfsVisit_preserves_f_of_not_white hne hnw
have hfold :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s')
(dfsVisit G n w (s1.setParent w u)) ws).f v =
(dfsVisit G n w (s1.setParent w u)).f v :=
ih (dfsVisit G n w (s1.setParent w u)) hrec_black
rw [hfold, hrec_f, hsp]
· simp [hw]
exact ih s1 hbA DFS visit preserves the invariant that every parent edge points to a graph neighbor of the child.
theorem dfsVisit_preserves_parent_edge {fuel : Nat} {u : V} {s : DFSState V}
(hinv : ∀ x y, s.parent y = some x → G.Adj x y) :
∀ x y, (dfsVisit G fuel u s).parent y = some x →
G.Adj x y := by
induction fuel generalizing u s with
| zero =>
simpa [dfsVisit] using hinv
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s'
have hinv_s1 : ∀ x y, s1.parent y = some x → G.Adj x y := by
intro x y hparent
exact hinv x y (by simpa [s1] using hparent)
have hfold : ∀ (l : List V) (s' : DFSState V),
(∀ w ∈ l, G.Adj u w) →
(∀ x y, s'.parent y = some x → G.Adj x y) →
∀ x y, (List.foldl step s' l).parent y = some x → G.Adj x y := by
intro l
induction l with
| nil =>
intro s' _ hinv' x y hparent
simpa [step] using hinv' x y hparent
| cons w ws ih_ws =>
intro s' hadj hinv' x y hparent
have hw_adj : G.Adj u w := hadj w (by simp)
have hws_adj : ∀ z ∈ ws, G.Adj u z := by
intro z hz
exact hadj z (by simp [hz])
dsimp [step] at hparent
by_cases hw : s'.color w = Color.white
· rw [if_pos hw] at hparent
have hinv_parent : ∀ x y, (s'.setParent w u).parent y = some x → G.Adj x y := by
intro x y hpy
by_cases hy : y = w
· subst y
simp at hpy
cases hpy
exact hw_adj
· have h_old : s'.parent y = some x := by
simpa [hy] using hpy
exact hinv' x y h_old
exact ih_ws (dfsVisit G n w (s'.setParent w u)) hws_adj
(ih (u := w) (s := s'.setParent w u) hinv_parent) x y hparent
· rw [if_neg hw] at hparent
exact ih_ws s' hws_adj hinv' x y hparent
have h_adj_list : ∀ w ∈ (G.adj u).toList, G.Adj u w := by
intro w hw
simpa [Adj] using (Finset.mem_toList.mp hw)
exact hfold (G.adj u).toList s1 h_adj_list hinv_s1
· simpa [dfsVisit, hwhite] using hinvIn a state produced by DFS, every black vertex finished strictly before the current clock value.
theorem dfsVisit_black_finish_lt_time {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hinv : ∀ v, s.color v = Color.black → finishTime s v < s.time) :
∀ v, (dfsVisit G fuel u s).color v = Color.black →
finishTime (dfsVisit G fuel u s) v < (dfsVisit G fuel u s).time := by
induction fuel generalizing u s hinv with
| zero => linarith
| succ n ih =>
simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have htime_s3 : s3.time > s.time := by
have hs1 : s1.time = s.time + 1 := by simp [s1]
have hs2 : s2.time ≥ s1.time := G.dfsVisit_fold_time_ge s1
have hs3 : s3.time = s2.time + 1 := by simp [s3]
linarith
have hblack_s : ∀ v, s.color v = Color.black → finishTime s3 v < s3.time := by
intro v hv
have hne : v ≠ u := by
intro heq
rw [heq] at hv
simp [hwhite] at hv
have h2 : finishTime s3 v = finishTime s v := by
have h3 : s3.f v = s.f v := by
have h4 : (dfsVisit G (n + 1) u s).f v = s.f v :=
dfsVisit_preserves_f_of_not_white G hne (by simp [hv])
have h5 : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [h5] at h4
exact h4
simp [finishTime, h3]
linarith [hinv v hv, htime_s3]
have hsource : finishTime s3 u < s3.time := by
have hfu : s3.f u = some s2.time := by simp [s3]
have htime : s3.time = s2.time + 1 := by simp [s3]
simp [finishTime, hfu]
linarith [htime]
have hfold : ∀ v, s2.color v = Color.black → finishTime s2 v < s2.time := by
have fold_inv : ∀ (l : List V) (s' : DFSState V),
(∀ v, s'.color v = Color.black → finishTime s' v < s'.time) →
∀ v, (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).color v = Color.black →
finishTime (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l) v
< (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).time := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'
| cons w ws ih' =>
simp
by_cases hw : s'.color w = Color.white
· simp [hw]
let s0 := s'.setParent w u
let s_rec := dfsVisit G n w s0
have hsp : ∀ v, s0.color v = Color.black ↔ s'.color v = Color.black := by
intro v; simp [s0]
have hsp_inv : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time := by
intro v hv
have hv' : s'.color v = Color.black := by
simpa [s0] using hv
have h1 : finishTime s0 v = finishTime s' v := by
simp [finishTime, s0]
have h2 : s0.time = s'.time := by
simp [s0]
rw [h1, h2]
exact hs' v hv'
have hrec : ∀ v, s_rec.color v = Color.black → finishTime s_rec v < s_rec.time := by
intro v hv
by_cases hn0 : n = 0
· -- n = 0, the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq] at hv ⊢
exact hsp_inv v hv
· -- n > 0
apply ih (u := w) (s := s0) (by omega) (by simpa [s0] using hw) hsp_inv v hv
exact ih' s_rec hrec
· simp [hw]
exact ih' s' hs'
have h1_inv : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time := by
intro v hv
have hne : v ≠ u := by
intro heq
rw [heq] at hv
simp [s1] at hv
have h2 : finishTime s1 v = finishTime s v := by
simp [finishTime, s1]
have h3 : s1.time = s.time + 1 := by simp [s1]
have h4 : finishTime s v < s.time := hinv v (by simpa [s1, hne] using hv)
rw [h2, h3]
linarith
exact fold_inv (G.adj u).toList s1 h1_inv
intro v hv
by_cases hvu : v = u
· have h4 : s3.time = s2.time + 1 := by simp [s3]
have hthis : finishTime s3 v < s3.time := by
rw [show v = u by exact hvu]
exact hsource
linarith [hthis, h4]
· have h2 : s2.color v = Color.black := hv hvu
have h3 : finishTime s3 v = finishTime s2 v := by
simp [finishTime, s3, hvu]
have h4 : s3.time = s2.time + 1 := by simp [s3]
have h5 : finishTime s2 v < s2.time := hfold v h2
rw [h3]
linarith [h4, h5]The inner fold of a DFS visit preserves the black-vertex finish-time invariant: if the initial accumulator satisfies it, so does the final result.
theorem dfsVisit_fold_black_finish_lt_time {n : Nat} {u : V} {s1 : DFSState V} {l : List V}
(hinv : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time) :
∀ v, (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).color v = Color.black →
finishTime (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) v <
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).time := by
intros v hv
induction l generalizing s1 with
| nil =>
simpa using hinv v hv
| cons w ws ih' =>
simp at hv ⊢
by_cases hw : s1.color w = Color.white
· simp [hw] at hv ⊢
let s0 := s1.setParent w u
let s_rec := dfsVisit G n w s0
have hsp_inv : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time := by
intro v hv0
have hv1 : s1.color v = Color.black := by
simpa [s0] using hv0
have h1 : finishTime s0 v = finishTime s1 v := by
simp [finishTime, s0]
have h2 : s0.time = s1.time := by
simp [s0]
rw [h1, h2]
exact hinv v hv1
have hrec : ∀ v, s_rec.color v = Color.black → finishTime s_rec v < s_rec.time := by
intro v' hv'
by_cases hn0 : n = 0
· -- n = 0, the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq] at hv' ⊢
exact hsp_inv v' hv'
· -- n > 0
apply dfsVisit_black_finish_lt_time G (by omega) (by simpa [s0] using hw) hsp_inv v' hv'
exact ih' (s1 := s_rec) hrec hv
· simp [hw] at hv ⊢
exact ih' (s1 := s1) hinv hvAfter the neighbor-processing fold of a DFS visit (but before the source is finished), every black vertex already has a finish time strictly less than the current clock.
theorem dfsVisit_pre_finish_black_finish_lt_time {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (_hwhite : s.color u = Color.white)
(hinv : ∀ v, s.color v = Color.black → finishTime s v < s.time) :
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G (fuel - 1) v (s'.setParent v u) else s') s1 (G.adj u).toList
∀ v, s2.color v = Color.black → finishTime s2 v < s2.time := by
cases fuel with
| zero => linarith
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
have h1_inv : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time := by
intro v hv
have hne : v ≠ u := by
intro heq
rw [heq] at hv
simp [s1] at hv
have h2 : finishTime s1 v = finishTime s v := by
simp [finishTime, s1]
have h3 : s1.time = s.time + 1 := by simp [s1]
have h4 : finishTime s v < s.time := hinv v (by simpa [s1, hne] using hv)
rw [h2, h3]
linarith
have fold_inv : ∀ (l : List V) (s' : DFSState V),
(∀ v, s'.color v = Color.black → finishTime s' v < s'.time) →
∀ v, (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).color v = Color.black →
finishTime (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l) v
< (List.foldl (fun (s'' : DFSState V) (v : V) =>
if s''.color v = Color.white then dfsVisit G n v (s''.setParent v u) else s'') s' l).time := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'
| cons w ws ih' =>
simp
by_cases hw : s'.color w = Color.white
· simp [hw]
let s0 := s'.setParent w u
let s_rec := dfsVisit G n w s0
have hsp : ∀ v, s0.color v = Color.black ↔ s'.color v = Color.black := by
intro v; simp [s0]
have hsp_inv : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time := by
intro v hv
have hv' : s'.color v = Color.black := by
simpa [s0] using hv
have h1 : finishTime s0 v = finishTime s' v := by
simp [finishTime, s0]
have h2 : s0.time = s'.time := by
simp [s0]
rw [h1, h2]
exact hs' v hv'
have hrec : ∀ v, s_rec.color v = Color.black → finishTime s_rec v < s_rec.time := by
intro v hv
by_cases hn0 : n = 0
· -- n = 0, the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq] at hv ⊢
exact hsp_inv v hv
· -- n > 0
exact dfsVisit_black_finish_lt_time G (by omega) (by simpa [s0] using hw) hsp_inv v hv
exact ih' s_rec hrec
· simp [hw]
exact ih' s' hs'
exact fold_inv (G.adj u).toList s1 h1_invIn a DFS visit from a white source, every vertex that is white before the visit and black after it finishes strictly before the source.
theorem dfsVisit_finish_lt_source_finish {fuel : Nat} {u : V} {s : DFSState V} {w : V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hinv : ∀ v, s.color v = Color.black → finishTime s v < s.time)
(_hw : s.color w = Color.white)
(hb : (dfsVisit G fuel u s).color w = Color.black)
(hne : w ≠ u) :
finishTime (dfsVisit G fuel u s) w < finishTime (dfsVisit G fuel u s) u := by
cases fuel with
| zero => linarith
| succ n =>
let s_out := dfsVisit G (n + 1) u s
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hs' : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [hs'] at hb ⊢
have hw_black_s2 : s2.color w = Color.black := by
have : s3.color w = Color.black := hb
simp [s3, hne] at this
exact this
have hfold := dfsVisit_pre_finish_black_finish_lt_time G hfuel hwhite hinv
have h1 : finishTime s3 w = finishTime s2 w := by
simp [finishTime, s3, hne]
have h2 : finishTime s2 w < s2.time := hfold w hw_black_s2
have h3 : finishTime s3 u = s2.time := by
simp [finishTime, s3]
rw [h1, h3]
exact h2Recursive DFS preserves the black-vertex finish-time invariant.
theorem dfsFromList_black_finish_lt_time {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hfuel : 0 < fuel)
(hinv : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time) :
∀ v, (dfsFromList G fuel vs s0).color v = Color.black →
finishTime (dfsFromList G fuel vs s0) v < (dfsFromList G fuel vs s0).time := by
induction vs generalizing s0
· simpa [dfsFromList]
· rename_i u us ih
simp [dfsFromList]
split_ifs with hwhite
· exact ih (dfsVisit_black_finish_lt_time G hfuel hwhite hinv)
· exact ih hinv
After dfs, every vertex has a finish time strictly less than the final
clock.
theorem dfs_black_finish_lt_time {v : V} (hv : v ∈ G.vertices) :
finishTime (G.dfs) v < (G.dfs).time := by
have hfuel : 0 < G.vertices.card + 1 := by linarith [Finset.card_pos.mpr ⟨v, hv⟩]
have hblack := G.dfs_all_black hv
exact dfsFromList_black_finish_lt_time G hfuel (by
intro w hw
have h1 : dfsInit.color w = Color.white := rfl
rw [h1] at hw
nomatch hw
) v hblackFor every black vertex, discovery time is less than finish time.
def DiscoveryFinishInvariant (s : DFSState V) : Prop :=
∀ v, s.color v = Color.black → discoveryTime s v < finishTime s vA DFS visit from a white vertex preserves the discovery<finish invariant.
theorem dfsVisit_discovery_lt_finish {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hinv : DiscoveryFinishInvariant s) :
DiscoveryFinishInvariant (dfsVisit G fuel u s) := by
induction fuel generalizing u s hinv hwhite with
| zero => linarith
| succ n ih =>
simp [dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
intro v hv
by_cases hvu : v = u
· -- The source is discovered before it is finished.
rw [hvu]
have hdu : discoveryTime s3 u = s.time := by
have h1 : s3.d u = some s.time := by
have h2 : s2.d u = s1.d u := G.dfsVisit_fold_preserves_d_of_not_white s1 (by simp [s1])
have h3 : s1.d u = some s.time := by simp [s1]
simp [s3, h2, h3]
simp [discoveryTime, h1]
have hfu : finishTime s3 u = s2.time := by
simp [finishTime, s3]
have hge : s2.time ≥ s1.time := G.dfsVisit_fold_time_ge s1
have hs1 : s1.time = s.time + 1 := by simp [s1]
rw [hdu, hfu]
linarith [hge, hs1]
· -- Every other black vertex is processed inside the neighbor fold.
have hblack_s2 : s2.color v = Color.black := by
have : s3.color v = Color.black := hv
simp [s3, hvu] at this
exact this
have h1 : discoveryTime s3 v = discoveryTime s2 v := by
simp [discoveryTime, s3]
have h2 : finishTime s3 v = finishTime s2 v := by
simp [finishTime, s3, if_neg hvu]
have hinv_s1 : ∀ x, s1.color x = Color.black → discoveryTime s1 x < finishTime s1 x := by
intro x hx
have hne : x ≠ u := by
intro heq
rw [heq] at hx
simp [s1] at hx
have hd : discoveryTime s1 x = discoveryTime s x := by
simp [discoveryTime, s1, hne]
have hf : finishTime s1 x = finishTime s x := by
simp [finishTime, s1]
rw [hd, hf]
exact hinv x (by simpa [s1, hne] using hx)
have fold_inv : ∀ (l : List V) (s' : DFSState V),
(∀ x, s'.color x = Color.black → discoveryTime s' x < finishTime s' x) →
∀ x, (List.foldl step s' l).color x = Color.black →
discoveryTime (List.foldl step s' l) x < finishTime (List.foldl step s' l) x := by
intro l s' hs' x hx
induction l generalizing s' with
| nil => simpa using hs' x hx
| cons w ws ih' =>
simp [step] at hx ⊢
by_cases hw : s'.color w = Color.white
· simp [hw] at hx ⊢
let s0 := s'.setParent w u
let s_rec := dfsVisit G n w s0
have hsp_inv : ∀ x, s0.color x = Color.black → discoveryTime s0 x < finishTime s0 x := by
intro y hy
have hy1 : s'.color y = Color.black := by simpa [s0] using hy
simp [discoveryTime, finishTime, s0]
exact hs' y hy1
have hrec : ∀ x, s_rec.color x = Color.black → discoveryTime s_rec x < finishTime s_rec x := by
intro y hy
by_cases hn0 : n = 0
· have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq] at hy ⊢
exact hsp_inv y hy
· exact ih (u := w) (s := s0) (by omega) (by simpa [s0] using hw) hsp_inv y hy
exact ih' s_rec hrec hx
· simp [hw] at hx ⊢
exact ih' s' hs' hx
have hfold := fold_inv (G.adj u).toList s1 hinv_s1 v hblack_s2
rw [h1, h2]
exact hfoldRecursive DFS over a list preserves the discovery<finish invariant.
theorem dfsFromList_discovery_lt_finish {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hfuel : 0 < fuel) (hinv : DiscoveryFinishInvariant s0) :
DiscoveryFinishInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0
· simpa [dfsFromList]
· rename_i u us ih
simp [dfsFromList]
split_ifs with hwhite
· exact ih (dfsVisit_discovery_lt_finish G hfuel hwhite hinv)
· exact ih hinv
After dfs, every vertex has a discovery time strictly less than its
finish time.
theorem dfs_discovery_lt_finish {v : V} (hv : v ∈ G.vertices) :
discoveryTime (G.dfs) v < finishTime (G.dfs) v := by
have hfuel : 0 < G.vertices.card + 1 := by linarith [Finset.card_pos.mpr ⟨v, hv⟩]
have hinv : DiscoveryFinishInvariant G.dfs :=
dfsFromList_discovery_lt_finish G hfuel (by
intro w hw
have h1 : dfsInit.color w = Color.white := rfl
rw [h1] at hw
nomatch hw
)
exact hinv v (G.dfs_all_black hv)end Timestampsend BasicPropertiesNumber of white vertices of the graph in a DFS state.
-- =============================================================================
-- Cost layer: O(V + E) running time
-- =============================================================================
noncomputable def whiteCount (s : DFSState V) : Nat :=
(G.vertices.filter (fun v => s.color v = Color.white)).cardTotal out-degree of the black vertices of the graph in a DFS state; this is exactly the adjacency already scanned by DFS.
noncomputable def blackWeight (s : DFSState V) : Nat :=
∑ v ∈ G.vertices.filter (fun v => s.color v = Color.black), (G.adj v).cardGraying a white vertex removes exactly one white vertex.
lemma whiteCount_setColor_gray {u : V} {s : DFSState V} (hu : u ∈ G.vertices)
(hwhite : s.color u = Color.white) :
whiteCount G (s.setColor u Color.gray |>.setDiscovery u) + 1 = whiteCount G s := by
have hfilter : G.vertices.filter (fun v => (s.setColor u Color.gray |>.setDiscovery u).color v = Color.white)
= (G.vertices.filter (fun v => s.color v = Color.white)) \ ({u} : Finset V) := by
ext v
by_cases hvu : v = u
· subst hvu
simp [hwhite]
· simp [hvu]
rw [whiteCount, whiteCount, hfilter]
have hsub : ({u} : Finset V) ⊆ G.vertices.filter (fun v => s.color v = Color.white) := by
intro v hv
simp at hv
subst hv
simp [hu, hwhite]
rw [Finset.card_sdiff_of_subset hsub]
have hge : 1 ≤ (G.vertices.filter (fun v => s.color v = Color.white)).card := by
simpa using Finset.card_le_card hsub
simp
omegaBlackening a gray vertex adds its out-degree to the scanned weight.
lemma blackWeight_setColor_black {u : V} {s : DFSState V} (hu : u ∈ G.vertices)
(hgray : s.color u = Color.gray) :
blackWeight G (s.setColor u Color.black |>.setFinish u) = blackWeight G s + (G.adj u).card := by
have hfilter : G.vertices.filter (fun v => (s.setColor u Color.black |>.setFinish u).color v = Color.black)
= insert u (G.vertices.filter (fun v => s.color v = Color.black)) := by
ext v
by_cases hvu : v = u
· subst hvu
simp [hgray, hu]
· simp [hvu]
rw [blackWeight, blackWeight, hfilter]
have hu_notin : u ∉ G.vertices.filter (fun v => s.color v = Color.black) := by
intro h
have hblack : s.color u = Color.black := (Finset.mem_filter.mp h).2
rw [hblack] at hgray
cases hgray
rw [Finset.sum_insert hu_notin]
omega
Fuelled DFS visit that also accumulates the total work. Each visit of a
white vertex u costs one visit plus one adjacency-list scan per
out-neighbor of u.
noncomputable def dfsVisitWithCost (fuel : Nat) (u : V) (s : DFSState V) : DFSState V × Nat :=
match fuel with
| 0 => (s, 0)
| fuel + 1 =>
if s.color u = Color.white then
let s1 := s.setColor u Color.gray |>.setDiscovery u
let (s2, c2) := (G.adj u).toList.foldl
(fun (sc : DFSState V × Nat) (v : V) =>
if sc.1.color v = Color.white then
let (s', c') := dfsVisitWithCost fuel v (sc.1.setParent v u)
(s', sc.2 + c')
else sc) (s1, 0)
let s3 := s2.setColor u Color.black |>.setFinish u
(s3, 1 + (G.adj u).card + c2)
else (s, 0)Erasing the cost recovers the plain fuelled DFS visit.
theorem dfsVisitWithCost_result (fuel : Nat) (u : V) (s : DFSState V) :
(dfsVisitWithCost G fuel u s).1 = dfsVisit G fuel u s := by
induction fuel generalizing u s with
| zero => simp [dfsVisitWithCost, dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· simp [dfsVisitWithCost, dfsVisit, hwhite]
let s1 := s.setColor u Color.gray |>.setDiscovery u
have hfold : ∀ (l : List V) (a : DFSState V) (c : Nat),
(l.foldl (fun (sc : DFSState V × Nat) (v : V) =>
if sc.1.color v = Color.white then
let (s', c') := dfsVisitWithCost G n v (sc.1.setParent v u)
(s', sc.2 + c')
else sc) (a, c)).1
= l.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') a := by
intro l a c
induction l generalizing a c with
| nil => rfl
| cons v vs ih' =>
simp
by_cases hv : a.color v = Color.white
· simp [hv]
have herase := ih v (a.setParent v u)
have h' := ih' (dfsVisitWithCost G n v (a.setParent v u)).1
(c + (dfsVisitWithCost G n v (a.setParent v u)).2)
simpa [herase] using h'
· simp [hv]
exact ih' a c
simpa [s1] using congrArg (fun x => (x.setColor u Color.black).setFinish u)
(hfold (G.adj u).toList s1 0)
· simp [dfsVisitWithCost, dfsVisit, hwhite]Recursive DFS over a list of starting vertices, accumulating work.
noncomputable def dfsFromListWithCost (fuel : Nat) : List V → DFSState V → DFSState V × Nat
| [], s => (s, 0)
| u :: us, s =>
if s.color u = Color.white then
let (s', c') := dfsVisitWithCost G fuel u s
let (s'', c'') := dfsFromListWithCost fuel us s'
(s'', c' + c'')
else
dfsFromListWithCost fuel us sErasing the cost recovers the plain recursive DFS over a list.
theorem dfsFromListWithCost_result (fuel : Nat) (vs : List V) (s : DFSState V) :
(dfsFromListWithCost G fuel vs s).1 = dfsFromList G fuel vs s := by
induction vs generalizing s with
| nil => simp [dfsFromListWithCost, dfsFromList]
| cons u us ih =>
simp [dfsFromListWithCost, dfsFromList]
by_cases hwhite : s.color u = Color.white
· simp [hwhite, dfsVisitWithCost_result G fuel u s, ih]
· simp [hwhite, ih]Depth-first search over the whole graph, with a work counter.
noncomputable def dfsWithCost : DFSState V × Nat :=
dfsFromListWithCost G (G.vertices.card + 1) G.vertices.toList dfsInit
Erasing the cost recovers dfs.
theorem dfsWithCost_result : (dfsWithCost (G := G)).1 = G.dfs := by
simp [dfsWithCost, dfs, dfsFromListWithCost_result]end Graphend Chapter22end CLRSDefinitions and proofs
CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.Cost
Section 20.3 - Depth-first search cost accounting
This companion module closes the textbook O(V + E) work bound for the
costed depth-first search defined in the base Section 20.3 module. The proof
uses an exact potential balance: every newly processed vertex contributes one
unit of vertex work, and its outgoing adjacency list contributes exactly its
out-degree.
Main results:
-
Theorem
dfsWithCost_cost_eq: whole-graph DFS performs exactlyV + Echarged control steps. -
Theorem
dfsWithCost_cost_le: the textbookO(V + E)upper bound.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V]variable (G : Graph V)One costed adjacency-fold step, retaining the accumulated work counter.
private noncomputable def dfsCostFoldStep (fuel : Nat) (parent : V)
(sc : DFSState V × Nat) (v : V) : DFSState V × Nat :=
if sc.1.color v = Color.white then
let result := dfsVisitWithCost G fuel v (sc.1.setParent v parent)
(result.1, sc.2 + result.2)
else
scThe corresponding state-only adjacency-fold step.
private noncomputable def dfsPlainFoldStep (fuel : Nat) (parent : V)
(s : DFSState V) (v : V) : DFSState V :=
if s.color v = Color.white then dfsVisit G fuel v (s.setParent v parent) else sParent-pointer updates do not change the number of white graph vertices.
@[simp] private theorem whiteCount_setParent (s : DFSState V) (v parent : V) :
whiteCount G (s.setParent v parent) = whiteCount G s := by
rflParent-pointer updates do not change the scanned black-vertex weight.
@[simp] private theorem blackWeight_setParent (s : DFSState V) (v parent : V) :
blackWeight G (s.setParent v parent) = blackWeight G s := by
rflDiscovery-time updates do not change the scanned black-vertex weight.
@[simp] private theorem blackWeight_setDiscovery (s : DFSState V) (v : V) :
blackWeight G (s.setDiscovery v) = blackWeight G s := by
rflFinish-time updates do not change the number of white graph vertices.
@[simp] private theorem whiteCount_setFinish (s : DFSState V) (v : V) :
whiteCount G (s.setFinish v) = whiteCount G s := by
rflRecoloring a white vertex gray does not change the already scanned weight.
private theorem blackWeight_setColor_gray_of_white {s : DFSState V} {u : V}
(hwhite : s.color u = Color.white) :
blackWeight G (s.setColor u Color.gray) = blackWeight G s := by
unfold blackWeight
have hfilter :
G.vertices.filter (fun x => (s.setColor u Color.gray).color x = Color.black) =
G.vertices.filter (fun x => s.color x = Color.black) := by
ext x
by_cases hxu : x = u
· subst x
simp [hwhite]
· simp [hxu]
rw [hfilter]Recoloring a nonwhite vertex black does not change the number of white graph vertices.
private theorem whiteCount_setColor_black_of_not_white {s : DFSState V} {u : V}
(hnotwhite : s.color u ≠ Color.white) :
whiteCount G (s.setColor u Color.black) = whiteCount G s := by
unfold whiteCount
have hfilter :
G.vertices.filter (fun x => (s.setColor u Color.black).color x = Color.white) =
G.vertices.filter (fun x => s.color x = Color.white) := by
ext x
by_cases hxu : x = u
· subst x
simp [hnotwhite]
· simp [hxu]
rw [hfilter]Erasing a single costed fold step recovers the state-only DFS step.
private theorem dfsCostFoldStep_state (fuel : Nat) (parent : V)
(sc : DFSState V × Nat) (v : V) :
(dfsCostFoldStep G fuel parent sc v).1 =
dfsPlainFoldStep G fuel parent sc.1 v := by
by_cases hwhite : sc.1.color v = Color.white
· simp [dfsCostFoldStep, dfsPlainFoldStep, hwhite, dfsVisitWithCost_result]
· simp [dfsCostFoldStep, dfsPlainFoldStep, hwhite]Erasing an entire costed adjacency fold recovers the plain adjacency fold.
private theorem dfsCostFold_state (fuel : Nat) (parent : V)
(vertices : List V) (sc : DFSState V × Nat) :
(vertices.foldl (dfsCostFoldStep G fuel parent) sc).1 =
vertices.foldl (dfsPlainFoldStep G fuel parent) sc.1 := by
induction vertices generalizing sc with
| nil => rfl
| cons v rest ih =>
simp only [List.foldl]
rw [ih, dfsCostFoldStep_state]A completed costed DFS visit satisfies the exact white/black work balance.
theorem dfsVisitWithCost_balance {fuel : Nat} {u : V} {s : DFSState V}
(hu : u ∈ G.vertices) :
let result := dfsVisitWithCost G fuel u s
result.2 + whiteCount G result.1 + blackWeight G s =
whiteCount G s + blackWeight G result.1 := by
induction fuel generalizing u s with
| zero => simp [dfsVisitWithCost]
| succ n visitIH =>
by_cases hwhite : s.color u = Color.white
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let folded := (G.adj u).toList.foldl (dfsCostFoldStep G n u) (s1, 0)
let s2 := folded.1
let cost2 := folded.2
have hfold : ∀ (vertices : List V) (sc : DFSState V × Nat),
(∀ v ∈ vertices, v ∈ G.vertices) →
let result := vertices.foldl (dfsCostFoldStep G n u) sc
result.2 + whiteCount G result.1 + blackWeight G sc.1 =
sc.2 + whiteCount G sc.1 + blackWeight G result.1 := by
intro vertices
induction vertices with
| nil =>
intro sc _
simp
| cons v rest restIH =>
intro sc hvertices
have hv : v ∈ G.vertices := hvertices v (by simp)
have hrest : ∀ w ∈ rest, w ∈ G.vertices := by
intro w hw
exact hvertices w (by simp [hw])
simp only [List.foldl]
by_cases hvwhite : sc.1.color v = Color.white
· let visitResult := dfsVisitWithCost G n v (sc.1.setParent v u)
have hstep : dfsCostFoldStep G n u sc v =
(visitResult.1, sc.2 + visitResult.2) := by
simp [dfsCostFoldStep, hvwhite, visitResult]
rw [hstep]
have hvisit := visitIH (u := v) (s := sc.1.setParent v u) hv
have htail := restIH (visitResult.1, sc.2 + visitResult.2) hrest
have hvisit' :
visitResult.2 + whiteCount G visitResult.1 + blackWeight G sc.1 =
whiteCount G sc.1 + blackWeight G visitResult.1 := by
simpa [visitResult] using hvisit
simp only at htail
omega
· have hstep : dfsCostFoldStep G n u sc v = sc := by
simp [dfsCostFoldStep, hvwhite]
rw [hstep]
exact restIH sc hrest
have hadj : ∀ v ∈ (G.adj u).toList, v ∈ G.vertices := by
intro v hv
exact G.adj_mem_right (by simpa [Adj] using (Finset.mem_toList.mp hv))
have hfoldMain :
cost2 + whiteCount G s2 + blackWeight G s1 =
whiteCount G s1 + blackWeight G s2 := by
simpa [folded, s2, cost2] using hfold (G.adj u).toList (s1, 0) hadj
have hplainGray :
((G.adj u).toList.foldl (dfsPlainFoldStep G n u) s1).color u =
Color.gray := by
change
((G.adj u).toList.foldl
(fun s' v =>
if s'.color v = Color.white then
dfsVisit G n v (s'.setParent v u)
else s') s1).color u = Color.gray
simpa [s1] using
(dfsVisit_u_stays_gray (G := G) (fuel := n + 1) (u := u) (s := s)
(by omega) hwhite)
have hcostState : s2 =
(G.adj u).toList.foldl (dfsPlainFoldStep G n u) s1 := by
simpa [folded, s2] using
(dfsCostFold_state G n u (G.adj u).toList (s1, 0))
have hgray : s2.color u = Color.gray := by
rw [hcostState]
exact hplainGray
have hwhiteStart : whiteCount G s1 + 1 = whiteCount G s := by
simpa [s1] using whiteCount_setColor_gray G hu hwhite
have hblackStart : blackWeight G s1 = blackWeight G s := by
simpa [s1] using blackWeight_setColor_gray_of_white G hwhite
have hwhiteFinish :
whiteCount G (s2.setColor u Color.black |>.setFinish u) =
whiteCount G s2 := by
simpa using whiteCount_setColor_black_of_not_white G (by
rw [hgray]
decide)
have hblackFinish :
blackWeight G (s2.setColor u Color.black |>.setFinish u) =
blackWeight G s2 + (G.adj u).card := by
exact blackWeight_setColor_black G hu hgray
have hresult : dfsVisitWithCost G (n + 1) u s =
(s2.setColor u Color.black |>.setFinish u,
1 + (G.adj u).card + cost2) := by
have hstep :
(fun (sc : DFSState V × Nat) (v : V) =>
if sc.1.color v = Color.white then
let result := dfsVisitWithCost G n v (sc.1.setParent v u)
(result.1, sc.2 + result.2)
else sc) = dfsCostFoldStep G n u := by
funext sc v
rfl
simp only [dfsVisitWithCost, hwhite, if_pos]
rw [hstep]
rw [hresult]
change
(1 + (G.adj u).card + cost2) +
whiteCount G (s2.setColor u Color.black |>.setFinish u) +
blackWeight G s =
whiteCount G s +
blackWeight G (s2.setColor u Color.black |>.setFinish u)
omega
· simp [dfsVisitWithCost, hwhite]A costed DFS traversal over graph vertices satisfies the same exact work balance as one visit.
theorem dfsFromListWithCost_balance {fuel : Nat} {vertices : List V}
{s : DFSState V} (hvertices : ∀ v ∈ vertices, v ∈ G.vertices) :
let result := dfsFromListWithCost G fuel vertices s
result.2 + whiteCount G result.1 + blackWeight G s =
whiteCount G s + blackWeight G result.1 := by
induction vertices generalizing s with
| nil => simp [dfsFromListWithCost]
| cons u rest restIH =>
have hu : u ∈ G.vertices := hvertices u (by simp)
have hrest : ∀ v ∈ rest, v ∈ G.vertices := by
intro v hv
exact hvertices v (by simp [hv])
by_cases hwhite : s.color u = Color.white
· let visitResult := dfsVisitWithCost G fuel u s
let restResult := dfsFromListWithCost G fuel rest visitResult.1
have hvisit := dfsVisitWithCost_balance G (fuel := fuel) (u := u) (s := s) hu
have htail := restIH (s := visitResult.1) hrest
have hresult : dfsFromListWithCost G fuel (u :: rest) s =
(restResult.1, visitResult.2 + restResult.2) := by
simp [dfsFromListWithCost, hwhite, visitResult, restResult]
rw [hresult]
change
visitResult.2 + restResult.2 + whiteCount G restResult.1 +
blackWeight G s =
whiteCount G s + blackWeight G restResult.1
have hvisit' :
visitResult.2 + whiteCount G visitResult.1 + blackWeight G s =
whiteCount G s + blackWeight G visitResult.1 := by
simpa [visitResult] using hvisit
have htail' :
restResult.2 + whiteCount G restResult.1 + blackWeight G visitResult.1 =
whiteCount G visitResult.1 + blackWeight G restResult.1 := by
simpa [restResult] using htail
omega
· simpa [dfsFromListWithCost, hwhite] using restIH (s := s) hrestThe initial DFS state has one white vertex for every graph vertex.
private theorem whiteCount_dfsInit : whiteCount G (dfsInit : DFSState V) = G.vertices.card := by
simp [whiteCount, dfsInit]The initial DFS state has scanned no outgoing adjacency list.
private theorem blackWeight_dfsInit : blackWeight G (dfsInit : DFSState V) = 0 := by
simp [blackWeight, dfsInit]A whole-graph DFS result has no remaining white graph vertex.
private theorem whiteCount_dfsWithCost : whiteCount G (dfsWithCost (G := G)).1 = 0 := by
rw [dfsWithCost_result]
simp only [whiteCount, Finset.card_eq_zero]
ext v
simp only [Finset.mem_filter]
constructor
· rintro ⟨hv, hwhite⟩
rw [G.dfs_all_black hv] at hwhite
cases hwhite
· simpA whole-graph DFS result has scanned every outgoing adjacency list.
private theorem blackWeight_dfsWithCost :
blackWeight G (dfsWithCost (G := G)).1 = edgeCount G := by
rw [dfsWithCost_result]
simp only [blackWeight, edgeCount]
congr 1
ext v
simp only [Finset.mem_filter]
constructor
· exact And.left
· intro hv
exact ⟨hv, G.dfs_all_black hv⟩Exact DFS work. The costed whole-graph traversal charges one unit per vertex and one unit per directed edge.
theorem dfsWithCost_cost_eq :
(dfsWithCost (G := G)).2 = G.vertices.card + edgeCount G := by
have hvertices : ∀ v ∈ G.vertices.toList, v ∈ G.vertices := by
intro v hv
exact Finset.mem_toList.mp hv
have hbalance := dfsFromListWithCost_balance G
(fuel := G.vertices.card + 1) (vertices := G.vertices.toList)
(s := dfsInit) hvertices
change (dfsWithCost (G := G)).2 + whiteCount G (dfsWithCost (G := G)).1 +
blackWeight G dfsInit =
whiteCount G dfsInit + blackWeight G (dfsWithCost (G := G)).1 at hbalance
rw [whiteCount_dfsWithCost, blackWeight_dfsInit, whiteCount_dfsInit,
blackWeight_dfsWithCost] at hbalance
omega
DFS running time. The instrumented depth-first search costs at most
V + E control steps, and hence runs in O(V + E) in the selected
model.
theorem dfsWithCost_cost_le :
(dfsWithCost (G := G)).2 ≤ G.vertices.card + edgeCount G := by
exact (dfsWithCost_cost_eq G).leend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S1_WhitePath
DFS theory: white-path reachability and the white-path theorem
This file collects the DFS-theoretic consequences of the functional DFS model
that are needed for Section 20.5 (Kosaraju's SCC algorithm). The main result
is the white-path theorem for a single dfsVisit: starting from a white
vertex, the visit blackens exactly the vertices reachable through white vertices.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V] (G : Graph V)section ReachabilityReachability through white vertices
WhiteReachable s u v holds when v can be reached from
u by a path whose every step lands on a vertex that is white in s.
The source u itself need not be white; this is handled separately in the
theorems.
def WhiteReachable (s : DFSState V) (u v : V) : Prop :=
Relation.ReflTransGen (fun x y => G.Adj x y ∧ s.color y = Color.white) u vtheorem whiteReachable_refl (s : DFSState V) (u : V) : WhiteReachable G s u u :=
Relation.ReflTransGen.refltheorem whiteReachable_trans {s : DFSState V} {u v w : V}
(huv : WhiteReachable G s u v) (hvw : WhiteReachable G s v w) :
WhiteReachable G s u w :=
Relation.ReflTransGen.trans huv hvwtheorem whiteReachable_step {s : DFSState V} {u v w : V}
(huv : WhiteReachable G s u v) (hadj : G.Adj v w) (hw : s.color w = Color.white) :
WhiteReachable G s u w :=
Relation.ReflTransGen.tail huv ⟨hadj, hw⟩Every vertex on a white path (except possibly the source) is white.
theorem whiteReachable_target_white {u v : V} {s : DFSState V}
(hwhite : s.color u = Color.white) (hr : WhiteReachable G s u v) :
s.color v = Color.white := by
induction hr with
| refl => exact hwhite
| tail _ hstep _ => exact hstep.2White-reachable set as a finite iteration
We compute the set of white-reachable vertices by iterating a monotone operator.
Because the graph is finite, this iteration stabilises within |V| steps,
giving a finite characterisation of WhiteReachable that supports
induction on the size of the reachable set.
One step of the white-reachability operator.
def whiteReachableSucc (s : DFSState V) (U : Finset V) : Finset V :=
Finset.filter (fun v => s.color v = Color.white) (U.biUnion (fun w => G.adj w))
Iterated white reachability from u.
def whiteReachableIter (s : DFSState V) (u : V) : Nat → Finset V
| 0 => {u}
| n + 1 => whiteReachableIter s u n ∪ whiteReachableSucc G s (whiteReachableIter s u n)
The white-reachable set is the iteration stabilised at |V|.
noncomputable def whiteReachableSet (s : DFSState V) (u : V) : Finset V :=
whiteReachableIter G s u (G.vertices.card)theorem whiteReachableIter_subset_vertices (s : DFSState V) (u : V) (hu : u ∈ G.vertices)
(n : Nat) : whiteReachableIter G s u n ⊆ G.vertices := by
induction n with
| zero => simp [whiteReachableIter, hu]
| succ n ih =>
intro v hv
simp [whiteReachableIter, whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion] at hv
rcases hv with (h | ⟨⟨w, hw, hadj⟩, hwhite⟩)
· exact ih h
· exact G.adj_mem_right hadjtheorem whiteReachableSet_subset_vertices (s : DFSState V) (u : V) (hu : u ∈ G.vertices) :
whiteReachableSet G s u ⊆ G.vertices :=
whiteReachableIter_subset_vertices G s u hu (G.vertices.card)theorem whiteReachableIter_mono (s : DFSState V) (u : V) (n : Nat) :
whiteReachableIter G s u n ⊆ whiteReachableIter G s u (n + 1) := by
simp [whiteReachableIter]theorem whiteReachableIter_mono_le (s : DFSState V) (u : V) {n m : Nat} (h : n ≤ m) :
whiteReachableIter G s u n ⊆ whiteReachableIter G s u m := by
induction h with
| refl => rfl
| step h ih => exact ih.trans (whiteReachableIter_mono G s u _)
theorem whiteReachableIter_eventually_stable (s : DFSState V) (u : V) (hu : u ∈ G.vertices) :
∃ k ≤ G.vertices.card, whiteReachableIter G s u k = whiteReachableIter G s u (k + 1) := by
by_contra h
push Not at h
have hcard_pos : 1 ≤ G.vertices.card := Finset.one_le_card.mpr ⟨u, hu⟩
have hmono := whiteReachableIter_mono G s u
have h_strict : ∀ k ≤ G.vertices.card, whiteReachableIter G s u k ⊂ whiteReachableIter G s u (k + 1) := by
intro k hk
refine Finset.ssubset_iff_subset_ne.mpr ⟨hmono k, ?_⟩
intro heq
exact h k hk heq
have h_card : ∀ k ≤ G.vertices.card + 1,
(whiteReachableIter G s u k).card ≥ k + 1 := by
intro k hk
induction k with
| zero =>
simp [whiteReachableIter]
| succ k ih =>
have hk' : k ≤ G.vertices.card := by omega
have hlt := Finset.card_lt_card (h_strict k hk')
have hle := ih (by omega)
omega
have h_ub := Finset.card_le_card (whiteReachableIter_subset_vertices G s u hu (G.vertices.card + 1))
have h_mono_card := Finset.card_le_card (hmono (G.vertices.card))
have h_lb := h_card (G.vertices.card) (by omega)
simp at h_ub h_mono_card h_lb
omega
theorem whiteReachableIter_stable_at (s : DFSState V) (u : V) {k : Nat}
(heq : whiteReachableIter G s u k = whiteReachableIter G s u (k + 1)) (m : Nat) :
whiteReachableIter G s u k = whiteReachableIter G s u (k + m) := by
have hsucc : whiteReachableSucc G s (whiteReachableIter G s u k) ⊆ whiteReachableIter G s u k := by
have h := heq
simp [whiteReachableIter] at h
exact h
induction m with
| zero => simp
| succ m ih =>
calc
whiteReachableIter G s u k = whiteReachableIter G s u (k + m) := ih
_ = whiteReachableIter G s u (k + m + 1) := by
have h1 : whiteReachableIter G s u (k + m + 1)
= whiteReachableIter G s u (k + m) ∪ whiteReachableSucc G s (whiteReachableIter G s u (k + m)) := rfl
rw [h1, ← ih]
rw [Finset.union_eq_left.2 hsucc]
theorem whiteReachableIter_stable (s : DFSState V) (u : V) (hu : u ∈ G.vertices) :
whiteReachableSet G s u = whiteReachableIter G s u (G.vertices.card + 1) := by
rcases whiteReachableIter_eventually_stable G s u hu with ⟨k, hk, heq⟩
have h1 : whiteReachableSet G s u = whiteReachableIter G s u k := by
dsimp [whiteReachableSet]
have heq1 := whiteReachableIter_stable_at G s u heq (G.vertices.card - k)
have : k + (G.vertices.card - k) = G.vertices.card := by omega
rw [this] at heq1
exact heq1.symm
have h2 : whiteReachableIter G s u k = whiteReachableIter G s u (G.vertices.card + 1) := by
have heq2 := whiteReachableIter_stable_at G s u heq (G.vertices.card + 1 - k)
have : k + (G.vertices.card + 1 - k) = G.vertices.card + 1 := by omega
rw [this] at heq2
exact heq2
rw [h1, h2]theorem whiteReachableIter_to_WhiteReachable {s : DFSState V} {u v : V} {n : Nat}
(hv : v ∈ whiteReachableIter G s u n) : WhiteReachable G s u v := by
induction n generalizing v with
| zero =>
simp [whiteReachableIter, Finset.mem_singleton] at hv
subst v
exact whiteReachable_refl G s u
| succ n ih =>
simp [whiteReachableIter, whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion] at hv
rcases hv with (h | ⟨⟨w, hw, hadj⟩, hwhite⟩)
· exact ih h
· exact whiteReachable_step G (ih hw) hadj hwhitetheorem WhiteReachable.mem_iter {s : DFSState V} {u v : V}
(hr : WhiteReachable G s u v) : ∃ n, v ∈ whiteReachableIter G s u n := by
induction hr with
| refl => use 0; simp [whiteReachableIter]
| @tail w v' hwr hadj ih =>
rcases ih with ⟨n, hn⟩
use n + 1
simp [whiteReachableIter, whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion]
refine Or.inr ⟨⟨w, hn, hadj.1⟩, hadj.2⟩
theorem WhiteReachable.mem_set {s : DFSState V} {u v : V} (hu : u ∈ G.vertices)
(hr : WhiteReachable G s u v) : v ∈ whiteReachableSet G s u := by
rcases hr.mem_iter G with ⟨n, hn⟩
have hstable := whiteReachableIter_stable G s u hu
rw [hstable]
by_cases h : n ≤ G.vertices.card + 1
· exact whiteReachableIter_mono_le G s u h hn
· have : n ≥ G.vertices.card + 2 := by omega
rcases whiteReachableIter_eventually_stable G s u hu with ⟨k, hk, heq⟩
have h1 := whiteReachableIter_stable_at G s u heq (n - k)
have h2 := whiteReachableIter_stable_at G s u heq (G.vertices.card + 1 - k)
have hkn : k + (n - k) = n := by omega
have hkcard : k + (G.vertices.card + 1 - k) = G.vertices.card + 1 := by omega
rw [hkn] at h1
rw [hkcard] at h2
rw [← h1, h2] at hn
exact hntheorem mem_whiteReachableSet_iff {s : DFSState V} {u v : V} (hu : u ∈ G.vertices) :
v ∈ whiteReachableSet G s u ↔ WhiteReachable G s u v := by
constructor
· intro hv
exact whiteReachableIter_to_WhiteReachable G hv
· intro hr
exact WhiteReachable.mem_set G hu hrEvery vertex belongs to its own white-reachable set.
theorem mem_whiteReachableSet_self (s : DFSState V) (u : V) : u ∈ whiteReachableSet G s u := by
have h0 : u ∈ whiteReachableIter G s u 0 := by simp [whiteReachableIter]
exact whiteReachableIter_mono_le G s u (by linarith) h0
Iteration-level decomposition: a vertex different from u that
appears in iter (n+1) can be reached from a white neighbour of u
within n iterations of the gray state.
theorem mem_whiteReachableIter_self (s : DFSState V) (u : V) (n : Nat) :
u ∈ whiteReachableIter G s u n := by
induction n with
| zero => simp [whiteReachableIter]
| succ n ih => simp [whiteReachableIter, ih]theorem mem_whiteReachableIter_succ_of_mem {s : DFSState V} {u v : V} {n : Nat}
(h : v ∈ whiteReachableIter G s u n) :
v ∈ whiteReachableIter G s u (n + 1) :=
whiteReachableIter_mono G s u n h
theorem whiteReachableIter_decomp {s : DFSState V} {u v : V} (hu : u ∈ G.vertices)
(n : Nat) (hv : v ∈ whiteReachableIter G s u (n + 1)) (hne : v ≠ u) :
∃ x, G.Adj u x ∧ s.color x = Color.white ∧
v ∈ whiteReachableIter G (s.setColor u Color.gray) x n := by
induction n generalizing v with
| zero =>
have h_eq : whiteReachableIter G s u (0 + 1) = {u} ∪ whiteReachableSucc G s {u} := rfl
rw [h_eq] at hv
simp [whiteReachableSucc, Finset.mem_filter] at hv
rcases hv with (rfl | h)
· contradiction
· use v
constructor
· exact h.1
constructor
· exact h.2
· exact mem_whiteReachableIter_self G (s.setColor u Color.gray) v 0
| succ n ih =>
have h_eq : whiteReachableIter G s u ((n + 1) + 1)
= whiteReachableIter G s u (n + 1) ∪ whiteReachableSucc G s (whiteReachableIter G s u (n + 1)) := rfl
rw [h_eq] at hv
simp [whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion] at hv
rcases hv with (h | ⟨⟨w, hw, hadj_wv⟩, hwhite_v⟩)
· rcases ih h hne with ⟨x, hadj, hwhite, hvx⟩
use x, hadj, hwhite
exact mem_whiteReachableIter_succ_of_mem G hvx
· by_cases hwu : w = u
· subst w
use v
constructor
· exact hadj_wv
constructor
· exact hwhite_v
· exact mem_whiteReachableIter_self G (s.setColor u Color.gray) v (n + 1)
· rcases ih hw (by simpa using hwu) with ⟨x, hadj_ux, hwhite_x, hvx⟩
use x
constructor
· exact hadj_ux
constructor
· exact hwhite_x
· have hwhite_v_gray : (s.setColor u Color.gray).color v = Color.white := by
simp [hwhite_v]
exact hne
simp [whiteReachableIter, whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion]
refine Or.inr ⟨⟨w, hvx, hadj_wv⟩, hwhite_v_gray⟩
If v lies in the white-reachable set and v ≠ u, then
v can be reached from a white neighbour x of u without
using u.
theorem whiteReachableSet_decomp {s : DFSState V} {u v : V} (hu : u ∈ G.vertices)
(_hwhite : s.color u = Color.white) (hv : v ∈ whiteReachableSet G s u) (hne : v ≠ u) :
∃ x, G.Adj u x ∧ s.color x = Color.white ∧
v ∈ whiteReachableSet G (s.setColor u Color.gray) x := by
have hstable := whiteReachableIter_stable G s u hu
have : v ∈ whiteReachableIter G s u (G.vertices.card + 1) := by
rw [← hstable]
exact hv
rcases whiteReachableIter_decomp G hu (G.vertices.card) this hne with ⟨x, hadj, hwhite_x, hvx⟩
use x, hadj, hwhite_x
have hstable_x := whiteReachableIter_stable G (s.setColor u Color.gray) x (G.adj_mem_right hadj)
rw [hstable_x]
exact mem_whiteReachableIter_succ_of_mem G hvxExtract the first step of a non-trivial white path.
theorem WhiteReachable.exists_first_step {s : DFSState V} {u v : V}
(hr : WhiteReachable G s u v) (hne : v ≠ u) :
∃ x, G.Adj u x ∧ s.color x = Color.white ∧ WhiteReachable G s x v := by
induction hr with
| refl => contradiction
| @tail a b hab hbc ih =>
by_cases hau : a = u
· subst a
use b
exact ⟨hbc.1, hbc.2, whiteReachable_refl G s b⟩
· rcases ih hau with ⟨x, hx1, hx2, hx3⟩
use x, hx1, hx2
exact whiteReachable_step G hx3 hbc.1 hbc.2
Variant of whiteReachableSet_decomp that guarantees the chosen
neighbour is different from u.
theorem whiteReachableSet_decomp_ne {s : DFSState V} {u v : V} (hu : u ∈ G.vertices)
(hwhite : s.color u = Color.white) (hv : v ∈ whiteReachableSet G s u) (hne : v ≠ u) :
∃ x, G.Adj u x ∧ s.color x = Color.white ∧ x ≠ u ∧
v ∈ whiteReachableSet G (s.setColor u Color.gray) x := by
rcases whiteReachableSet_decomp G hu hwhite hv hne with ⟨x, hadj, hwhite_x, hvx⟩
by_cases hxne : x = u
· subst x
have hr' := whiteReachableIter_to_WhiteReachable G hvx
rcases WhiteReachable.exists_first_step G hr' hne with ⟨z, hadj_z, hwhite_z_gray, hr_zv⟩
have hzne : z ≠ u := by
intro hzu
subst z
have : (s.setColor u Color.gray).color u = Color.white := hwhite_z_gray
simp at this
have hwhite_z : s.color z = Color.white := by
simp [hzne] at hwhite_z_gray
exact hwhite_z_gray
use z
constructor
· exact hadj_z
constructor
· exact hwhite_z
constructor
· exact hzne
· exact WhiteReachable.mem_set G (G.adj_mem_right hadj_z) hr_zv
· use x, hadj, hwhite_x, hxne, hvx
theorem whiteReachable_gray_to_white {s : DFSState V} {u x v : V}
(_hwhite : s.color u = Color.white)
(hr : WhiteReachable G (s.setColor u Color.gray) x v) :
WhiteReachable G s x v := by
induction hr with
| refl => exact whiteReachable_refl G s x
| @tail y z hwy hadj' ih =>
have hwhite_z : s.color z = Color.white := by
have : (s.setColor u Color.gray).color z = Color.white := hadj'.2
simp at this
by_cases h : z = u
· subst z
simp at this
· simpa [h] using this
exact whiteReachable_step G ih hadj'.1 hwhite_z
If every white vertex of s' is also white in s, then a white
path in s' is also a white path in s.
theorem whiteReachable_mono_of_color_superset {s s' : DFSState V} {u v : V}
(h : ∀ z, s'.color z = Color.white → s.color z = Color.white) :
WhiteReachable G s' u v → WhiteReachable G s u v := by
intro hr
induction hr with
| refl => exact whiteReachable_refl G s u
| @tail x y _ hstep ih =>
have hwhite_y : s.color y = Color.white := h y hstep.2
exact whiteReachable_step G ih hstep.1 hwhite_yIf two states agree on colors, white reachability is equivalent.
theorem WhiteReachable.color_eq {s s' : DFSState V} {u v : V}
(h : ∀ z, s.color z = s'.color z) :
WhiteReachable G s u v ↔ WhiteReachable G s' u v := by
constructor
· apply whiteReachable_mono_of_color_superset
intro z hz
rw [← h z]
exact hz
· apply whiteReachable_mono_of_color_superset
intro z hz
rw [h z]
exact hzMonotonicity of the white-reachable set with respect to the set of white vertices.
theorem whiteReachableSet_mono_of_color_superset {s s' : DFSState V} {u : V} (hu : u ∈ G.vertices)
(h : ∀ z, s'.color z = Color.white → s.color z = Color.white) :
whiteReachableSet G s' u ⊆ whiteReachableSet G s u := by
intro v hv
have hr := whiteReachableIter_to_WhiteReachable G hv
exact WhiteReachable.mem_set G hu (whiteReachable_mono_of_color_superset G h hr)If two states agree on colors, their white-reachable sets are equal.
theorem whiteReachableSet_eq_of_color_eq {s s' : DFSState V} {u : V} (hu : u ∈ G.vertices)
(h : ∀ z, s.color z = s'.color z) :
whiteReachableSet G s u = whiteReachableSet G s' u := by
apply Finset.Subset.antisymm
· apply whiteReachableSet_mono_of_color_superset G hu
intro z hz
rw [← h z]
exact hz
· apply whiteReachableSet_mono_of_color_superset G hu
intro z hz
rw [h z]
exact hzSubset relationship induced by a white path.
theorem whiteReachableSet_subset_of_WhiteReachable {s : DFSState V} {u v : V} (hu : u ∈ G.vertices)
(hr : WhiteReachable G s u v) :
whiteReachableSet G s v ⊆ whiteReachableSet G s u := by
intro x hx
have hr2 := whiteReachableIter_to_WhiteReachable G hx
exact WhiteReachable.mem_set G hu (whiteReachable_trans G hr hr2)
theorem whiteReachableSet_neighbor_ssubset {s : DFSState V} {u x : V} (hu : u ∈ G.vertices)
(hwhite : s.color u = Color.white) (hadj : G.Adj u x) (hx : s.color x = Color.white)
(hxne : x ≠ u) :
whiteReachableSet G (s.setColor u Color.gray) x ⊂ whiteReachableSet G s u := by
have hsub : whiteReachableSet G (s.setColor u Color.gray) x ⊆ whiteReachableSet G s u := by
intro v hv
have hr := whiteReachableIter_to_WhiteReachable G hv
have hr' : WhiteReachable G s u v := by
have h1 : G.Adj u x := hadj
have h2 := whiteReachable_gray_to_white G hwhite hr
exact whiteReachable_step G (whiteReachable_refl G s u) h1 hx |>.trans h2
exact WhiteReachable.mem_set G hu hr'
have hne : u ∉ whiteReachableSet G (s.setColor u Color.gray) x := by
intro h
have hr := whiteReachableIter_to_WhiteReachable G h
have hwhite_x : (s.setColor u Color.gray).color x = Color.white := by
simp [hx, hxne]
have hwhite_u : (s.setColor u Color.gray).color u = Color.white :=
whiteReachable_target_white (G := G) hwhite_x hr
simp at hwhite_u
have hmem : u ∈ whiteReachableSet G s u := by
rw [mem_whiteReachableSet_iff G hu]
exact whiteReachable_refl G s u
exact Finset.ssubset_iff_subset_ne.mpr ⟨hsub, fun heq => hne (heq ▸ hmem)⟩end ReachabilityConverse of the white-path theorem
If a dfsVisit call turns a vertex black, that vertex was either black
already or reachable through white vertices from the source.
dfsVisit never turns a non-white vertex into a white one.
theorem dfsVisit_does_not_create_white {fuel : Nat} {u x : V} {s : DFSState V}
(hnw : s.color x ≠ Color.white) :
(dfsVisit G fuel u s).color x ≠ Color.white := by
induction fuel generalizing u s with
| zero =>
intro h
simp [dfsVisit] at h
contradiction
| succ n ih =>
by_cases hwhite_u : s.color u = Color.white
· -- u is white, so the visit expands
by_cases hxu : x = u
· -- x = u: final color is black
have : (dfsVisit G (n+1) u s).color x = Color.black := by
rw [hxu]
simp [dfsVisit, hwhite_u]
rw [this]
intro h
contradiction
· -- x ≠ u: the color comes from the fold over the adjacency list
have h2 : (dfsVisit G (n+1) u s).color x = (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s')
(s.setColor u Color.gray |>.setDiscovery u) (G.adj u).toList).color x := by
simp [dfsVisit, hwhite_u, hxu]
rw [h2]
let step := fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s'
have hnw' : (s.setColor u Color.gray |>.setDiscovery u).color x ≠ Color.white := by
simp [hxu]
exact hnw
have hfold : ∀ (s1 : DFSState V), s1.color x ≠ Color.white →
(List.foldl step s1 (G.adj u).toList).color x ≠ Color.white := by
intro s1 hs1x
induction (G.adj u).toList generalizing s1 with
| nil =>
simpa using hs1x
| cons w ws ih' =>
rw [List.foldl_cons]
by_cases hw : s1.color w = Color.white
· have hstep : step s1 w = dfsVisit G n w (s1.setParent w u) := by
simp [step, hw]
rw [hstep]
apply ih'
have hsp : (s1.setParent w u).color x = s1.color x := by simp
have hsp_nw : (s1.setParent w u).color x ≠ Color.white := by
intro h
apply hs1x
rwa [hsp] at h
exact ih (u := w) (s := s1.setParent w u) hsp_nw
· have hstep : step s1 w = s1 := by
simp [step, hw]
rw [hstep]
exact ih' s1 hs1x
exact hfold (s.setColor u Color.gray |>.setDiscovery u) hnw'
· -- u is not white, the state is unchanged
have h2 : (dfsVisit G (n+1) u s).color x = s.color x := by
simp [dfsVisit, hwhite_u]
rw [h2]
exact hnw
If dfsVisit leaves a vertex white, it was white before the call.
theorem dfsVisit_output_white_imp_input_white {fuel : Nat} {u x : V} {s : DFSState V}
(hout : (dfsVisit G fuel u s).color x = Color.white) :
s.color x = Color.white := by
by_contra h
push Not at h
have := dfsVisit_does_not_create_white (G := G) (fuel := fuel) (u := u) (x := x) (s := s) h
contradictionIf a fold over adjacency lists leaves a vertex white, it was white before the fold.
theorem dfsVisit_fold_output_white_imp_input_white {n : Nat} {u x : V} {s1 : DFSState V} {l : List V}
(hout : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).color x = Color.white) :
s1.color x = Color.white := by
induction l generalizing s1 with
| nil =>
simpa using hout
| cons w ws ih =>
rw [List.foldl_cons] at hout
by_cases hw : s1.color w = Color.white
· rw [if_pos hw] at hout
have h2 := ih hout
have h4 : (s1.setParent w u).color x = s1.color x := by simp
have h5 : (s1.setParent w u).color x = Color.white := by
exact dfsVisit_output_white_imp_input_white (G := G) (fuel := n) (u := w) (x := x) (s := s1.setParent w u) h2
rwa [h4] at h5
· rw [if_neg hw] at hout
exact ih houtA fold step preserves black vertices.
theorem dfsVisit_fold_preserves_black_general {n : Nat} {u x : V} {s1 : DFSState V} {l : List V}
(hb : s1.color x = Color.black) :
(l.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1).color x = Color.black := by
have step_pres : ∀ (s' : DFSState V) (w : V),
s'.color x = Color.black →
(if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s').color x = Color.black :=
fun s' w => dfsVisit_fold_step_preserves_black G
induction l generalizing s1 with
| nil => simpa
| cons w ws ih =>
simp
exact ih (step_pres s1 w hb)
If a vertex v occurs in the fold list and is white at the start of the
fold, then it is black after the fold (provided fuel is large enough).
theorem dfsVisit_fold_blackens_member {n : Nat} {u v : V} {s1 : DFSState V} {l : List V}
(hn : 0 < n) (hv : v ∈ l) (hwhite : s1.color v = Color.white) :
(l.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1).color v = Color.black := by
induction l generalizing s1 with
| nil => simp at hv
| cons w ws ih =>
simp at hv
cases hv with
| inl hvw =>
subst v
simp
by_cases hw : s1.color w = Color.white
· rw [if_pos hw]
have hsp : (s1.setParent w u).color w = Color.white := by simp [hw]
have hhead : (dfsVisit G n w (s1.setParent w u)).color w = Color.black :=
dfsVisit_blackens_u_pos G hn hsp
exact dfsVisit_fold_preserves_black_general (l := ws) G hhead
· rw [if_neg hw]
contradiction
| inr hvw =>
simp
by_cases hw : s1.color w = Color.white
· rw [if_pos hw]
by_cases hblack : (dfsVisit G n w (s1.setParent w u)).color v = Color.black
· exact dfsVisit_fold_preserves_black_general (l := ws) G hblack
· apply ih
· exact hvw
· -- The recursive call on `w` cannot leave `v` gray: if it is not
-- black after the call, it must still be white.
have hng : (dfsVisit G n w (s1.setParent w u)).color v ≠ Color.gray := by
intro h
have := dfsVisit_no_new_gray (G := G) (fuel := n) (u := w) (s := s1.setParent w u) v h
simp [hwhite] at this
cases hcolor : (dfsVisit G n w (s1.setParent w u)).color v with
| white => rfl
| gray => contradiction
| black => contradiction
· rw [if_neg hw]
exact ih hvw hwhite
Locate the recursive fold step that first blackens a white vertex v.
The returned state s2 is the state just before that recursive call, so
v (and the chosen neighbour) are still white in s2.
theorem dfsVisit_fold_blackens_loc {n : Nat} {u v : V} {s1 : DFSState V}
(hwhite_v1 : s1.color v = Color.white)
(hfold_black : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList).color v = Color.black) :
∃ w ∈ (G.adj u).toList, ∃ s2 : DFSState V,
s2.color w = Color.white ∧
s2.color v = Color.white ∧
(dfsVisit G n w (s2.setParent w u)).color v = Color.black ∧
(∀ z, s2.color z = Color.white → s1.color z = Color.white) := by
revert hfold_black
generalize (G.adj u).toList = l
intro hfold_black
induction l generalizing s1 with
| nil =>
rw [List.foldl_nil] at hfold_black
rw [hwhite_v1] at hfold_black
contradiction
| cons w ws ih' =>
rw [List.foldl_cons] at hfold_black
by_cases hw : s1.color w = Color.white
· rw [if_pos hw] at hfold_black
by_cases hblack : (dfsVisit G n w (s1.setParent w u)).color v = Color.black
· refine ⟨w, ?_, s1, hw, hwhite_v1, hblack, fun _ h => h⟩
simp
· have hwhite' : (dfsVisit G n w (s1.setParent w u)).color v = Color.white := by
have hspv : (s1.setParent w u).color v = Color.white := by
have : (s1.setParent w u).color v = s1.color v := by simp
rw [this, hwhite_v1]
have hng : (dfsVisit G n w (s1.setParent w u)).color v ≠ Color.gray := by
intro h
have := dfsVisit_no_new_gray G v h
rw [hspv] at this
contradiction
cases hcolor : (dfsVisit G n w (s1.setParent w u)).color v with
| white => rfl
| gray => contradiction
| black => contradiction
have h' := ih' hwhite' hfold_black
rcases h' with ⟨w', hw'mem, s2, h2w, h2v, h2b, h2mono⟩
have mono2 : ∀ z, s2.color z = Color.white → s1.color z = Color.white := by
intro z hz
have h2 := h2mono z hz
exact dfsVisit_output_white_imp_input_white (G := G) (fuel := n) (u := w) (x := z) (s := s1.setParent w u) h2
refine ⟨w', ?_, s2, h2w, h2v, h2b, mono2⟩
simp [hw'mem]
· rw [if_neg hw] at hfold_black
have h' := ih' hwhite_v1 hfold_black
rcases h' with ⟨w', hw'mem, s2, h2w, h2v, h2b, h2mono⟩
refine ⟨w', ?_, s2, h2w, h2v, h2b, fun z hz => h2mono z hz⟩
simp [hw'mem]
Variant of dfsVisit_fold_blackens_loc that also returns the prefix
processed before the blackening call and guarantees the accumulator satisfies
the black-vertex finish-time invariant and the discovery-time invariant.
theorem dfsVisit_fold_blackens_loc_prefix {n : Nat} {u v : V} {s1 : DFSState V}
(hinv : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hwhite_v1 : s1.color v = Color.white)
(hfold_black : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList).color v = Color.black) :
∃ (pre post : List V) (w : V) (s2 : DFSState V),
(G.adj u).toList = pre ++ w :: post ∧
s2 = List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 pre ∧
s2.color w = Color.white ∧
s2.color v = Color.white ∧
(dfsVisit G n w (s2.setParent w u)).color v = Color.black ∧
(∀ z, s2.color z = Color.white → s1.color z = Color.white) ∧
(∀ z, s2.color z = Color.black → finishTime s2 z < s2.time) := by
revert hfold_black
generalize (G.adj u).toList = l
intro hfold_black
induction l generalizing s1 with
| nil =>
rw [List.foldl_nil] at hfold_black
rw [hwhite_v1] at hfold_black
contradiction
| cons w ws ih' =>
rw [List.foldl_cons] at hfold_black
by_cases hw : s1.color w = Color.white
· rw [if_pos hw] at hfold_black
by_cases hblack : (dfsVisit G n w (s1.setParent w u)).color v = Color.black
· refine ⟨[], ws, w, s1, by simp, by simp, hw, hwhite_v1, hblack, fun _ h => h, hinv⟩
· let s1' := dfsVisit G n w (s1.setParent w u)
have hwhite' : s1'.color v = Color.white := by
have hspv : (s1.setParent w u).color v = Color.white := by
have : (s1.setParent w u).color v = s1.color v := by simp
rw [this, hwhite_v1]
have hng : s1'.color v ≠ Color.gray := by
intro h
have := dfsVisit_no_new_gray G v h
rw [hspv] at this
contradiction
cases hcolor : s1'.color v with
| white => rfl
| gray => contradiction
| black => contradiction
have hinv' : ∀ z, s1'.color z = Color.black → finishTime s1' z < s1'.time := by
by_cases hn0 : n = 0
· -- n = 0: the call returns the input state unchanged
have h_eq : s1' = s1.setParent w u := by
simp [s1', hn0, dfsVisit]
intro z hz
rw [h_eq] at hz ⊢
have hz1 : s1.color z = Color.black := by
simpa using hz
have h1 : finishTime (s1.setParent w u) z = finishTime s1 z := by
simp [finishTime]
have h2 : (s1.setParent w u).time = s1.time := by
simp
rw [h1, h2]
exact hinv z hz1
· -- n > 0: output invariant from the recursive visit
have hsp_inv : ∀ z, (s1.setParent w u).color z = Color.black → finishTime (s1.setParent w u) z < (s1.setParent w u).time := by
intro z hz
have hz1 : s1.color z = Color.black := by
simpa using hz
have h1 : finishTime (s1.setParent w u) z = finishTime s1 z := by
simp [finishTime]
have h2 : (s1.setParent w u).time = s1.time := by
simp
rw [h1, h2]
exact hinv z hz1
exact dfsVisit_black_finish_lt_time G (by omega) (by simpa using hw) hsp_inv
have h' := ih' hinv' hwhite' hfold_black
rcases h' with ⟨pre', post', w', s2, heq, hs2, h2w, h2v, h2b, h2mono, h2inv⟩
have mono2 : ∀ z, s2.color z = Color.white → s1.color z = Color.white := by
intro z hz
have h2 := h2mono z hz
exact dfsVisit_output_white_imp_input_white (G := G) (fuel := n) (u := w) (x := z) (s := s1.setParent w u) h2
refine ⟨w :: pre', post', w', s2, by simp [heq], by simp [hs2, hw, s1'], h2w, h2v, h2b, mono2, h2inv⟩
· rw [if_neg hw] at hfold_black
have h' := ih' hinv hwhite_v1 hfold_black
rcases h' with ⟨pre', post', w', s2, heq, hs2, h2w, h2v, h2b, h2mono, h2inv⟩
refine ⟨w :: pre', post', w', s2, by simp [heq], by simp [hs2, hw], h2w, h2v, h2b, fun z hz => h2mono z hz, h2inv⟩Fold decomposition lemma (sub-problem 1)
When the adjacency list decomposes as pre ++ v :: post and the fold
accumulator at pre is s2 with
s2.color v = Color.white, the full fold equals the fold over
post starting from the recursive dfsVisit on v.
This pure List.foldl identity uses a named step function to avoid
lambda-matching issues.
lemma dfsVisit_fold_split_at_white_neighbor {n : Nat} {u v : V}
(s_init : DFSState V) (pre post : List V) (s2 : DFSState V)
(hadj_eq : (G.adj u).toList = pre ++ v :: post)
(hs2_eq : s2 = List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G n x (s'.setParent x u) else s') s_init pre)
(hv_white_s2 : s2.color v = Color.white) :
(List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G n x (s'.setParent x u) else s')
s_init (G.adj u).toList) =
(List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G n x (s'.setParent x u) else s')
(dfsVisit G n v (s2.setParent v u)) post) := by
let step : DFSState V → V → DFSState V := fun s' x =>
if s'.color x = Color.white then dfsVisit G n x (s'.setParent x u) else s'
have h_step : step s2 v = dfsVisit G n v (s2.setParent v u) := by
dsimp [step]; rw [if_pos hv_white_s2]
have h_foldl_step : List.foldl step s2 (v :: post) = List.foldl step (step s2 v) post := rfl
calc
List.foldl step s_init (G.adj u).toList
= List.foldl step s_init (pre ++ v :: post) := by rw [hadj_eq]
_ = List.foldl step (List.foldl step s_init pre) (v :: post) := by rw [List.foldl_append]
_ = List.foldl step s2 (v :: post) := by rw [hs2_eq]
_ = List.foldl step (step s2 v) post := h_foldl_step
_ = List.foldl step (dfsVisit G n v (s2.setParent v u)) post := by rw [h_step]
A recursive dfsVisit call that blackens a white vertex v
discovers a white path from its source to v.
theorem dfsVisit_blackens_implies_whiteReachable {fuel : Nat} {u v : V} {s : DFSState V}
(hwhite : s.color u = Color.white) (hfuel : 0 < fuel)
(hwhite_v : s.color v = Color.white)
(hb : (dfsVisit G fuel u s).color v = Color.black) :
WhiteReachable G s u v := by
induction fuel generalizing u v s with
| zero => linarith
| succ n ih =>
simp [dfsVisit, hwhite] at hb
by_cases hvu : v = u
· subst v
exact whiteReachable_refl G s u
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let gray := s.setColor u Color.gray
have hwhite_v1 : s1.color v = Color.white := by
have hs1 : s1 = (s.setColor u Color.gray).setDiscovery u := rfl
rw [hs1]
simp [hvu, hwhite_v]
have hfold_black : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList).color v = Color.black := by
simpa [hvu] using hb
have hloc := dfsVisit_fold_blackens_loc G hwhite_v1 hfold_black
rcases hloc with ⟨w, hwmem, s2, hwhite_w2, hwhite_v2_s2, hblack2, hmono⟩
have hwhite_v2 : (s2.setParent w u).color v = Color.white := by
have h1 : (s2.setParent w u).color v = s2.color v := by simp
rw [h1, hwhite_v2_s2]
have hsp_white : (s2.setParent w u).color w = Color.white := by
simp [hwhite_w2]
have hn_pos : 0 < n := by
by_contra h
push Not at h
have : n = 0 := by omega
subst n
simp [dfsVisit] at hblack2
rw [hwhite_v2_s2] at hblack2
contradiction
have hr_wv := ih (u := w) (v := v) (s := s2.setParent w u)
hsp_white hn_pos hwhite_v2 hblack2
have hmono' : ∀ z, (s2.setParent w u).color z = Color.white → s1.color z = Color.white := by
intro z hz
have h2 : s2.color z = Color.white := by
have h1 : (s2.setParent w u).color z = s2.color z := by simp
rwa [h1] at hz
exact hmono z h2
have hr_wv_s1 : WhiteReachable G s1 w v :=
whiteReachable_mono_of_color_superset G hmono' hr_wv
have hcolors : ∀ z, s1.color z = gray.color z := by
intro z
have hs1' : s1 = (s.setColor u Color.gray).setDiscovery u := rfl
have hgray' : gray = s.setColor u Color.gray := rfl
rw [hs1', hgray']
by_cases hz : z = u
· simp [hz]
· simp [hz]
have hr_wv_gray : WhiteReachable G gray w v := by
rwa [WhiteReachable.color_eq G hcolors] at hr_wv_s1
have hadj_uw : G.Adj u w := by
simp [Finset.mem_toList] at hwmem
exact hwmem
have hwu : w ≠ u := by
intro h
subst w
have h1 : s1.color u = Color.white := hmono u hwhite_w2
have h2 : s1.color u = Color.gray := by
have hs1' : s1 = (s.setColor u Color.gray).setDiscovery u := rfl
rw [hs1']
simp
rw [h2] at h1
contradiction
have hw_white_gray : gray.color w = Color.white := by
have h1 : s1.color w = Color.white := hmono w hwhite_w2
dsimp [gray]
simp [hwu]
have hs1' : s1 = (s.setColor u Color.gray).setDiscovery u := rfl
rw [hs1'] at h1
simpa [hwu] using h1
have hr_uw_gray : WhiteReachable G gray u w :=
whiteReachable_step G (whiteReachable_refl G gray u) hadj_uw hw_white_gray
have hr_uv_gray : WhiteReachable G gray u v :=
whiteReachable_trans G hr_uw_gray hr_wv_gray
exact whiteReachable_gray_to_white G hwhite hr_uv_graysection WhitePathForwardForward direction of the white-path theorem
If a vertex v is reachable from a white source u through white
vertices, then a sufficiently fuelled dfsVisit from u blackens
v.
If a DFS visit from w blackens exactly the white-reachable set from
w (among vertices that were white before the visit), and leaves v
non-black, then any white path from x to v that existed before
the visit remains white after the visit.
theorem WhiteReachable.preserved_after_visit {fuel : Nat} {s' : DFSState V} {w x v : V}
(hw : w ∈ G.vertices)
(hblack_iff : ∀ y, s'.color y = Color.white →
((dfsVisit G fuel w s').color y = Color.black ↔ y ∈ whiteReachableSet G s' w))
(hwhite_x : s'.color x = Color.white)
(hpath : WhiteReachable G s' x v)
(hnv : (dfsVisit G fuel w s').color v ≠ Color.black) :
WhiteReachable G (dfsVisit G fuel w s') x v := by
let s'' := dfsVisit G fuel w s'
have hwhite_or_black {z} (hz : s'.color z = Color.white) :
s''.color z = Color.white ∨ s''.color z = Color.black := by
by_cases hb : s''.color z = Color.black
· right; exact hb
· left
exact dfsVisit_white_stays_white_or_black G hz hb
have hmem_self (a : V) : a ∈ whiteReachableSet G s' a := by
have h0 : a ∈ whiteReachableIter G s' a 0 := by simp [whiteReachableIter]
exact whiteReachableIter_mono_le G s' a (by linarith) h0
have hwhite_v : s'.color v = Color.white :=
whiteReachable_target_white (G := G) hwhite_x hpath
have hP : ∀ a, WhiteReachable G s' x a → WhiteReachable G s' a v → s''.color a ≠ Color.black → WhiteReachable G s'' x a := by
intro a hr_xa
induction hr_xa with
| refl =>
intro _ _
exact whiteReachable_refl G s'' x
| @tail p q hpq hstep ih =>
intro hr_qv hnblack_q
have hwhite_q_s' : s'.color q = Color.white := hstep.2
have hr_pv : WhiteReachable G s' p v :=
whiteReachable_trans G (whiteReachable_step G (whiteReachable_refl G s' p) hstep.1 hstep.2) hr_qv
have hwhite_p_s' : s'.color p = Color.white :=
whiteReachable_target_white (G := G) hwhite_x hpq
have hnblack_p : s''.color p ≠ Color.black := by
intro hb
have hpw : p ∈ whiteReachableSet G s' w := (hblack_iff p hwhite_p_s').mp hb
have hpw' := whiteReachableIter_to_WhiteReachable G hpw
have hpv : p ∈ G.vertices :=
whiteReachableIter_subset_vertices G s' w hw (G.vertices.card) hpw
have hsubset := whiteReachableSet_subset_of_WhiteReachable G hw hpw'
have hvp_set : v ∈ whiteReachableSet G s' p :=
WhiteReachable.mem_set G hpv hr_pv
have hvw : v ∈ whiteReachableSet G s' w := hsubset hvp_set
have hb_v : s''.color v = Color.black := (hblack_iff v hwhite_v).mpr hvw
contradiction
have hwhite_p_s'' : s''.color p = Color.white :=
(hwhite_or_black hwhite_p_s').resolve_right hnblack_p
have hwhite_q_s'' : s''.color q = Color.white :=
(hwhite_or_black hwhite_q_s').resolve_right hnblack_q
have hr_xp_s'' := ih hr_pv hnblack_p
exact whiteReachable_step G hr_xp_s'' hstep.1 hwhite_q_s''
exact hP v hpath (whiteReachable_refl G s' v) hnvForward direction of the white-path theorem.
A sufficiently fuelled dfsVisit from a white source u blackens
every vertex that is reachable from u through white vertices.
theorem dfsVisit_white_path_black {fuel : Nat} {u v : V} {s : DFSState V}
(hwhite : s.color u = Color.white) (hu : u ∈ G.vertices)
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1)
(hv : v ∈ whiteReachableSet G s u) :
(dfsVisit G fuel u s).color v = Color.black := by
generalize hM : (whiteReachableSet G s u).card = M
revert fuel u v s hwhite hu hfuel hv hM
induction M using Nat.strongRecOn with
| ind M ih =>
intro fuel u v s hwhite hu hfuel hv hM
have h0fuel : 0 < fuel := by omega
by_cases hvu : v = u
· subst v
exact dfsVisit_blackens_u_pos G h0fuel hwhite
· have hne : v ≠ u := hvu
rcases whiteReachableSet_decomp_ne G hu hwhite hv hne with ⟨x, hadj, hwhite_x, hxne, hvx⟩
let s1 := s.setColor u Color.gray |>.setDiscovery u
let gray := s.setColor u Color.gray
have hwhite_x_s1 : s1.color x = Color.white := by
simp [s1, hxne, hwhite_x]
have hvx_s1 : v ∈ whiteReachableSet G s1 x := by
have hcolors : ∀ z, s1.color z = gray.color z := by
intro z
simp [s1, gray]
rw [whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj) hcolors]
exact hvx
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G (fuel - 1) w (s'.setParent w u) else s'
have hinv : ∀ (l' : List V) (s' : DFSState V),
l' ⊆ (G.adj u).toList →
x ∈ l' →
(∀ z, s'.color z = Color.white → s1.color z = Color.white) →
(s'.color x = Color.white ∧ v ∈ whiteReachableSet G s' x) →
(List.foldl step s' l').color v = Color.black := by
intro l' s' hlsub hxmem hmono hP
induction l' generalizing s' with
| nil =>
simp at hxmem
| cons w ws ih' =>
have hwmem : w ∈ (G.adj u).toList := by
apply hlsub
simp
have hws_sub : ws ⊆ (G.adj u).toList := by
intro y hy
apply hlsub
simp [hy]
simp at hxmem
rcases hxmem with (rfl | hxws)
· -- w = x
simp [step]
rw [if_pos hP.1]
let s0 := s'.setParent x u
have hwhite_x_s0 : s0.color x = Color.white := by simp [s0, hP.1]
have hcolors0 : ∀ z, s0.color z = s'.color z := by simp [s0]
have hvx_s0 : v ∈ whiteReachableSet G s0 x := by
rw [whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj) hcolors0]
exact hP.2
have hcard_x : (whiteReachableSet G s0 x).card < M := by
have h1 : whiteReachableSet G s0 x = whiteReachableSet G s' x :=
whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj) hcolors0
have h2 : whiteReachableSet G s' x ⊆ whiteReachableSet G s1 x :=
whiteReachableSet_mono_of_color_superset G (G.adj_mem_right hadj) hmono
have h3 : whiteReachableSet G s1 x = whiteReachableSet G gray x := by
apply whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj)
intro z
simp [s1, gray]
have h4 : (whiteReachableSet G gray x).card < (whiteReachableSet G s u).card := by
apply Finset.card_lt_card
exact whiteReachableSet_neighbor_ssubset G hu hwhite hadj hwhite_x hxne
rw [h1]
apply Nat.lt_of_le_of_lt (Finset.card_le_card h2)
rw [h3]
linarith [hM]
have hfuel_x : fuel - 1 ≥ (whiteReachableSet G s0 x).card + 1 := by
omega
have hblack_x : (dfsVisit G (fuel - 1) x s0).color v = Color.black := by
exact @ih (whiteReachableSet G s0 x).card (by linarith [hM, hcard_x]) (fuel - 1) x v s0 hwhite_x_s0 (G.adj_mem_right hadj) hfuel_x hvx_s0 (by rfl)
exact dfsVisit_fold_preserves_black_general G hblack_x
· -- w ≠ x
simp [step]
by_cases hw : s'.color w = Color.white
· rw [if_pos hw]
let s0 := s'.setParent w u
let s'' := dfsVisit G (fuel - 1) w s0
have hadj_w : G.Adj u w := by
simp [Finset.mem_toList] at hwmem
exact hwmem
have hcolors0 : ∀ z, s0.color z = s'.color z := by simp [s0]
have hcard_w : (whiteReachableSet G s0 w).card < M := by
have h1 : whiteReachableSet G s0 w = whiteReachableSet G s' w :=
whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj_w) hcolors0
have h2 : whiteReachableSet G s' w ⊆ whiteReachableSet G s1 w :=
whiteReachableSet_mono_of_color_superset G (G.adj_mem_right hadj_w) hmono
have h3 : whiteReachableSet G s1 w = whiteReachableSet G gray w := by
apply whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj_w)
intro z
simp [s1, gray]
have h4 : (whiteReachableSet G gray w).card < (whiteReachableSet G s u).card := by
have hwne : w ≠ u := by
intro hwu
subst w
have : s1.color u = Color.white := hmono u (by simpa using hw)
simp [s1] at this
have hwhite_w_s : s.color w = Color.white := by
have h1 : s1.color w = Color.white := hmono w hw
simp [s1, hwne] at h1
exact h1
apply Finset.card_lt_card
exact whiteReachableSet_neighbor_ssubset G hu hwhite hadj_w hwhite_w_s hwne
rw [h1]
apply Nat.lt_of_le_of_lt (Finset.card_le_card h2)
rw [h3]
linarith [hM]
have hfuel_w : fuel - 1 ≥ (whiteReachableSet G s0 w).card + 1 := by
omega
have hwhite_v_s0 : s0.color v = Color.white := by
have hvx_s0 : v ∈ whiteReachableSet G s0 x := by
rw [whiteReachableSet_eq_of_color_eq G (G.adj_mem_right hadj) hcolors0]
exact hP.2
have hpath : WhiteReachable G s0 x v :=
whiteReachableIter_to_WhiteReachable G hvx_s0
exact whiteReachable_target_white (G := G) (by simp [s0, hP.1]) hpath
have hblack_iff : ∀ y, s0.color y = Color.white →
(s''.color y = Color.black ↔ y ∈ whiteReachableSet G s0 w) := by
intro y hy_white
constructor
· intro hblack
exact WhiteReachable.mem_set G (G.adj_mem_right hadj_w)
(dfsVisit_blackens_implies_whiteReachable G (by simp [s0]; exact hw) (by omega) hy_white hblack)
· intro hy
exact @ih (whiteReachableSet G s0 w).card (by linarith [hM, hcard_w]) (fuel - 1) w y s0 (by simp [s0]; exact hw) (G.adj_mem_right hadj_w) hfuel_w hy (by rfl)
have hP'' : s''.color v = Color.black ∨ (s''.color x = Color.white ∧ v ∈ whiteReachableSet G s'' x) := by
by_cases hblack_v : s''.color v = Color.black
· left; exact hblack_v
· right
have hwhite_x_s0 : s0.color x = Color.white := by simp [s0, hP.1]
have hwhite_x_s'' : s''.color x = Color.white := by
have hnx : s''.color x ≠ Color.black := by
intro hb
have hxw : x ∈ whiteReachableSet G s0 w := (hblack_iff x hwhite_x_s0).mp hb
have hxw' := whiteReachableIter_to_WhiteReachable G hxw
have hsubset := whiteReachableSet_subset_of_WhiteReachable G (G.adj_mem_right hadj_w) hxw'
have hvx_s' : WhiteReachable G s' x v := whiteReachableIter_to_WhiteReachable G hP.2
have hvx_s0 : WhiteReachable G s0 x v :=
(WhiteReachable.color_eq G (fun z => (hcolors0 z).symm)).mpr hvx_s'
have hvx_s0_set : v ∈ whiteReachableSet G s0 x :=
WhiteReachable.mem_set G (G.adj_mem_right hadj) hvx_s0
have hvw : v ∈ whiteReachableSet G s0 w := hsubset hvx_s0_set
have hb_v := (hblack_iff v hwhite_v_s0).mpr hvw
contradiction
exact dfsVisit_white_stays_white_or_black G hwhite_x_s0 hnx
have hv_s'' : v ∈ whiteReachableSet G s'' x := by
have hpath_s' : WhiteReachable G s' x v := whiteReachableIter_to_WhiteReachable G hP.2
have hpath : WhiteReachable G s0 x v :=
(WhiteReachable.color_eq G (fun z => (hcolors0 z).symm)).mpr hpath_s'
have hpreserved := WhiteReachable.preserved_after_visit G (G.adj_mem_right hadj_w) hblack_iff hwhite_x_s0 hpath hblack_v
exact WhiteReachable.mem_set G (G.adj_mem_right hadj) hpreserved
exact ⟨hwhite_x_s'', hv_s''⟩
have hmono'' : ∀ z, s''.color z = Color.white → s1.color z = Color.white := by
intro z hz
have h1 : s0.color z = Color.white := dfsVisit_output_white_imp_input_white (G := G) hz
have h2 : s'.color z = Color.white := by simpa [s0] using h1
exact hmono z h2
rcases hP'' with (hblack_v' | hP''')
· exact dfsVisit_fold_preserves_black_general G hblack_v'
· exact ih' s'' hws_sub hxws hmono'' hP'''
· rw [if_neg hw]
exact ih' s' hws_sub hxws hmono hP
have hxmem : x ∈ (G.adj u).toList := by
rw [Finset.mem_toList]
exact hadj
have hfold_black : (List.foldl step s1 (G.adj u).toList).color v = Color.black :=
hinv (G.adj u).toList s1 (fun _ h => h) hxmem (fun _ h => h) ⟨hwhite_x_s1, hvx_s1⟩
have : (dfsVisit G fuel u s).color v = (List.foldl step s1 (G.adj u).toList).color v := by
cases fuel with
| zero => linarith
| succ n =>
simp [dfsVisit, hwhite, hvu, s1, step]
rw [this]
exact hfold_black
A sufficiently fuelled dfsVisit from a white source u
blackens exactly the white vertices that are reachable from u through
white vertices.
theorem dfsVisit_blackens_iff_whiteReachable {fuel : Nat} {u v : V} {s : DFSState V}
(hwhite_u : s.color u = Color.white) (hu : u ∈ G.vertices)
(hwhite_v : s.color v = Color.white)
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1) :
(dfsVisit G fuel u s).color v = Color.black ↔ v ∈ whiteReachableSet G s u := by
constructor
· intro hb
exact WhiteReachable.mem_set G hu (dfsVisit_blackens_implies_whiteReachable G hwhite_u (by omega) hwhite_v hb)
· intro hv
exact dfsVisit_white_path_black G hwhite_u hu hfuel hvend WhitePathForwardsection ReachabilityInvariantsDFS reachability invariants
For any prefix of a full DFS, the set of black vertices is closed under reachability: if a vertex is black, every vertex reachable from it is also black. This lets us argue that a path to a still-white vertex stays entirely white at the moment of discovery.
A dfsVisit from a white source blackens exactly the vertices that were
already black together with the white-reachable set from the source.
theorem dfsVisit_black_set {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1) (hwhite : s.color u = Color.white)
(hu : u ∈ G.vertices)
(hng : ∀ v, s.color v = Color.white ∨ s.color v = Color.black) :
∀ v, (dfsVisit G fuel u s).color v = Color.black ↔
s.color v = Color.black ∨ v ∈ whiteReachableSet G s u := by
intro v
by_cases hblack : s.color v = Color.black
· have hout : (dfsVisit G fuel u s).color v = Color.black := dfsVisit_preserves_black G hblack
simp [hout, hblack]
· have hwhite_v : s.color v = Color.white := by cases hng v <;> tauto
have hiff := dfsVisit_blackens_iff_whiteReachable G hwhite hu hwhite_v hfuel
simp [hblack, hiff]
If z reaches a white vertex p and every vertex reachable from
z and from which p is reachable is white, then p is
white-reachable from z.
theorem WhiteReachable.of_reachable_closed {s : DFSState V} {z p : V}
(hwhite_p : s.color p = Color.white)
(hreach : G.Reachable z p)
(hwhite_inter : ∀ b, G.Reachable z b → G.Reachable b p → s.color b = Color.white) :
WhiteReachable G s z p := by
induction hreach with
| refl =>
exact whiteReachable_refl G s z
| @tail x y hzx hadj ih =>
have hx_white := hwhite_inter x hzx
(G.reachable_trans (G.reachable_adj hadj) (G.reachable_refl y))
have hzx' := ih hx_white (fun b hzb hbp => hwhite_inter b hzb (G.reachable_trans hbp (G.reachable_adj hadj)))
exact whiteReachable_step G hzx' hadj hwhite_pAfter any prefix of a full DFS, black vertices are closed under reachability.
theorem dfsFromList_black_reachable_closed {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hfuel : 0 < fuel)
(hfuel_bound : fuel ≥ G.vertices.card + 1)
(hng : ∀ v, s0.color v = Color.white ∨ s0.color v = Color.black)
(hclosed : ∀ z p, s0.color z = Color.black → G.Reachable z p → s0.color p = Color.black)
(hvs : ∀ v ∈ vs, v ∈ G.vertices) :
∀ z p, (dfsFromList G fuel vs s0).color z = Color.black → G.Reachable z p →
(dfsFromList G fuel vs s0).color p = Color.black := by
induction vs generalizing s0 hng hclosed with
| nil => simpa [dfsFromList]
| cons u us ih =>
by_cases hwhite : s0.color u = Color.white
· -- u is white: the visit blackens the white-reachable set
simp [dfsFromList, hwhite]
let s1 := dfsVisit G fuel u s0
have hng1 : ∀ v, s1.color v = Color.white ∨ s1.color v = Color.black := by
apply dfsVisit_output_no_gray
intro v; cases hng v <;> simp [*]
have hcard : fuel ≥ (whiteReachableSet G s0 u).card + 1 := by
have hsub : whiteReachableSet G s0 u ⊆ G.vertices :=
whiteReachableSet_subset_vertices G s0 u (hvs u (by simp))
have hcard : (whiteReachableSet G s0 u).card ≤ G.vertices.card :=
Finset.card_le_card hsub
omega
have hblack_set := dfsVisit_black_set G hcard hwhite (hvs u (by simp)) hng
have hclosed1 : ∀ z p, s1.color z = Color.black → G.Reachable z p → s1.color p = Color.black := by
intro z p hz hp
rw [hblack_set z] at hz
rcases hz with (hz0 | hzwr)
· -- z was already black in s0; closure forces p to be black in s0
by_cases hp0 : s0.color p = Color.black
· exact dfsVisit_preserves_black G hp0
· have hpw : s0.color p = Color.white := by cases hng p <;> tauto
have hp_black := hclosed z p hz0 hp
contradiction
· -- z is white-reachable from u; extend the white path to p
by_cases hp0 : s0.color p = Color.black
· exact dfsVisit_preserves_black G hp0
· have hpw : s0.color p = Color.white := by cases hng p <;> tauto
have hpwr : p ∈ whiteReachableSet G s0 u := by
have hwr_z := whiteReachableIter_to_WhiteReachable G hzwr
have hwr_p := WhiteReachable.of_reachable_closed G hpw hp (fun b _ hbp => by
by_contra hb
push Not at hb
have hb_black : s0.color b = Color.black := by cases hng b <;> tauto
have hp_black := hclosed b p hb_black hbp
contradiction)
have hwr_up := whiteReachable_trans G hwr_z hwr_p
exact WhiteReachable.mem_set G (hvs u (by simp)) hwr_up
rw [hblack_set p]
right; exact hpwr
exact ih (s0 := s1) hng1 hclosed1 (fun v hv => hvs v (List.mem_cons_of_mem u hv))
· -- u is not white: the state is unchanged on this step
have hunchanged : dfsVisit G fuel u s0 = s0 := by
have hne : s0.color u ≠ Color.white := by simpa using hwhite
induction fuel with
| zero => simp [dfsVisit]
| succ n _ => simp [dfsVisit, hne]
simp [dfsFromList, hwhite]
exact ih (s0 := s0) hng hclosed (fun v hv => hvs v (List.mem_cons_of_mem u hv))
Finish times of black vertices are preserved by any further
dfsFromList.
theorem dfsFromList_preserves_f_of_black {fuel : Nat} {s0 : DFSState V} {vs : List V}
(_hfuel : 0 < fuel) {x : V}
(hblack : s0.color x = Color.black) :
(dfsFromList G fuel vs s0).f x = s0.f x := by
induction vs generalizing s0 with
| nil => simp [dfsFromList]
| cons u us ih =>
simp [dfsFromList]
split_ifs with hwhite
· have hblack' : (dfsVisit G fuel u s0).color x = Color.black :=
dfsVisit_preserves_black G hblack
have hf : (dfsVisit G fuel u s0).f x = s0.f x := by
by_cases hxu : x = u
· rw [hxu] at hblack
have : s0.color u ≠ Color.white := by simp [hblack]
contradiction
· have hnw : s0.color x ≠ Color.white := by simp [hblack]
exact dfsVisit_preserves_f_of_not_white G hxu hnw
have h1 := ih (s0 := dfsVisit G fuel u s0) hblack'
rw [h1, hf]
· exact ih hblack
dfsFromList never moves the global clock backwards.
theorem dfsFromList_time_ge {fuel : Nat} {s0 : DFSState V} {vs : List V} :
(dfsFromList G fuel vs s0).time ≥ s0.time := by
induction vs generalizing s0 with
| nil => simp [dfsFromList]
| cons u us ih =>
simp [dfsFromList]
split_ifs with hwhite
· have h1 := G.dfsVisit_time_ge (fuel := fuel) (u := u) (s := s0)
have h2 := ih (s0 := dfsVisit G fuel u s0)
linarith
· exact ihend ReachabilityInvariantsend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S2_Intervals
DFS theory: parenthesis theorem and ancestor relations
This file extends the white-path theory with DFS timestamp intervals, the ancestor/descendant relations, and the discovery-state theorem.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V] (G : Graph V)section IntervalsDFS timestamps, intervals and ancestor relation
The parenthesis theorem compares the closed intervals
[d[u], f[u]] defined by the discovery/finish timestamps of a full DFS.
It is the key to edge classification and to the finish-time ordering of
strongly connected components.
u finishes strictly before v is discovered.
def finishesBeforeDiscovered (s : DFSState V) (u v : V) : Prop :=
finishTime s u < discoveryTime s v
v's interval is strictly nested inside u's interval.
def intervalNestedInside (s : DFSState V) (u v : V) : Prop :=
discoveryTime s u < discoveryTime s v ∧ finishTime s v < finishTime s uTwo distinct DFS timestamp intervals are laminar when they are disjoint in one direction or one is strictly nested inside the other.
def intervalsLaminar (s : DFSState V) (u v : V) : Prop :=
finishesBeforeDiscovered s u v ∨
finishesBeforeDiscovered s v u ∨
intervalNestedInside s u v ∨
intervalNestedInside s v uPartial parenthesis invariant for an intermediate DFS state: every pair of finished (black) vertices already has laminar timestamp intervals.
def ParenthesisInvariant (s : DFSState V) : Prop :=
∀ u v, s.color u = Color.black → s.color v = Color.black → u ≠ v →
intervalsLaminar s u vtheorem intervalsLaminar_symm {s : DFSState V} {u v : V}
(h : intervalsLaminar s u v) : intervalsLaminar s v u := by
unfold intervalsLaminar at h ⊢
tauto
u is an ancestor of v in the DFS parent forest
(reflexive-transitive closure of the parent relation).
def IsDFSAncestor (s : DFSState V) (u v : V) : Prop :=
Relation.ReflTransGen (fun x y => s.parent y = some x) u vInternal strengthened ancestor relation whose parent-chain children are all finished. This form can be transported through later DFS states because black vertices keep both their color and parent pointer.
def IsBlackDFSAncestor (s : DFSState V) (u v : V) : Prop :=
Relation.ReflTransGen (fun x y => s.parent y = some x ∧ s.color y = Color.black) u vFor finished vertices, strict interval nesting already determines a black parent-chain ancestor. This invariant supplies the parent-forest half of the CLRS parenthesis theorem.
def NestingAncestorInvariant (s : DFSState V) : Prop :=
∀ u v, s.color u = Color.black → s.color v = Color.black →
intervalNestedInside s u v → IsBlackDFSAncestor s u vEvery recorded parent has already been discovered. A white child is still waiting to be visited; a non-white child was discovered strictly after its parent.
def ParentDiscoveryInvariant (s : DFSState V) : Prop :=
∀ u v, s.parent v = some u →
s.color u ≠ Color.white ∧
((s.color v = Color.white ∧ discoveryTime s u < s.time) ∨
(s.color v ≠ Color.white ∧ discoveryTime s u < discoveryTime s v))
v is a descendant of u in the DFS parent forest; this is the
same relation as IsDFSAncestor.
def IsDFSDescendant (s : DFSState V) (u v : V) : Prop := IsDFSAncestor s u v@[simp]
theorem IsDFSAncestor.refl (s : DFSState V) (u : V) : IsDFSAncestor s u u :=
Relation.ReflTransGen.refltheorem IsBlackDFSAncestor.toAncestor {s : DFSState V} {u v : V}
(h : IsBlackDFSAncestor s u v) : IsDFSAncestor s u v := by
induction h with
| refl => exact Relation.ReflTransGen.refl
| tail _ hxy ih => exact Relation.ReflTransGen.tail ih hxy.1theorem IsBlackDFSAncestor.trans {s : DFSState V} {u v w : V}
(huv : IsBlackDFSAncestor s u v) (hvw : IsBlackDFSAncestor s v w) :
IsBlackDFSAncestor s u w :=
Relation.ReflTransGen.trans huv hvwtheorem IsBlackDFSAncestor.single {s : DFSState V} {u v : V}
(hparent : s.parent v = some u) (hblack : s.color v = Color.black) :
IsBlackDFSAncestor s u v :=
Relation.ReflTransGen.single ⟨hparent, hblack⟩Transport a black ancestor chain to a later state that preserves black vertices and their parent pointers.
theorem IsBlackDFSAncestor.mono {s t : DFSState V} {u v : V}
(h : IsBlackDFSAncestor s u v)
(hblack : ∀ x, s.color x = Color.black → t.color x = Color.black)
(hparent : ∀ x, s.color x = Color.black → t.parent x = s.parent x) :
IsBlackDFSAncestor t u v := by
induction h with
| refl => exact Relation.ReflTransGen.refl
| @tail x y hxy hyz ih =>
apply Relation.ReflTransGen.tail ih
exact ⟨by rw [hparent y hyz.2]; exact hyz.1, hblack y hyz.2⟩The source of a DFS visit is discovered at the input state's clock value.
theorem dfsVisit_discovery_source {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
discoveryTime (dfsVisit G fuel u s) u = s.time := by
cases fuel with
| zero => linarith
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, dfsVisit, hwhite]
rw [heq_state]
have hs2 : s2.d u = s1.d u := by
apply G.dfsVisit_fold_preserves_d_of_not_white
simp [s1]
simp [s3, s1, discoveryTime, hs2]
Stronger version: the source's d field equals
some (s.time).
theorem dfsVisit_discovery_source_d_eq {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
(dfsVisit G fuel u s).d u = some (s.time) := by
cases fuel with
| zero => omega
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, dfsVisit, hwhite]
rw [heq_state]
have h_set : s1.d u = some (s.time) := by simp [s1]
have hnw : s1.color u ≠ Color.white := by simp [s1]
have h_fold : s2.d u = s1.d u :=
dfsVisit_fold_preserves_d_of_not_white G (u := u) (v := u) s1 (l := (G.adj u).toList) hnw
have h_finish : s3.d u = s2.d u := by simp [s3]
simp [h_set, h_fold, h_finish]The source of a DFS visit is finished exactly one time unit before the output state's clock.
theorem dfsVisit_finishTime_source_eq_pred_time {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
finishTime (dfsVisit G fuel u s) u = (dfsVisit G fuel u s).time - 1 := by
cases fuel with
| zero => linarith
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, dfsVisit, hwhite]
rw [heq_state]
have hs2 : s2.f u = s1.f u := by
apply G.dfsVisit_fold_preserves_f_of_not_white s1
simp [s1]
simp [s3, finishTime]
In a DFS visit from a white source u, every vertex blackened during
the visit finishes no later than u.
theorem dfsVisit_finish_le_source {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hinv : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hblack : (dfsVisit G fuel u s).color v = Color.black) :
finishTime (dfsVisit G fuel u s) v ≤ finishTime (dfsVisit G fuel u s) u := by
by_cases hvu : v = u
· subst v; rfl
· have h1 : finishTime (dfsVisit G fuel u s) u = (dfsVisit G fuel u s).time - 1 :=
dfsVisit_finishTime_source_eq_pred_time G hfuel hwhite
have h2 : finishTime (dfsVisit G fuel u s) v < (dfsVisit G fuel u s).time := by
apply dfsVisit_black_finish_lt_time G hfuel hwhite hinv
exact hblack
have htime_pos : (dfsVisit G fuel u s).time > 0 := by
have : finishTime (dfsVisit G fuel u s) v ≥ 0 := Nat.zero_le _
omega
omegaAny non-source vertex discovered during a DFS visit is discovered at a time strictly later than the input state's clock.
theorem dfsVisit_discovery_ge_input_time {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hwhite_v : s.color v = Color.white)
(hblack : (dfsVisit G fuel u s).color v = Color.black) (hne : v ≠ u) :
discoveryTime (dfsVisit G fuel u s) v ≥ s.time + 1 := by
induction fuel generalizing u s with
| zero =>
simp [dfsVisit] at hblack
rw [hwhite_v] at hblack
contradiction
| succ n ih =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, step, dfsVisit, hwhite]
have heq_color : (dfsVisit G (n + 1) u s).color v = s3.color v := by
rw [heq_state]
have heq_d : (dfsVisit G (n + 1) u s).d v = s3.d v := by
rw [heq_state]
rw [heq_color] at hblack
have hwhite_v1 : s1.color v = Color.white := by
simp [s1, hne, hwhite_v]
have hfold_black : (List.foldl step s1 (G.adj u).toList).color v = Color.black := by
simp [s3, hne] at hblack
simpa using hblack
have hdisc_fold : discoveryTime s2 v ≥ s1.time := by
have hgen : ∀ (l : List V) (s' : DFSState V),
s'.color v = Color.white →
(List.foldl step s' l).color v = Color.black →
discoveryTime (List.foldl step s' l) v ≥ s'.time := by
intro l s' hwhite_s' hblack_s'
induction l generalizing s' with
| nil =>
rw [List.foldl_nil] at hblack_s'
rw [hwhite_s'] at hblack_s'
contradiction
| cons w ws ih' =>
rw [List.foldl_cons] at hblack_s' ⊢
by_cases hw : s'.color w = Color.white
· let s_rec := dfsVisit G n w (s'.setParent w u)
have hstep : step s' w = s_rec := by
simp [step, s_rec, hw]
rw [hstep]
by_cases hblack_rec : s_rec.color v = Color.black
· have hn_pos : 0 < n := by
by_contra h
have : n = 0 := by omega
subst n
simp [s_rec, dfsVisit] at hblack_rec
rw [hwhite_s'] at hblack_rec
cases hblack_rec
have hdisc_rec : discoveryTime s_rec v ≥ (s'.setParent w u).time := by
by_cases hvw : v = w
· rw [hvw]
rw [dfsVisit_discovery_source G hn_pos (by simpa using hw)]
· have h1 := ih (u := w) (s := s'.setParent w u) hn_pos (by simpa using hw) (by simpa [hvw] using hwhite_s') hblack_rec hvw
linarith
have htime_eq : (s'.setParent w u).time = s'.time := by simp
have hdisc_rec' : discoveryTime s_rec v ≥ s'.time := by linarith [hdisc_rec, htime_eq]
have hpres : discoveryTime (List.foldl step s_rec ws) v = discoveryTime s_rec v := by
have hblack' : s_rec.color v = Color.black := hblack_rec
have h4 : (List.foldl step s_rec ws).d v = s_rec.d v :=
G.dfsVisit_fold_preserves_d_of_black (s1 := s_rec) (l := ws) hblack'
simp [discoveryTime, h4]
linarith [hpres, hdisc_rec']
· have hwhite_rec : s_rec.color v = Color.white := by
have hspv : (s'.setParent w u).color v = Color.white := by simpa using hwhite_s'
have hng : s_rec.color v ≠ Color.gray := by
intro h
have := dfsVisit_no_new_gray G v h
rw [hspv] at this
contradiction
cases hcolor : s_rec.color v with
| white => rfl
| gray => contradiction
| black => contradiction
rw [hstep] at hblack_s'
have htime_ge : s_rec.time ≥ s'.time := by
have h1 := G.dfsVisit_time_ge (fuel := n) (u := w) (s := s'.setParent w u)
have h2 : (s'.setParent w u).time = s'.time := by simp
linarith
have hsub : discoveryTime (List.foldl step s_rec ws) v ≥ s_rec.time :=
ih' s_rec hwhite_rec hblack_s'
linarith [hsub, htime_ge]
· have hstep : step s' w = s' := by
simp [step, hw]
rw [hstep]
rw [hstep] at hblack_s'
exact ih' s' hwhite_s' hblack_s'
exact hgen (G.adj u).toList s1 hwhite_v1 hfold_black
have htime_s1 : s1.time = s.time + 1 := by
simp [s1]
have hdisc_top : discoveryTime (dfsVisit G (n + 1) u s) v = discoveryTime s2 v := by
have h4 : (dfsVisit G (n + 1) u s).d v = s2.d v := by
rw [heq_d]
simp [s3]
simp [discoveryTime, h4]
linarith [hdisc_fold, htime_s1, hdisc_top]Every non-white vertex of a DFS state was discovered strictly before the state's current clock. This invariant holds for all well-formed intermediate states produced by DFS.
def DiscoveryTimeInvariant (s : DFSState V) : Prop :=
∀ v, s.color v ≠ Color.white → discoveryTime s v < s.timeA DFS visit from a white source strictly advances the global clock.
theorem dfsVisit_time_gt_of_white {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white) :
(dfsVisit G fuel u s).time > s.time := by
cases fuel with
| zero => linarith
| succ n =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [heq]
have hs1 : s1.time = s.time + 1 := by simp [s1]
have hs2 : s2.time ≥ s1.time := G.dfsVisit_fold_time_ge s1
have hs3 : s3.time = s2.time + 1 := by simp [s3]
linarith [hs1, hs2, hs3]A DFS visit from a white source preserves the discovery-time invariant for all non-white vertices, including intermediate gray vertices on the recursion stack.
theorem dfsVisit_preserves_discoveryTimeInvariant {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ v, s.color v = Color.black → finishTime s v < s.time)
(hdf : DiscoveryFinishInvariant s) :
DiscoveryTimeInvariant (dfsVisit G fuel u s) := by
intro v hv
by_cases hgray_out : (dfsVisit G fuel u s).color v = Color.gray
· -- `v` stays gray; it was already gray in `s`, so its discovery time is
-- preserved while the clock advanced.
have hgray_in : s.color v = Color.gray := dfsVisit_no_new_gray G v hgray_out
have hne : v ≠ u := by
intro heq
rw [heq] at hgray_in
simp [hwhite] at hgray_in
have hd_eq : discoveryTime (dfsVisit G fuel u s) v = discoveryTime s v := by
have h2 : (dfsVisit G fuel u s).d v = s.d v :=
dfsVisit_preserves_d_of_not_white G hne (by simp [hgray_in])
simp [discoveryTime, h2]
rw [hd_eq]
have h1 : discoveryTime s v < s.time := hdt v (by simp [hgray_in])
have h2 : (dfsVisit G fuel u s).time > s.time :=
dfsVisit_time_gt_of_white G hfuel hwhite
linarith
· -- `v` is not gray; since it is not white either, it is black.
have hblack : (dfsVisit G fuel u s).color v = Color.black := by
have h1 : (dfsVisit G fuel u s).color v ≠ Color.white := hv
have h2 : (dfsVisit G fuel u s).color v ≠ Color.gray := by
intro h'; simp [h'] at hgray_out
cases hcolor : (dfsVisit G fuel u s).color v with
| white => exfalso; exact h1 hcolor
| gray => exfalso; exact h2 hcolor
| black => rfl
by_cases hwhite_v : s.color v = Color.white
· -- `v` was white and was blackened during the visit
have hdu : discoveryTime (dfsVisit G fuel u s) v < finishTime (dfsVisit G fuel u s) v := by
have hdf_out : DiscoveryFinishInvariant (dfsVisit G fuel u s) :=
dfsVisit_discovery_lt_finish G hfuel hwhite hdf
exact hdf_out v hblack
have hft : finishTime (dfsVisit G fuel u s) v < (dfsVisit G fuel u s).time := by
exact dfsVisit_black_finish_lt_time G hfuel hwhite hbf v hblack
linarith
· -- `v` was already non-white in `s`
have hne : v ≠ u := by
intro heq
rw [heq] at hwhite_v
simp [hwhite] at hwhite_v
have hd_eq : discoveryTime (dfsVisit G fuel u s) v = discoveryTime s v := by
have h2 : (dfsVisit G fuel u s).d v = s.d v :=
dfsVisit_preserves_d_of_not_white G hne (by simp [hwhite_v])
simp [discoveryTime, h2]
rw [hd_eq]
have h1 : discoveryTime s v < s.time := hdt v (by simp [hwhite_v])
have h2 : (dfsVisit G fuel u s).time > s.time :=
dfsVisit_time_gt_of_white G hfuel hwhite
linarithRecursive DFS over a list preserves the discovery-time invariant.
theorem dfsFromList_preserves_discoveryTimeInvariant {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hfuel : 0 < fuel)
(hdt : DiscoveryTimeInvariant s0)
(hbf : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time)
(hdf : DiscoveryFinishInvariant s0)
(hng : ∀ v, s0.color v = Color.white ∨ s0.color v = Color.black)
(hvs : ∀ v ∈ vs, v ∈ G.vertices) :
DiscoveryTimeInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0 with
| nil => simpa [dfsFromList]
| cons u us ih =>
simp [dfsFromList]
split_ifs with hwhite
· let s1 := dfsVisit G fuel u s0
have hdt1 : DiscoveryTimeInvariant s1 :=
dfsVisit_preserves_discoveryTimeInvariant G hfuel hwhite hdt hbf hdf
have hbf1 : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time :=
dfsVisit_black_finish_lt_time G hfuel hwhite hbf
have hdf1 : DiscoveryFinishInvariant s1 :=
dfsVisit_discovery_lt_finish G hfuel hwhite hdf
have hng1 : ∀ v, s1.color v = Color.white ∨ s1.color v = Color.black :=
dfsVisit_output_no_gray G hng
exact ih (s0 := s1) hdt1 hbf1 hdf1 hng1 (fun v hv => hvs v (by simp [hv]))
· exact ih (s0 := s0) hdt hbf hdf hng (fun v hv => hvs v (by simp [hv]))Parenthesis invariant
A DFS visit preserves laminarity of the intervals of all finished vertices.
Old black vertices finish before the visit starts. Vertices finished by one recursive subcall are handled by the induction hypothesis, while every vertex newly finished by the whole visit is nested inside the visit source.
theorem dfsVisit_preserves_parenthesisInvariant {fuel : Nat} {u : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hparen : ParenthesisInvariant s)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ v, s.color v = Color.black → finishTime s v < s.time)
(hdf : DiscoveryFinishInvariant s) :
ParenthesisInvariant (dfsVisit G fuel u s) := by
induction fuel generalizing u s with
| zero => omega
| succ n ih =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hout : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, step, s3]
have hparen1 : ParenthesisInvariant s1 := by
intro x y hx hy hxy
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hyu : y ≠ u := by
intro h
subst y
simp [s1] at hy
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hy0 : s.color y = Color.black := by simpa [s1, hyu] using hy
have h := hparen x y hx0 hy0 hxy
simpa [intervalsLaminar, finishesBeforeDiscovered, intervalNestedInside,
discoveryTime, finishTime, s1, hxu, hyu] using h
have hdt1 : DiscoveryTimeInvariant s1 := by
intro x hx
by_cases hxu : x = u
· subst x
simp [s1, discoveryTime]
· have hx0 : s.color x ≠ Color.white := by simpa [s1, hxu] using hx
have hlt := hdt x hx0
have hd : discoveryTime s1 x = discoveryTime s x := by
simp [s1, discoveryTime, hxu]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hd, ht]
omega
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hbf x hx0
have hf : finishTime s1 x = finishTime s x := by simp [s1, finishTime]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hf, ht]
omega
have hdf1 : DiscoveryFinishInvariant s1 := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hdf x hx0
simpa [s1, discoveryTime, finishTime, hxu] using hlt
have hfold : ∀ (l : List V) (st : DFSState V),
ParenthesisInvariant st →
DiscoveryTimeInvariant st →
(∀ x, st.color x = Color.black → finishTime st x < st.time) →
DiscoveryFinishInvariant st →
let out := List.foldl step st l
ParenthesisInvariant out ∧
DiscoveryTimeInvariant out ∧
(∀ x, out.color x = Color.black → finishTime out x < out.time) ∧
DiscoveryFinishInvariant out := by
intro l
induction l with
| nil =>
intro st hp hdt_st hbf_st hdf_st
exact ⟨hp, hdt_st, hbf_st, hdf_st⟩
| cons w ws ih_fold =>
intro st hp hdt_st hbf_st hdf_st
simp only [List.foldl_cons]
by_cases hw : st.color w = Color.white
· have hp0 : ParenthesisInvariant (st.setParent w u) := by
simpa [ParenthesisInvariant, intervalsLaminar, finishesBeforeDiscovered,
intervalNestedInside, discoveryTime, finishTime] using hp
have hdt0 : DiscoveryTimeInvariant (st.setParent w u) := by
simpa [DiscoveryTimeInvariant, discoveryTime] using hdt_st
have hbf0 : ∀ x, (st.setParent w u).color x = Color.black →
finishTime (st.setParent w u) x < (st.setParent w u).time := by
simpa [finishTime] using hbf_st
have hdf0 : DiscoveryFinishInvariant (st.setParent w u) := by
simpa [DiscoveryFinishInvariant, discoveryTime, finishTime] using hdf_st
by_cases hn : n = 0
· subst n
simp [step, hw, dfsVisit]
exact ih_fold (st.setParent w u) hp0 hdt0 hbf0 hdf0
· have hnpos : 0 < n := by omega
let st' := dfsVisit G n w (st.setParent w u)
have hp' : ParenthesisInvariant st' := by
exact ih hnpos (by simpa using hw) hp0 hdt0 hbf0 hdf0
have hdt' : DiscoveryTimeInvariant st' := by
exact dfsVisit_preserves_discoveryTimeInvariant G hnpos (by simpa using hw)
hdt0 hbf0 hdf0
have hbf' : ∀ x, st'.color x = Color.black → finishTime st' x < st'.time := by
exact dfsVisit_black_finish_lt_time G hnpos (by simpa using hw) hbf0
have hdf' : DiscoveryFinishInvariant st' := by
exact dfsVisit_discovery_lt_finish G hnpos (by simpa using hw) hdf0
have hrest := ih_fold st' hp' hdt' hbf' hdf'
simpa [step, hw, st'] using hrest
· simpa [step, hw] using ih_fold st hp hdt_st hbf_st hdf_st
rcases hfold (G.adj u).toList s1 hparen1 hdt1 hbf1 hdf1 with
⟨hparen2, _hdt2, _hbf2, _hdf2⟩
have hsource : ∀ z, z ≠ u → (dfsVisit G (n + 1) u s).color z = Color.black →
intervalsLaminar (dfsVisit G (n + 1) u s) u z := by
intro z hzu hzblack
by_cases hzwhite : s.color z = Color.white
· have hdisc := dfsVisit_discovery_ge_input_time G (fuel := n + 1)
(u := u) (v := z) (s := s) (by omega) hwhite hzwhite hzblack hzu
have hfinish := dfsVisit_finish_lt_source_finish G (fuel := n + 1)
(u := u) (s := s) (w := z) (by omega) hwhite hbf hzwhite hzblack hzu
have hdu := dfsVisit_discovery_source G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
unfold intervalsLaminar intervalNestedInside
exact Or.inr (Or.inr (Or.inl ⟨by omega, hfinish⟩))
· cases hz : s.color z with
| white => contradiction
| gray =>
have hzgray : s.color z = Color.gray := hz
have hgray_out := dfsVisit_preserves_gray (fuel := n + 1) G hzgray hzu
rw [hgray_out] at hzblack
contradiction
| black =>
have hzblack0 : s.color z = Color.black := hz
have hf_eq : finishTime (dfsVisit G (n + 1) u s) z = finishTime s z := by
dsimp [finishTime]
rw [dfsVisit_preserves_f_of_not_white G hzu (by simp [hzblack0])]
have hdu := dfsVisit_discovery_source G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
unfold intervalsLaminar finishesBeforeDiscovered
exact Or.inr (Or.inl (by rw [hf_eq, hdu]; exact hbf z hzblack0))
intro x y hx hy hxy
by_cases hxu : x = u
· subst x
exact hsource y hxy.symm hy
by_cases hyu : y = u
· subst y
exact intervalsLaminar_symm (hsource x hxu hx)
· have hx2 : s2.color x = Color.black := by
rw [hout] at hx
simpa [s3, hxu] using hx
have hy2 : s2.color y = Color.black := by
rw [hout] at hy
simpa [s3, hyu] using hy
have h := hparen2 x y hx2 hy2 hxy
rw [hout]
simpa [intervalsLaminar, finishesBeforeDiscovered, intervalNestedInside,
discoveryTime, finishTime, s3, hxu, hyu] using hRecursive DFS over a root list preserves the parenthesis invariant.
theorem dfsFromList_preserves_parenthesisInvariant {fuel : Nat} {s0 : DFSState V}
{vs : List V} (hfuel : 0 < fuel)
(hparen : ParenthesisInvariant s0)
(hdt : DiscoveryTimeInvariant s0)
(hbf : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time)
(hdf : DiscoveryFinishInvariant s0) :
ParenthesisInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0 with
| nil => simpa [dfsFromList] using hparen
| cons u us ih =>
simp only [dfsFromList]
by_cases hwhite : s0.color u = Color.white
· rw [if_pos hwhite]
let s1 := dfsVisit G fuel u s0
have hp1 : ParenthesisInvariant s1 :=
dfsVisit_preserves_parenthesisInvariant G hfuel hwhite hparen hdt hbf hdf
have hdt1 : DiscoveryTimeInvariant s1 :=
dfsVisit_preserves_discoveryTimeInvariant G hfuel hwhite hdt hbf hdf
have hbf1 : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time :=
dfsVisit_black_finish_lt_time G hfuel hwhite hbf
have hdf1 : DiscoveryFinishInvariant s1 :=
dfsVisit_discovery_lt_finish G hfuel hwhite hdf
exact ih hp1 hdt1 hbf1 hdf1
· rw [if_neg hwhite]
exact ih hparen hdt hbf hdfDFS parenthesis theorem. The discovery/finish intervals of any two distinct graph vertices are disjoint or one is strictly nested inside the other.
theorem dfs_parenthesis {u v : V} (hu : u ∈ G.vertices) (hv : v ∈ G.vertices)
(hne : u ≠ v) : intervalsLaminar (G.dfs) u v := by
have hfuel : 0 < G.vertices.card + 1 := by omega
have hparen0 : ParenthesisInvariant (dfsInit : DFSState V) := by
intro x y hx
simp [dfsInit] at hx
have hdt0 : DiscoveryTimeInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hbf0 : ∀ x, (dfsInit : DFSState V).color x = Color.black →
finishTime (dfsInit : DFSState V) x < (dfsInit : DFSState V).time := by
intro x hx
simp [dfsInit] at hx
have hdf0 : DiscoveryFinishInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hp : ParenthesisInvariant (G.dfs) := by
simpa [dfs] using
(dfsFromList_preserves_parenthesisInvariant (G := G) (fuel := G.vertices.card + 1)
(s0 := dfsInit) (vs := G.vertices.toList) hfuel hparen0 hdt0 hbf0 hdf0)
exact hp u v (G.dfs_all_black hu) (G.dfs_all_black hv) hneAll graph-vertex pairs are either equal or have laminar DFS intervals.
theorem dfs_parenthesis_cases {u v : V} (hu : u ∈ G.vertices) (hv : v ∈ G.vertices) :
u = v ∨ intervalsLaminar (G.dfs) u v := by
by_cases h : u = v
· exact Or.inl h
· exact Or.inr (dfs_parenthesis G hu hv h)
DFS intervals cannot partially overlap: the endpoint order
d[u] < d[v] < f[u] < f[v] is impossible.
theorem dfs_intervals_not_cross {u v : V} (hu : u ∈ G.vertices) (hv : v ∈ G.vertices) :
¬(discoveryTime (G.dfs) u < discoveryTime (G.dfs) v ∧
discoveryTime (G.dfs) v < finishTime (G.dfs) u ∧
finishTime (G.dfs) u < finishTime (G.dfs) v) := by
intro hcross
have hne : u ≠ v := by
intro h
subst v
omega
have hparen := dfs_parenthesis G hu hv hne
rcases hparen with h | h | h | h
· unfold finishesBeforeDiscovered at h
omega
· unfold finishesBeforeDiscovered at h
have hvdf := G.dfs_discovery_lt_finish hv
omega
· unfold intervalNestedInside at h
omega
· unfold intervalNestedInside at h
omegasection DiscoveryStateExistence of the discovery state
For any vertex discovered during a DFS visit, there is a state just before the recursive call that first discovers it. This state satisfies the black-vertex finish-time invariant and has the discovered vertex white.
The neighbor-processing fold of a DFS visit preserves the discovery-time, black-finish, and discovery<finish invariants.
theorem dfsVisit_fold_preserves_invariants {n : Nat} {u : V} {s1 : DFSState V} {l : List V}
(hdt : DiscoveryTimeInvariant s1)
(hbf : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hdf : DiscoveryFinishInvariant s1) :
DiscoveryTimeInvariant (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) ∧
(∀ v, (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).color v = Color.black →
finishTime (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) v <
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).time) ∧
DiscoveryFinishInvariant (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) := by
induction l generalizing s1 with
| nil => exact ⟨hdt, hbf, hdf⟩
| cons w ws ih =>
simp only [List.foldl_cons]
split_ifs with hw
· let s0 := s1.setParent w u
let s_rec := dfsVisit G n w s0
have hdt0 : DiscoveryTimeInvariant s0 := by
intro z hz
have hz1 : s1.color z ≠ Color.white := by simpa [s0] using hz
have h1 : discoveryTime s0 z = discoveryTime s1 z := by simp [discoveryTime, s0]
have h2 : s0.time = s1.time := by simp [s0]
rw [h1, h2]
exact hdt z hz1
have hbf0 : ∀ v, s0.color v = Color.black → finishTime s0 v < s0.time := by
intro z hz
have hz1 : s1.color z = Color.black := by simpa [s0] using hz
have h1 : finishTime s0 z = finishTime s1 z := by simp [finishTime, s0]
have h2 : s0.time = s1.time := by simp [s0]
rw [h1, h2]
exact hbf z hz1
have hdf0 : DiscoveryFinishInvariant s0 := by
intro z hz
have hz1 : s1.color z = Color.black := by simpa [s0] using hz
have hd : discoveryTime s0 z = discoveryTime s1 z := by simp [discoveryTime, s0]
have hf : finishTime s0 z = finishTime s1 z := by simp [finishTime, s0]
rw [hd, hf]
exact hdf z hz1
have hdt_rec : DiscoveryTimeInvariant s_rec := by
by_cases hn0 : n = 0
· -- n = 0: the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq]
exact hdt0
· exact dfsVisit_preserves_discoveryTimeInvariant G (by omega) (by simpa [s0] using hw) hdt0 hbf0 hdf0
have hbf_rec : ∀ v, s_rec.color v = Color.black → finishTime s_rec v < s_rec.time := by
by_cases hn0 : n = 0
· -- n = 0: the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq]
exact hbf0
· exact dfsVisit_black_finish_lt_time G (by omega) (by simpa [s0] using hw) hbf0
have hdf_rec : DiscoveryFinishInvariant s_rec := by
by_cases hn0 : n = 0
· -- n = 0: the recursive call returns s0 unchanged
have h_eq : s_rec = s0 := by
simp [s_rec, s0, hn0, dfsVisit]
rw [h_eq]
exact hdf0
· exact dfsVisit_discovery_lt_finish G (by omega) (by simpa [s0] using hw) hdf0
exact ih hdt_rec hbf_rec hdf_rec
· exact ih hdt hbf hdf
Projection of dfsVisit_fold_preserves_invariants: the fold
preserves the discovery-time invariant.
theorem dfsVisit_fold_preserves_discoveryTimeInvariant {n : Nat} {u : V}
{s1 : DFSState V} {l : List V}
(hdt : DiscoveryTimeInvariant s1)
(hbf : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hdf : DiscoveryFinishInvariant s1) :
DiscoveryTimeInvariant (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) :=
(dfsVisit_fold_preserves_invariants G hdt hbf hdf).1
Projection of dfsVisit_fold_preserves_invariants: the fold
preserves the black-finish-before-clock invariant.
theorem dfsVisit_fold_preserves_black_finish_lt_time {n : Nat} {u : V}
{s1 : DFSState V} {l : List V}
(hdt : DiscoveryTimeInvariant s1)
(hbf : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hdf : DiscoveryFinishInvariant s1) :
∀ v, (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).color v =
Color.black →
finishTime (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) v <
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).time :=
(dfsVisit_fold_preserves_invariants G hdt hbf hdf).2.1
Projection of dfsVisit_fold_preserves_invariants: the fold
preserves the discovery-before-finish invariant.
theorem dfsVisit_fold_preserves_discoveryFinishInvariant {n : Nat} {u : V}
{s1 : DFSState V} {l : List V}
(hdt : DiscoveryTimeInvariant s1)
(hbf : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hdf : DiscoveryFinishInvariant s1) :
DiscoveryFinishInvariant (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l) :=
(dfsVisit_fold_preserves_invariants G hdt hbf hdf).2.2
Variant of dfsVisit_fold_blackens_loc_prefix that also guarantees
the accumulator satisfies the discovery-time invariant.
theorem dfsVisit_fold_blackens_loc_prefix_full {n : Nat} {u v : V} {s1 : DFSState V}
(hinv : ∀ v, s1.color v = Color.black → finishTime s1 v < s1.time)
(hdt : DiscoveryTimeInvariant s1)
(hdf : DiscoveryFinishInvariant s1)
(hwhite_v1 : s1.color v = Color.white)
(hfold_black : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList).color v = Color.black) :
∃ (pre post : List V) (w : V) (s2 : DFSState V),
(G.adj u).toList = pre ++ w :: post ∧
s2 = List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 pre ∧
s2.color w = Color.white ∧
s2.color v = Color.white ∧
(dfsVisit G n w (s2.setParent w u)).color v = Color.black ∧
(∀ z, s2.color z = Color.white → s1.color z = Color.white) ∧
(∀ z, s2.color z = Color.black → finishTime s2 z < s2.time) ∧
DiscoveryTimeInvariant s2 := by
rcases dfsVisit_fold_blackens_loc_prefix G hinv hwhite_v1 hfold_black
with ⟨pre, post, w, s2, heq, hs2, h2w, h2v, h2b, h2mono, h2inv⟩
have hdt2 : DiscoveryTimeInvariant s2 := by
rw [hs2]
exact dfsVisit_fold_preserves_discoveryTimeInvariant G hdt hinv hdf
exact ⟨pre, post, w, s2, heq, hs2, h2w, h2v, h2b, h2mono, h2inv, hdt2⟩
Discovery times of black vertices are preserved by any further
dfsFromList.
theorem dfsFromList_preserves_d_of_black {fuel : Nat} {s0 : DFSState V} {vs : List V}
(_hfuel : 0 < fuel) {x : V}
(hblack : s0.color x = Color.black) :
(dfsFromList G fuel vs s0).d x = s0.d x := by
induction vs generalizing s0 with
| nil => simp [dfsFromList]
| cons u us ih =>
simp [dfsFromList]
split_ifs with hwhite
· have hne : x ≠ u := by
intro h
rw [h] at hblack
simp [hblack] at hwhite
have hblack' : (dfsVisit G fuel u s0).color x = Color.black :=
dfsVisit_preserves_black G hblack
have hd : (dfsVisit G fuel u s0).d x = s0.d x := by
have hnw : s0.color x ≠ Color.white := by simp [hblack]
exact dfsVisit_preserves_d_of_not_white G hne hnw
have h1 := ih (s0 := dfsVisit G fuel u s0) hblack'
rw [h1, hd]
· exact ih hblack
If a vertex is white at the beginning of a dfsFromList prefix and black at
its end, then its discovery time in the final state is at least the initial
clock value.
theorem dfsFromList_discovery_ge_of_white {fuel : Nat} {s0 : DFSState V} {vs : List V} {c : V}
(hfuel : 0 < fuel)
(hwhite : s0.color c = Color.white)
(hblack : (dfsFromList G fuel vs s0).color c = Color.black) :
discoveryTime (dfsFromList G fuel vs s0) c ≥ s0.time := by
induction vs generalizing s0 with
| nil =>
simp [dfsFromList] at hblack
rw [hwhite] at hblack
contradiction
| cons u us ih =>
simp [dfsFromList] at hblack ⊢
by_cases hwhite_u : s0.color u = Color.white
· simp [hwhite_u] at hblack ⊢
let s1 := dfsVisit G fuel u s0
by_cases hc : s1.color c = Color.black
· -- `c` is discovered during the visit from `u`
have hdisc_s1 : discoveryTime s1 c ≥ s0.time := by
by_cases hcu : c = u
· rw [hcu]
have heq := dfsVisit_discovery_source G hfuel hwhite_u
simp [s1] at heq ⊢
linarith
· have hge : discoveryTime s1 c ≥ s0.time + 1 :=
dfsVisit_discovery_ge_input_time G hfuel hwhite_u hwhite hc hcu
linarith
have hdisc_final : discoveryTime (dfsFromList G fuel us s1) c = discoveryTime s1 c := by
have h1 : (dfsFromList G fuel us s1).d c = s1.d c :=
dfsFromList_preserves_d_of_black G hfuel hc
simp [discoveryTime, h1]
linarith [hdisc_final, hdisc_s1]
· -- `c` stays white through the visit from `u`
have hwhite' : s1.color c = Color.white :=
dfsVisit_white_stays_white_or_black G hwhite hc
have h1 := ih (s0 := s1) hwhite' hblack
have h2 : s1.time ≥ s0.time := G.dfsVisit_time_ge (fuel := fuel) (u := u) (s := s0)
linarith
· simp [hwhite_u] at hblack ⊢
exact ih hwhite hblackThe set of vertices that are white in a DFS state.
noncomputable def whiteVertices (s : DFSState V) : Finset V :=
G.vertices.filter (fun w => s.color w = Color.white)A non-trivial white-reachable path stays inside the vertex set.
theorem whiteReachable_source_mem_vertices {u v : V} {s : DFSState V}
(hr : WhiteReachable G s u v) (hne : v ≠ u) : u ∈ G.vertices := by
have h : u = v ∨ u ∈ G.vertices := by
induction hr using Relation.ReflTransGen.head_induction_on with
| refl =>
left
rfl
| head h' _ _ =>
right
exact G.adj_mem_left h'.1
cases h with
| inl h_eq => exfalso; exact hne h_eq.symm
| inr h_mem => exact h_mem
Inside a dfsVisit from a white source u, any white-reachable
vertex v has a discovery state: a state just before a recursive call on
v in which v is white, the black-vertex finish-time invariant
holds, and every gray vertex reaches v (they are ancestors on the
recursion stack).
theorem dfsVisit_discovery_state {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hinv : ∀ v, s.color v = Color.black → finishTime s v < s.time)
(hb : (dfsVisit G fuel u s).color v = Color.black)
(hw : WhiteReachable G s u v) (hv : s.color v = Color.white)
(hgray : ∀ w, s.color w = Color.gray → G.Reachable w u) :
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) := by
by_cases hvu : v = u
· -- `v` is the source itself; the current state is already the discovery state
subst v
exact ⟨s, fuel, hwhite, hb, hinv, hgray⟩
generalize hk : (whiteVertices G s).card = k
have hgoal : ∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) := by
have hP : ∀ (k : Nat) (fuel : Nat) (u v : V) (s : DFSState V),
(whiteVertices G s).card = k →
0 < fuel → s.color u = Color.white →
(∀ v, s.color v = Color.black → finishTime s v < s.time) →
(dfsVisit G fuel u s).color v = Color.black →
WhiteReachable G s u v → s.color v = Color.white →
(∀ w, s.color w = Color.gray → G.Reachable w u) →
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) := by
intro k
induction k using Nat.strongRecOn with
| ind k ih =>
intro fuel u v s hk hfuel hwhite hinv hb hw hv hgray
cases fuel with
| zero => linarith
| succ n =>
by_cases h' : v = u
· -- `v` is the source itself; the current state is already the discovery state
subst v
exact ⟨s, n + 1, hwhite, hb, hinv, hgray⟩
· -- `v` is a proper descendant, so it is blackened inside the fold
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, step, dfsVisit, hwhite]
have hv_s3 : s3.color v = Color.black := by
rw [← heq_state]
exact hb
have hfold_black : s2.color v = Color.black := by
simp [s3] at hv_s3
exact hv_s3 h'
have hwhite_v_s1 : s1.color v = Color.white := by
simp [s1]
rw [if_neg h']
exact hv
have hinv_s1 : ∀ z, s1.color z = Color.black → finishTime s1 z < s1.time := by
intro z hz
have hne_zu : z ≠ u := by
intro h
subst z
simp [s1] at hz
have h1 : finishTime s1 z = finishTime s z := by
simp [finishTime, s1]
have h2 : s1.time = s.time + 1 := by
simp [s1]
have h3 : finishTime s z < s.time := hinv z (by simpa [s1, hne_zu] using hz)
rw [h1, h2]
linarith
have hloc := dfsVisit_fold_blackens_loc_prefix G hinv_s1 hwhite_v_s1 hfold_black
rcases hloc with ⟨pre, post, w, s2', heq, hs2, hwhite_w, hwhite_v, hblack_v, hmono, hinv_s2'⟩
let s_input := s2'.setParent w u
have hwhite_w_input : s_input.color w = Color.white := by
simp [s_input, hwhite_w]
have hwhite_v_input : s_input.color v = Color.white := by
simp [s_input, hwhite_v]
have hblack_v_input : (dfsVisit G n w s_input).color v = Color.black := by
simpa [s_input] using hblack_v
have hn_pos : 0 < n := by
by_contra h
have : n = 0 := by omega
subst n
simp [dfsVisit] at hblack_v_input
rw [hwhite_v_input] at hblack_v_input
contradiction
have hwreach : WhiteReachable G s_input w v := by
apply dfsVisit_blackens_implies_whiteReachable
· exact hwhite_w_input
· exact hn_pos
· exact hwhite_v_input
· exact hblack_v_input
have hinv_input : ∀ z, s_input.color z = Color.black → finishTime s_input z < s_input.time := by
intro z hz
have hz2 : s2'.color z = Color.black := by
simpa [s_input] using hz
have h1 := hinv_s2' z hz2
simp [s_input] at h1 ⊢
exact h1
have hgray_input : ∀ z, s_input.color z = Color.gray → G.Reachable z w := by
intro z hz
have hz2 : s2'.color z = Color.gray := by
simpa [s_input] using hz
have hz1 : s1.color z = Color.gray := by
rw [hs2] at hz2
exact dfsVisit_fold_no_new_gray G s1 hz2
have h1 : z = u ∨ s.color z = Color.gray := by
by_cases hzu : z = u
· left; exact hzu
· right
simp [s1, hzu] at hz1
exact hz1
rcases h1 with (hzu | hz_gray)
· subst z
have hadj_uw : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
exact Relation.ReflTransGen.single hadj_uw
· have hzu : G.Reachable z u := hgray z hz_gray
have hadj_uw : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
exact Relation.ReflTransGen.trans hzu (Relation.ReflTransGen.single hadj_uw)
have hcard : (whiteVertices G s_input).card < k := by
have hk' : k = (whiteVertices G s).card := by rw [hk]
have hsub : whiteVertices G s_input ⊆ whiteVertices G s := by
intro x hx
simp [whiteVertices] at hx ⊢
constructor
· exact hx.1
· have h1 : s_input.color x = Color.white := hx.2
have h2 : s2'.color x = Color.white := by
simpa [s_input] using h1
have h3 : s2'.color x = Color.white → s1.color x = Color.white := hmono x
have h4 : s1.color x = Color.white := h3 h2
have hxu : x ≠ u := by
intro h
subst x
have : s_input.color u = Color.white := h1
simp [s_input] at this
have : s2'.color u = Color.white := by
simpa [s_input] using this
have : s1.color u = Color.white := hmono u this
simp [s1] at this
simp [s1, hxu] at h4
exact h4
have hu_notin : u ∉ whiteVertices G s_input := by
simp [whiteVertices, s_input]
intro hmem hwhite_u
have : s2'.color u = Color.white := by
simpa [s_input] using hwhite_u
have : s1.color u = Color.white := hmono u this
simp [s1] at this
have hu_mem : u ∈ G.vertices := whiteReachable_source_mem_vertices G hw h'
have hu_in : u ∈ whiteVertices G s := by
simp [whiteVertices, hwhite, hu_mem]
have hlt := Finset.card_lt_card (Finset.ssubset_iff_subset_ne.mpr ⟨hsub, fun heq => hu_notin (heq ▸ hu_in)⟩)
linarith
exact ih (whiteVertices G s_input).card hcard n w v s_input (by rfl) hn_pos hwhite_w_input hinv_input hblack_v_input hwreach hwhite_v_input hgray_input
exact hP k fuel u v s hk hfuel hwhite hinv hb hw hv hgray
exact hgoal
Variant of dfsVisit_discovery_state that also guarantees the
recursive fuel is large enough to blacken the whole white-reachable set of the
discovered vertex.
theorem dfsVisit_discovery_state_with_fuel {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1)
(hwhite : s.color u = Color.white)
(hinv : ∀ v, s.color v = Color.black → finishTime s v < s.time)
(hb : (dfsVisit G fuel u s).color v = Color.black)
(hw : WhiteReachable G s u v) (hv : s.color v = Color.white)
(hgray : ∀ w, s.color w = Color.gray → G.Reachable w u) :
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) ∧
fuel' ≥ (whiteReachableSet G s' v).card + 1 := by
by_cases hvu : v = u
· -- `v` is the source itself; the current state is already the discovery state
subst v
exact ⟨s, fuel, hwhite, hb, hinv, hgray, hfuel⟩
generalize hk : (whiteVertices G s).card = k
have hgoal : ∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) ∧
fuel' ≥ (whiteReachableSet G s' v).card + 1 := by
have hP : ∀ (k : Nat) (fuel : Nat) (u v : V) (s : DFSState V),
(whiteVertices G s).card = k →
fuel ≥ (whiteReachableSet G s u).card + 1 →
s.color u = Color.white →
(∀ v, s.color v = Color.black → finishTime s v < s.time) →
(dfsVisit G fuel u s).color v = Color.black →
WhiteReachable G s u v → s.color v = Color.white →
(∀ w, s.color w = Color.gray → G.Reachable w u) →
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) ∧
fuel' ≥ (whiteReachableSet G s' v).card + 1 := by
intro k
induction k using Nat.strongRecOn with
| ind k ih =>
intro fuel u v s hk hfuel_bound hwhite hinv hb hw hv hgray
cases fuel with
| zero => linarith
| succ n =>
by_cases h' : v = u
· -- `v` is the source itself; the current state is already the discovery state
subst v
exact ⟨s, n + 1, hwhite, hb, hinv, hgray, hfuel_bound⟩
· -- `v` is a proper descendant, so it is blackened inside the fold
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, step, dfsVisit, hwhite]
have hv_s3 : s3.color v = Color.black := by
rw [← heq_state]
exact hb
have hfold_black : s2.color v = Color.black := by
simp [s3] at hv_s3
exact hv_s3 h'
have hwhite_v_s1 : s1.color v = Color.white := by
simp [s1]
rw [if_neg h']
exact hv
have hinv_s1 : ∀ z, s1.color z = Color.black → finishTime s1 z < s1.time := by
intro z hz
have hne_zu : z ≠ u := by
intro h
subst z
simp [s1] at hz
have h1 : finishTime s1 z = finishTime s z := by
simp [finishTime, s1]
have h2 : s1.time = s.time + 1 := by
simp [s1]
have h3 : finishTime s z < s.time := hinv z (by simpa [s1, hne_zu] using hz)
rw [h1, h2]
linarith
have hloc := dfsVisit_fold_blackens_loc_prefix G hinv_s1 hwhite_v_s1 hfold_black
rcases hloc with ⟨pre, post, w, s2', heq, hs2, hwhite_w, hwhite_v, hblack_v, hmono, hinv_s2'⟩
let s_input := s2'.setParent w u
have hwhite_w_input : s_input.color w = Color.white := by
simp [s_input, hwhite_w]
have hwhite_v_input : s_input.color v = Color.white := by
simp [s_input, hwhite_v]
have hblack_v_input : (dfsVisit G n w s_input).color v = Color.black := by
simpa [s_input] using hblack_v
have hn_pos : 0 < n := by
by_contra h
have : n = 0 := by omega
subst n
simp [dfsVisit] at hblack_v_input
rw [hwhite_v_input] at hblack_v_input
contradiction
have hwreach : WhiteReachable G s_input w v := by
apply dfsVisit_blackens_implies_whiteReachable
· exact hwhite_w_input
· exact hn_pos
· exact hwhite_v_input
· exact hblack_v_input
have hinv_input : ∀ z, s_input.color z = Color.black → finishTime s_input z < s_input.time := by
intro z hz
have hz2 : s2'.color z = Color.black := by
simpa [s_input] using hz
have h1 := hinv_s2' z hz2
simp [s_input] at h1 ⊢
exact h1
have hgray_input : ∀ z, s_input.color z = Color.gray → G.Reachable z w := by
intro z hz
have hz2 : s2'.color z = Color.gray := by
simpa [s_input] using hz
have hz1 : s1.color z = Color.gray := by
rw [hs2] at hz2
exact dfsVisit_fold_no_new_gray G s1 hz2
have h1 : z = u ∨ s.color z = Color.gray := by
by_cases hzu : z = u
· left; exact hzu
· right
simp [s1, hzu] at hz1
exact hz1
rcases h1 with (hzu | hz_gray)
· subst z
have hadj_uw : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
exact Relation.ReflTransGen.single hadj_uw
· have hzu : G.Reachable z u := hgray z hz_gray
have hadj_uw : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
exact Relation.ReflTransGen.trans hzu (Relation.ReflTransGen.single hadj_uw)
have hcard : (whiteVertices G s_input).card < k := by
have hk' : k = (whiteVertices G s).card := by rw [hk]
have hsub : whiteVertices G s_input ⊆ whiteVertices G s := by
intro x hx
simp [whiteVertices] at hx ⊢
constructor
· exact hx.1
· have h1 : s_input.color x = Color.white := hx.2
have h2 : s2'.color x = Color.white := by
simpa [s_input] using h1
have h3 : s2'.color x = Color.white → s1.color x = Color.white := hmono x
have h4 : s1.color x = Color.white := h3 h2
have hxu : x ≠ u := by
intro h
subst x
have : s_input.color u = Color.white := h1
simp [s_input] at this
have : s2'.color u = Color.white := by
simpa [s_input] using this
have : s1.color u = Color.white := hmono u this
simp [s1] at this
simp [s1, hxu] at h4
exact h4
have hu_notin : u ∉ whiteVertices G s_input := by
simp [whiteVertices, s_input]
intro hmem hwhite_u
have : s2'.color u = Color.white := by
simpa [s_input] using hwhite_u
have : s1.color u = Color.white := hmono u this
simp [s1] at this
have hu_mem : u ∈ G.vertices := whiteReachable_source_mem_vertices G hw h'
have hu_in : u ∈ whiteVertices G s := by
simp [whiteVertices, hwhite, hu_mem]
have hlt := Finset.card_lt_card (Finset.ssubset_iff_subset_ne.mpr ⟨hsub, fun heq => hu_notin (heq ▸ hu_in)⟩)
linarith
have hwV : w ∈ G.vertices := by
have hadj_w : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
exact G.adj_mem_right hadj_w
have hfuel_input : n ≥ (whiteReachableSet G s_input w).card + 1 := by
have hsub : whiteReachableSet G s_input w ⊆ whiteReachableSet G s u := by
intro x hx
have hxw : WhiteReachable G s_input w x := (mem_whiteReachableSet_iff G hwV).mp hx
have hxu : WhiteReachable G s u x := by
have hwu : WhiteReachable G s u w := by
have hadj_uw : G.Adj u w := by
have hwmem : w ∈ (G.adj u).toList := by
rw [heq]
simp
simp [Finset.mem_toList] at hwmem
exact hwmem
have hwhite_w_s : s.color w = Color.white := by
have h1 : s1.color w = Color.white := hmono w hwhite_w
have hwu : w ≠ u := by
intro heq
rw [heq] at h1
simp [s1] at h1
simp [s1, hwu] at h1
exact h1
exact whiteReachable_step G (whiteReachable_refl G s u) hadj_uw hwhite_w_s
have hwx : WhiteReachable G s_input w x := hxw
have hwx' : WhiteReachable G s w x := by
have hcolors : ∀ x, s_input.color x = Color.white → s.color x = Color.white := by
intro x hx
have h1 : s2'.color x = Color.white := by
have : s_input.color x = Color.white := hx
simpa [s_input] using this
have h2 : s1.color x = Color.white := hmono x h1
have hxu : x ≠ u := by
intro heq
rw [heq] at h2
simp [s1] at h2
simp [s1, hxu] at h2
exact h2
apply whiteReachable_mono_of_color_superset G hcolors hwx
exact whiteReachable_trans G hwu hwx'
exact (mem_whiteReachableSet_iff G (whiteReachable_source_mem_vertices G hw h')).mpr hxu
have hne : u ∉ whiteReachableSet G s_input w := by
intro hu_in
have hwhite_u : WhiteReachable G s_input w u := (mem_whiteReachableSet_iff G hwV).mp hu_in
have hcolor_u : s_input.color u = Color.white := whiteReachable_target_white G hwhite_w_input hwhite_u
have hs2'_gray_u : s2'.color u = Color.gray := by
rw [hs2]
let step := fun (s' : DFSState V) (v : V) =>
if s'.color v = Color.white then dfsVisit G n v (s'.setParent v u) else s'
have hfold : ∀ (pre : List V) (s' : DFSState V),
s'.color u = Color.gray →
(List.foldl step s' pre).color u = Color.gray := by
intro pre s' hs'
induction pre generalizing s' with
| nil => simpa
| cons v vs ih' =>
simp [step]
by_cases hv : s'.color v = Color.white
· simp [hv]
apply ih' (dfsVisit G n v (s'.setParent v u))
have hsp : (s'.setParent v u).color u = Color.gray := by simp [hs']
have hne : u ≠ v := by
intro heq
rw [← heq] at hv
have hcontra : Color.gray = Color.white := by
rw [← hs', hv]
cases hcontra
exact dfsVisit_preserves_gray G hsp hne
· simp [hv]
exact ih' s' hs'
exact hfold pre s1 (by simp [s1])
have hgray_u : s_input.color u = Color.gray := by
have h1 : s2'.color u = Color.gray := hs2'_gray_u
simp [s_input, h1]
rw [hgray_u] at hcolor_u
exact Color.noConfusion hcolor_u
have hcard1 : (whiteReachableSet G s_input w).card ≤ (whiteReachableSet G s u).card - 1 := by
have hfin : (whiteReachableSet G s_input w).card < (whiteReachableSet G s u).card := by
apply Finset.card_lt_card
apply Finset.ssubset_iff_subset_ne.mpr ⟨hsub, fun heq => hne (heq ▸ by
have : u ∈ whiteReachableSet G s u := by
apply (mem_whiteReachableSet_iff G (whiteReachable_source_mem_vertices G hw h')).mpr
exact whiteReachable_refl G s u
exact this)⟩
omega
have hcard2 : (whiteReachableSet G s u).card ≤ n := by
omega
omega
exact ih (whiteVertices G s_input).card hcard n w v s_input (by rfl) hfuel_input hwhite_w_input hinv_input hblack_v_input hwreach hwhite_v_input hgray_input
exact hP k fuel u v s hk hfuel hwhite hinv hb hw hv hgray
exact hgoal
A fuel-aware version of the discovery-state theorem for dfsFromList: it
also guarantees that the recursive fuel chosen for the discovered vertex is
large enough to blacken its whole white-reachable set.
theorem dfsFromList_discovery_state_with_fuel {fuel : Nat} {s0 : DFSState V} {vs : List V} {v : V}
(hfuel : fuel ≥ G.vertices.card + 1)
(hvs : ∀ x ∈ vs, x ∈ G.vertices)
(hinv0 : ∀ w, s0.color w = Color.black → finishTime s0 w < s0.time)
(hwhite0 : s0.color v = Color.white)
(hblack : (dfsFromList G fuel vs s0).color v = Color.black)
(hng0 : ∀ w, s0.color w = Color.gray → False) :
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) ∧
fuel' ≥ (whiteReachableSet G s' v).card + 1 := by
induction vs generalizing s0 with
| nil =>
simp [dfsFromList] at hblack
rw [hwhite0] at hblack
contradiction
| cons u us ih =>
have hfuel_pos : 0 < fuel := by omega
simp [dfsFromList] at hblack
by_cases hwhite_u : s0.color u = Color.white
· simp [hwhite_u] at hblack
let s1 := dfsVisit G fuel u s0
by_cases hc : s1.color v = Color.black
· -- `v` is discovered during the visit from `u`
have hwr : WhiteReachable G s0 u v := by
apply dfsVisit_blackens_implies_whiteReachable
· exact hwhite_u
· exact hfuel_pos
· exact hwhite0
· exact hc
have hgray_u : ∀ w, s0.color w = Color.gray → G.Reachable w u := by
intro w hw
exfalso
exact hng0 w hw
have hfuel_visit : fuel ≥ (whiteReachableSet G s0 u).card + 1 := by
have hsub : whiteReachableSet G s0 u ⊆ G.vertices :=
whiteReachableSet_subset_vertices G s0 u (hvs u (by simp))
have hcard : (whiteReachableSet G s0 u).card ≤ G.vertices.card :=
Finset.card_le_card hsub
omega
exact dfsVisit_discovery_state_with_fuel G hfuel_visit hwhite_u hinv0 hc hwr hwhite0 hgray_u
· -- `v` stays white through the visit from `u`
have hwhite' : s1.color v = Color.white :=
dfsVisit_white_stays_white_or_black G hwhite0 hc
have hinv1 : ∀ w, s1.color w = Color.black → finishTime s1 w < s1.time := by
apply dfsVisit_black_finish_lt_time G hfuel_pos hwhite_u hinv0
have hng1 : ∀ w, s1.color w = Color.gray → False := by
have hno_gray : ∀ w, s1.color w = Color.white ∨ s1.color w = Color.black := by
apply dfsVisit_output_no_gray
intro w
have h : s0.color w = Color.white ∨ s0.color w = Color.black := by
by_cases hg : s0.color w = Color.gray
· exfalso; exact hng0 w hg
· cases hcol : s0.color w with
| white => simp
| gray => contradiction
| black => simp
cases h <;> simp [*]
intro w hw
have := hno_gray w
simp [hw] at this
have hvs' : ∀ x ∈ us, x ∈ G.vertices := by
intro x hx
exact hvs x (by simp [hx])
exact ih (s0 := s1) hvs' hinv1 hwhite' hblack hng1
· simp [hwhite_u] at hblack
have hvs' : ∀ x ∈ us, x ∈ G.vertices := by
intro x hx
exact hvs x (by simp [hx])
exact ih hvs' hinv0 hwhite0 hblack hng0end DiscoveryStatetheorem IsDFSAncestor.trans {s : DFSState V} {u v w : V}
(huv : IsDFSAncestor s u v) (hvw : IsDFSAncestor s v w) :
IsDFSAncestor s u w :=
Relation.ReflTransGen.trans huv hvwtheorem IsDFSAncestor.single {s : DFSState V} {u v : V}
(hparent : s.parent v = some u) : IsDFSAncestor s u v :=
Relation.ReflTransGen.single hparentA parent edge recorded by any DFS computation is always a graph edge.
theorem dfsFromList_preserves_parent_edge {fuel : Nat} {s0 : DFSState V} {vs : List V}
(hinv : ∀ u v, s0.parent v = some u → G.Adj u v) :
∀ u v, (dfsFromList G fuel vs s0).parent v = some u →
G.Adj u v := by
induction vs generalizing s0 with
| nil =>
intro u v hparent
simpa [dfsFromList] using hinv u v hparent
| cons u us ih =>
intro x y hparent
simp [dfsFromList] at hparent
by_cases hwhite : s0.color u = Color.white
· rw [if_pos hwhite] at hparent
have hinv' : ∀ x y, (dfsVisit G fuel u s0).parent y = some x → G.Adj x y :=
dfsVisit_preserves_parent_edge G hinv
exact ih hinv' x y hparent
· rw [if_neg hwhite] at hparent
exact ih hinv x y hparentEvery parent pointer in the final DFS forest records a graph edge.
theorem dfs_parent_edge {u v : V} (hparent : (G.dfs).parent v = some u) :
G.Adj u v := by
have hinv_init : ∀ x y, (dfsInit (V := V)).parent y = some x → G.Adj x y := by
intro x y h
simp [dfsInit] at h
simpa [dfs] using
(dfsFromList_preserves_parent_edge (G := G) (fuel := G.vertices.card + 1)
(s0 := dfsInit) (vs := G.vertices.toList) hinv_init u v hparent)Every DFS ancestor in the full DFS forest is reachable in the graph.
theorem IsDFSAncestor_reachable {u v : V}
(h : IsDFSAncestor (G.dfs) u v) : G.Reachable u v := by
induction h with
| refl =>
exact G.reachable_refl u
| tail hxy hyz ih =>
exact G.reachable_trans ih (G.reachable_adj (dfs_parent_edge G hyz))end Intervalssection WhitePathTheoremWhite-path theorem
The white-path theorem characterises DFS descendants by the existence of a monochromatic (white) path at the moment the ancestor is discovered.
A DFS visit preserves the parent of a vertex that is not white and not the source.
theorem dfsVisit_preserves_parent_of_not_white {fuel : Nat} {u x : V} {s : DFSState V}
(hne : x ≠ u) (hnw : s.color x ≠ Color.white) :
(dfsVisit G fuel u s).parent x = s.parent x := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· -- u is white: process it and its neighbors
let s1 := s.setColor u Color.gray |>.setDiscovery u
let s2 := List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have h_eq : (dfsVisit G (n + 1) u s).parent x = s3.parent x := by
simp [dfsVisit, hwhite, s1, s2, s3]
rw [h_eq]
have h1 : s1.parent x = s.parent x := by simp [s1]
have h2 : s2.parent x = s1.parent x := by
have hfold : ∀ (l : List V) (s' : DFSState V),
s'.parent x = s1.parent x ∧ s'.color x ≠ Color.white →
(List.foldl (fun (s'' : DFSState V) (w : V) =>
if s''.color w = Color.white then dfsVisit G n w (s''.setParent w u) else s'') s' l).parent x = s1.parent x := by
intro l s' hs'
induction l generalizing s' with
| nil => simpa using hs'.1
| cons w ws ih' =>
simp
by_cases hw : s'.color w = Color.white
· simp [hw]
apply ih'
constructor
· have hne' : x ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hsp : (s'.setParent w u).parent x = s'.parent x := by
simp [hne']
have hnw' : (s'.setParent w u).color x ≠ Color.white := by simpa using hs'.2
have hrec : (dfsVisit G n w (s'.setParent w u)).parent x = (s'.setParent w u).parent x :=
ih (u := w) (s := s'.setParent w u) hne' hnw'
rw [hrec, hsp]
exact hs'.1
· have hne' : x ≠ w := by
by_contra h
rw [h] at hs'
exact hs'.2 hw
have hnw' : (s'.setParent w u).color x ≠ Color.white := by simpa using hs'.2
exact dfsVisit_preserves_not_white (fuel := n) G hne' hnw'
· simp [hw]
exact ih' s' hs'
have hs1 : s1.parent x = s1.parent x ∧ s1.color x ≠ Color.white := by
constructor
· rfl
· simpa [s1, hne] using hnw
exact hfold (G.adj u).toList s1 hs1
have h3 : s3.parent x = s2.parent x := by
simp [s3]
rw [h3, h2, h1]
· -- u is not white: state unchanged
simp [dfsVisit, hwhite]The inner fold of a DFS visit preserves the parent of any vertex that is already non-white.
theorem dfsVisit_fold_preserves_parent_of_not_white {n : Nat} {u x : V}
(s1 : DFSState V) {l : List V} (hnw : s1.color x ≠ Color.white) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s')
s1 l).parent x = s1.parent x := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : x ≠ w := by
intro h
subst x
exact hnw hw
have hnw_parent : (s1.setParent w u).color x ≠ Color.white := by
simpa using hnw
have hrec_parent :
(dfsVisit G n w (s1.setParent w u)).parent x = (s1.setParent w u).parent x :=
dfsVisit_preserves_parent_of_not_white G hne hnw_parent
have hrec_nw : (dfsVisit G n w (s1.setParent w u)).color x ≠ Color.white :=
dfsVisit_preserves_not_white G hne hnw_parent
have hfold := ih (dfsVisit G n w (s1.setParent w u)) hrec_nw
rw [hfold, hrec_parent]
simp [hne]
· simp [hw]
exact ih s1 hnwA DFS visit never changes the parent pointer of its own source.
theorem dfsVisit_parent_source {fuel : Nat} {u : V} {s : DFSState V} :
(dfsVisit G fuel u s).parent u = s.parent u := by
cases fuel with
| zero => simp [dfsVisit]
| succ n =>
by_cases hwhite : s.color u = Color.white
· let s1 := s.setColor u Color.gray |>.setDiscovery u
have hnw : s1.color u ≠ Color.white := by simp [s1]
have hfold := dfsVisit_fold_preserves_parent_of_not_white
(G := G) (n := n) (u := u) (x := u) s1 (l := (G.adj u).toList) hnw
simp [dfsVisit, hwhite]
simpa [s1] using hfold
· simp [dfsVisit, hwhite]The inner fold of a DFS visit preserves the parent of any already-black vertex.
theorem dfsVisit_fold_preserves_parent_of_black {n : Nat} {u x : V} (s1 : DFSState V) {l : List V}
(hb : s1.color x = Color.black) :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 l).parent x = s1.parent x := by
induction l generalizing s1 with
| nil => simp
| cons w ws ih =>
simp
by_cases hw : s1.color w = Color.white
· simp [hw]
have hne : x ≠ w := by
intro h
rw [h] at hb
simp [hw] at hb
have hblack' : (s1.setParent w u).color x = Color.black := by simp [hb]
have hrec_black : (dfsVisit G n w (s1.setParent w u)).color x = Color.black :=
dfsVisit_preserves_black G hblack'
have hsp : (s1.setParent w u).parent x = s1.parent x := by
simp [hne]
have hrec_parent : (dfsVisit G n w (s1.setParent w u)).parent x = (s1.setParent w u).parent x :=
dfsVisit_preserves_parent_of_not_white G hne (by rw [hblack']; decide)
have hfold := ih (dfsVisit G n w (s1.setParent w u)) hrec_black
rw [hfold, hrec_parent, hsp]
· simp [hw]
exact ih s1 hbRecursive DFS over a list preserves the parent of any already-black vertex.
theorem dfsFromList_preserves_parent_of_black {fuel : Nat} {s0 : DFSState V} {vs : List V} {x : V}
(_hfuel : 0 < fuel)
(hblack : s0.color x = Color.black) :
(dfsFromList G fuel vs s0).parent x = s0.parent x := by
induction vs generalizing s0 with
| nil => simp [dfsFromList]
| cons u us ih =>
simp [dfsFromList]
split_ifs with hwhite
· have hne : x ≠ u := by
intro h
rw [h] at hblack
simp [hblack] at hwhite
have hblack' : (dfsVisit G fuel u s0).color x = Color.black :=
dfsVisit_preserves_black G hblack
have hp : (dfsVisit G fuel u s0).parent x = s0.parent x := by
have hnw : s0.color x ≠ Color.white := by simp [hblack]
exact dfsVisit_preserves_parent_of_not_white G hne hnw
have h1 := ih (s0 := dfsVisit G fuel u s0) hblack'
rw [h1, hp]
· exact ih hblackIf a DFS visit blackens a vertex that was white at the start, the visit source is an ancestor of that vertex in the output parent forest. The strengthened result records that every child along the parent chain is black.
theorem dfsVisit_blackens_implies_blackAncestor {fuel : Nat} {u v : V} {s : DFSState V}
(hwhite_u : s.color u = Color.white)
(hbf : ∀ x, s.color x = Color.black → finishTime s x < s.time)
(hwhite_v : s.color v = Color.white)
(hblack_v : (dfsVisit G fuel u s).color v = Color.black) :
IsBlackDFSAncestor (dfsVisit G fuel u s) u v := by
induction fuel generalizing u v s with
| zero =>
simp [dfsVisit] at hblack_v
rw [hwhite_v] at hblack_v
contradiction
| succ n ih =>
by_cases hvu : v = u
· subst v
exact Relation.ReflTransGen.refl
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (st : DFSState V) (w : V) =>
if st.color w = Color.white then dfsVisit G n w (st.setParent w u) else st
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hout : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite_u, s1, s2, step, s3]
have hwhite_v1 : s1.color v = Color.white := by
simp [s1, hvu, hwhite_v]
have hfold_black : s2.color v = Color.black := by
rw [hout] at hblack_v
simpa [s3, hvu] using hblack_v
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hbf x hx0
have hf : finishTime s1 x = finishTime s x := by simp [s1, finishTime]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hf, ht]
omega
have hfold_black' :
(List.foldl (fun (st : DFSState V) (w : V) =>
if st.color w = Color.white then dfsVisit G n w (st.setParent w u) else st)
s1 (G.adj u).toList).color v = Color.black := by
simpa [s2, step] using hfold_black
rcases dfsVisit_fold_blackens_loc_prefix G hbf1 hwhite_v1 hfold_black' with
⟨pre, post, w, st, hadj, hst, hwhite_w, hwhite_v_st, hrec_black,
_hmono, hbf_st⟩
have hnpos : 0 < n := by
by_contra hn
have hn0 : n = 0 := by omega
subst n
simp [dfsVisit] at hrec_black
rw [hwhite_v_st] at hrec_black
contradiction
let sin := st.setParent w u
let sout := dfsVisit G n w sin
have hwhite_w_in : sin.color w = Color.white := by simp [sin, hwhite_w]
have hwhite_v_in : sin.color v = Color.white := by simp [sin, hwhite_v_st]
have hbf_in : ∀ x, sin.color x = Color.black → finishTime sin x < sin.time := by
simpa [sin, finishTime] using hbf_st
have hdesc_wv : IsBlackDFSAncestor sout w v := by
exact ih hwhite_w_in hbf_in hwhite_v_in (by simpa [sout, sin] using hrec_black)
have hblack_w : sout.color w = Color.black := by
exact dfsVisit_blackens_u_pos G hnpos hwhite_w_in
have hparent_w : sout.parent w = some u := by
calc
sout.parent w = sin.parent w := dfsVisit_parent_source (G := G)
_ = some u := by simp [sin]
have hdesc_uw : IsBlackDFSAncestor sout u w :=
IsBlackDFSAncestor.single hparent_w hblack_w
have hdesc_uv : IsBlackDFSAncestor sout u v := hdesc_uw.trans hdesc_wv
have hdesc_post : IsBlackDFSAncestor (List.foldl step sout post) u v := by
apply hdesc_uv.mono
· intro x hx
simpa [step] using
(dfsVisit_fold_preserves_black_general (G := G) (n := n) (u := u)
(x := x) (s1 := sout) (l := post) hx)
· intro x hx
simpa [step] using
(dfsVisit_fold_preserves_parent_of_black (G := G) (n := n) (u := u)
(x := x) sout (l := post) hx)
have hsplit := dfsVisit_fold_split_at_white_neighbor G s1 pre post st hadj hst hwhite_w
have hs2 : s2 = List.foldl step sout post := by
simpa [s2, step, sout, sin] using hsplit
have hdesc_s2 : IsBlackDFSAncestor s2 u v := by
rw [hs2]
exact hdesc_post
have hdesc_s3 : IsBlackDFSAncestor s3 u v := by
apply hdesc_s2.mono
· intro x hx
simp [s3, hx]
· intro x _hx
simp [s3]
rw [hout]
exact hdesc_s3A DFS visit preserves the fact that strict interval nesting determines a black parent-chain ancestor.
theorem dfsVisit_preserves_nestingAncestorInvariant {fuel : Nat} {u : V}
{s : DFSState V} (hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hnest : NestingAncestorInvariant s)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ x, s.color x = Color.black → finishTime s x < s.time)
(hdf : DiscoveryFinishInvariant s) :
NestingAncestorInvariant (dfsVisit G fuel u s) := by
induction fuel generalizing u s with
| zero => omega
| succ n ih =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (st : DFSState V) (w : V) =>
if st.color w = Color.white then dfsVisit G n w (st.setParent w u) else st
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hout : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, step, s3]
have hnest1 : NestingAncestorInvariant s1 := by
intro x y hx hy hinter
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hyu : y ≠ u := by
intro h
subst y
simp [s1] at hy
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hy0 : s.color y = Color.black := by simpa [s1, hyu] using hy
have hinter0 : intervalNestedInside s x y := by
simpa [intervalNestedInside, discoveryTime, finishTime, s1, hxu, hyu] using hinter
have hanc := hnest x y hx0 hy0 hinter0
apply hanc.mono
· intro z hz
have hzu : z ≠ u := by
intro h
subst z
rw [hwhite] at hz
contradiction
simpa [s1, hzu] using hz
· intro z _hz
simp [s1]
have hdt1 : DiscoveryTimeInvariant s1 := by
intro x hx
by_cases hxu : x = u
· subst x
simp [s1, discoveryTime]
· have hx0 : s.color x ≠ Color.white := by simpa [s1, hxu] using hx
have hlt := hdt x hx0
have hd : discoveryTime s1 x = discoveryTime s x := by
simp [s1, discoveryTime, hxu]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hd, ht]
omega
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hbf x hx0
have hf : finishTime s1 x = finishTime s x := by simp [s1, finishTime]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hf, ht]
omega
have hdf1 : DiscoveryFinishInvariant s1 := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hdf x hx0
simpa [s1, discoveryTime, finishTime, hxu] using hlt
have hfold : ∀ (l : List V) (st : DFSState V),
NestingAncestorInvariant st →
DiscoveryTimeInvariant st →
(∀ x, st.color x = Color.black → finishTime st x < st.time) →
DiscoveryFinishInvariant st →
let out := List.foldl step st l
NestingAncestorInvariant out ∧
DiscoveryTimeInvariant out ∧
(∀ x, out.color x = Color.black → finishTime out x < out.time) ∧
DiscoveryFinishInvariant out := by
intro l
induction l with
| nil =>
intro st hnest_st hdt_st hbf_st hdf_st
exact ⟨hnest_st, hdt_st, hbf_st, hdf_st⟩
| cons w ws ih_fold =>
intro st hnest_st hdt_st hbf_st hdf_st
simp only [List.foldl_cons]
by_cases hw : st.color w = Color.white
· have hnest0 : NestingAncestorInvariant (st.setParent w u) := by
intro x y hx hy hinter
have hx0 : st.color x = Color.black := by simpa using hx
have hy0 : st.color y = Color.black := by simpa using hy
have hanc := hnest_st x y hx0 hy0 (by
simpa [intervalNestedInside, discoveryTime, finishTime] using hinter)
apply hanc.mono
· intro z hz
simpa using hz
· intro z hz
have hzw : z ≠ w := by
intro h
subst z
rw [hw] at hz
contradiction
simp [hzw]
have hdt0 : DiscoveryTimeInvariant (st.setParent w u) := by
simpa [DiscoveryTimeInvariant, discoveryTime] using hdt_st
have hbf0 : ∀ x, (st.setParent w u).color x = Color.black →
finishTime (st.setParent w u) x < (st.setParent w u).time := by
simpa [finishTime] using hbf_st
have hdf0 : DiscoveryFinishInvariant (st.setParent w u) := by
simpa [DiscoveryFinishInvariant, discoveryTime, finishTime] using hdf_st
by_cases hn : n = 0
· subst n
simp [step, hw, dfsVisit]
exact ih_fold (st.setParent w u) hnest0 hdt0 hbf0 hdf0
· have hnpos : 0 < n := by omega
let st' := dfsVisit G n w (st.setParent w u)
have hnest' : NestingAncestorInvariant st' := by
exact ih hnpos (by simpa using hw) hnest0 hdt0 hbf0 hdf0
have hdt' : DiscoveryTimeInvariant st' :=
dfsVisit_preserves_discoveryTimeInvariant G hnpos (by simpa using hw)
hdt0 hbf0 hdf0
have hbf' : ∀ x, st'.color x = Color.black → finishTime st' x < st'.time :=
dfsVisit_black_finish_lt_time G hnpos (by simpa using hw) hbf0
have hdf' : DiscoveryFinishInvariant st' :=
dfsVisit_discovery_lt_finish G hnpos (by simpa using hw) hdf0
have hrest := ih_fold st' hnest' hdt' hbf' hdf'
simpa [step, hw, st'] using hrest
· simpa [step, hw] using ih_fold st hnest_st hdt_st hbf_st hdf_st
rcases hfold (G.adj u).toList s1 hnest1 hdt1 hbf1 hdf1 with
⟨hnest2, _hdt2, _hbf2, _hdf2⟩
intro x y hx hy hinter
by_cases hxu : x = u
· subst x
have hyu : y ≠ u := by
intro h
subst y
unfold intervalNestedInside at hinter
omega
by_cases hywhite : s.color y = Color.white
· exact dfsVisit_blackens_implies_blackAncestor G hwhite hbf hywhite hy
· cases hyc : s.color y with
| white => contradiction
| gray =>
have hgray_out := dfsVisit_preserves_gray (fuel := n + 1) G hyc hyu
rw [hgray_out] at hy
contradiction
| black =>
have hy0 : s.color y = Color.black := hyc
have hdy : discoveryTime (dfsVisit G (n + 1) u s) y = discoveryTime s y := by
dsimp [discoveryTime]
rw [dfsVisit_preserves_d_of_not_white G hyu (by simp [hy0])]
have hdu := dfsVisit_discovery_source G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
have hdy_lt := hdf y hy0
have hfy_lt := hbf y hy0
exfalso
unfold intervalNestedInside at hinter
omega
by_cases hyu : y = u
· subst y
by_cases hxwhite : s.color x = Color.white
· have hdisc := dfsVisit_discovery_ge_input_time G (fuel := n + 1)
(u := u) (v := x) (s := s) (by omega) hwhite hxwhite hx hxu
have hdu := dfsVisit_discovery_source G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
exfalso
unfold intervalNestedInside at hinter
omega
· cases hxc : s.color x with
| white => contradiction
| gray =>
have hgray_out := dfsVisit_preserves_gray (fuel := n + 1) G hxc hxu
rw [hgray_out] at hx
contradiction
| black =>
have hx0 : s.color x = Color.black := hxc
have hfx : finishTime (dfsVisit G (n + 1) u s) x = finishTime s x := by
dsimp [finishTime]
rw [dfsVisit_preserves_f_of_not_white G hxu (by simp [hx0])]
have hdu := dfsVisit_discovery_source G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
have hdf_out := dfsVisit_discovery_lt_finish G (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite hdf
have hub := dfsVisit_blackens_u_pos (G := G) (fuel := n + 1)
(u := u) (s := s) (by omega) hwhite
have hdufu := hdf_out u hub
have hfx_lt := hbf x hx0
exfalso
unfold intervalNestedInside at hinter
omega
· have hx2 : s2.color x = Color.black := by
rw [hout] at hx
simpa [s3, hxu] using hx
have hy2 : s2.color y = Color.black := by
rw [hout] at hy
simpa [s3, hyu] using hy
have hinter2 : intervalNestedInside s2 x y := by
rw [hout] at hinter
simpa [intervalNestedInside, discoveryTime, finishTime, s3, hxu, hyu] using hinter
have hanc2 := hnest2 x y hx2 hy2 hinter2
have hanc2' : IsBlackDFSAncestor s2 x y := by
exact hanc2
have hanc3 : IsBlackDFSAncestor s3 x y := by
apply hanc2'.mono
· intro z hz
by_cases hzu : z = u
· subst z
simp [s3]
· simpa [s3, hzu] using hz
· intro z _hz
simp [s3]
rw [hout]
exact hanc3Recursive DFS over a root list preserves the nesting/ancestor invariant.
theorem dfsFromList_preserves_nestingAncestorInvariant {fuel : Nat}
{s0 : DFSState V} {vs : List V} (hfuel : 0 < fuel)
(hnest : NestingAncestorInvariant s0)
(hdt : DiscoveryTimeInvariant s0)
(hbf : ∀ x, s0.color x = Color.black → finishTime s0 x < s0.time)
(hdf : DiscoveryFinishInvariant s0) :
NestingAncestorInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0 with
| nil => simpa [dfsFromList] using hnest
| cons u us ih =>
simp only [dfsFromList]
by_cases hwhite : s0.color u = Color.white
· rw [if_pos hwhite]
let s1 := dfsVisit G fuel u s0
have hnest1 : NestingAncestorInvariant s1 :=
dfsVisit_preserves_nestingAncestorInvariant G hfuel hwhite hnest hdt hbf hdf
have hdt1 : DiscoveryTimeInvariant s1 :=
dfsVisit_preserves_discoveryTimeInvariant G hfuel hwhite hdt hbf hdf
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time :=
dfsVisit_black_finish_lt_time G hfuel hwhite hbf
have hdf1 : DiscoveryFinishInvariant s1 :=
dfsVisit_discovery_lt_finish G hfuel hwhite hdf
exact ih hnest1 hdt1 hbf1 hdf1
· rw [if_neg hwhite]
exact ih hnest hdt hbf hdfStrict nesting of final DFS intervals implies ancestry in the DFS parent forest.
theorem intervalNestedInside_dfs_implies_ancestor {u v : V}
(hu : u ∈ G.vertices) (hv : v ∈ G.vertices)
(h : intervalNestedInside (G.dfs) u v) : IsDFSAncestor (G.dfs) u v := by
have hfuel : 0 < G.vertices.card + 1 := by omega
have hnest0 : NestingAncestorInvariant (dfsInit : DFSState V) := by
intro x y hx
simp [dfsInit] at hx
have hdt0 : DiscoveryTimeInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hbf0 : ∀ x, (dfsInit : DFSState V).color x = Color.black →
finishTime (dfsInit : DFSState V) x < (dfsInit : DFSState V).time := by
intro x hx
simp [dfsInit] at hx
have hdf0 : DiscoveryFinishInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hnest_final : NestingAncestorInvariant (G.dfs) := by
simpa [dfs] using
(dfsFromList_preserves_nestingAncestorInvariant (G := G)
(fuel := G.vertices.card + 1) (s0 := dfsInit) (vs := G.vertices.toList)
hfuel hnest0 hdt0 hbf0 hdf0)
exact (hnest_final u v (G.dfs_all_black hu) (G.dfs_all_black hv) h).toAncestorA DFS visit preserves the ordering between every recorded parent and its child's discovery event.
theorem dfsVisit_preserves_parentDiscoveryInvariant {fuel : Nat} {u : V}
{s : DFSState V} (hfuel : 0 < fuel) (hwhite : s.color u = Color.white)
(hparent : ParentDiscoveryInvariant s)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ x, s.color x = Color.black → finishTime s x < s.time)
(hdf : DiscoveryFinishInvariant s) :
ParentDiscoveryInvariant (dfsVisit G fuel u s) := by
induction fuel generalizing u s with
| zero => omega
| succ n ih =>
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (st : DFSState V) (w : V) =>
if st.color w = Color.white then dfsVisit G n w (st.setParent w u) else st
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have hout : dfsVisit G (n + 1) u s = s3 := by
simp [dfsVisit, hwhite, s1, s2, step, s3]
have hparent1 : ParentDiscoveryInvariant s1 := by
intro p v hp
have hp0 : s.parent v = some p := by simpa [s1] using hp
rcases hparent p v hp0 with ⟨hp_nw, hchild⟩
have hpu : p ≠ u := by
intro h
subst p
exact hp_nw hwhite
have hp_nw1 : s1.color p ≠ Color.white := by
simpa [s1, hpu] using hp_nw
refine ⟨hp_nw1, ?_⟩
rcases hchild with ⟨hvwhite, hlt⟩ | ⟨hvnw, hlt⟩
· by_cases hvu : v = u
· subst v
right
constructor
· simp [s1]
· simpa [s1, discoveryTime, hpu] using hlt
· left
constructor
· simpa [s1, hvu] using hvwhite
· have hd : discoveryTime s1 p = discoveryTime s p := by
simp [s1, discoveryTime, hpu]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hd, ht]
omega
· have hvu : v ≠ u := by
intro h
subst v
exact hvnw hwhite
right
constructor
· simpa [s1, hvu] using hvnw
· simpa [s1, discoveryTime, hpu, hvu] using hlt
have hdt1 : DiscoveryTimeInvariant s1 := by
intro x hx
by_cases hxu : x = u
· subst x
simp [s1, discoveryTime]
· have hx0 : s.color x ≠ Color.white := by simpa [s1, hxu] using hx
have hlt := hdt x hx0
have hd : discoveryTime s1 x = discoveryTime s x := by
simp [s1, discoveryTime, hxu]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hd, ht]
omega
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
have hlt := hbf x hx0
have hf : finishTime s1 x = finishTime s x := by simp [s1, finishTime]
have ht : s1.time = s.time + 1 := by simp [s1]
rw [hf, ht]
omega
have hdf1 : DiscoveryFinishInvariant s1 := by
intro x hx
have hxu : x ≠ u := by
intro h
subst x
simp [s1] at hx
have hx0 : s.color x = Color.black := by simpa [s1, hxu] using hx
simpa [s1, discoveryTime, finishTime, hxu] using hdf x hx0
have hgray1 : s1.color u = Color.gray := by simp [s1]
have hfold : ∀ (l : List V) (st : DFSState V),
ParentDiscoveryInvariant st →
DiscoveryTimeInvariant st →
(∀ x, st.color x = Color.black → finishTime st x < st.time) →
DiscoveryFinishInvariant st →
st.color u = Color.gray →
let out := List.foldl step st l
ParentDiscoveryInvariant out ∧
DiscoveryTimeInvariant out ∧
(∀ x, out.color x = Color.black → finishTime out x < out.time) ∧
DiscoveryFinishInvariant out ∧ out.color u = Color.gray := by
intro l
induction l with
| nil =>
intro st hp_st hdt_st hbf_st hdf_st hgray_st
exact ⟨hp_st, hdt_st, hbf_st, hdf_st, hgray_st⟩
| cons w ws ih_fold =>
intro st hp_st hdt_st hbf_st hdf_st hgray_st
simp only [List.foldl_cons]
by_cases hw : st.color w = Color.white
· have hwu : w ≠ u := by
intro h
subst w
rw [hgray_st] at hw
contradiction
have hp0 : ParentDiscoveryInvariant (st.setParent w u) := by
intro p v hp
by_cases hvw : v = w
· subst v
have hpu : p = u := by simpa using hp.symm
subst p
refine ⟨?_, Or.inl ⟨?_, ?_⟩⟩
· simp [hgray_st]
· simpa using hw
· exact hdt_st u (by simp [hgray_st])
· have hp' : st.parent v = some p := by simpa [hvw] using hp
simpa [hvw, discoveryTime] using hp_st p v hp'
have hdt0 : DiscoveryTimeInvariant (st.setParent w u) := by
simpa [DiscoveryTimeInvariant, discoveryTime] using hdt_st
have hbf0 : ∀ x, (st.setParent w u).color x = Color.black →
finishTime (st.setParent w u) x < (st.setParent w u).time := by
simpa [finishTime] using hbf_st
have hdf0 : DiscoveryFinishInvariant (st.setParent w u) := by
simpa [DiscoveryFinishInvariant, discoveryTime, finishTime] using hdf_st
have hgray0 : (st.setParent w u).color u = Color.gray := by
simpa using hgray_st
by_cases hn : n = 0
· subst n
simp [step, hw, dfsVisit]
exact ih_fold (st.setParent w u) hp0 hdt0 hbf0 hdf0 hgray0
· have hnpos : 0 < n := by omega
let st' := dfsVisit G n w (st.setParent w u)
have hp' : ParentDiscoveryInvariant st' := by
exact ih hnpos (by simpa using hw) hp0 hdt0 hbf0 hdf0
have hdt' : DiscoveryTimeInvariant st' :=
dfsVisit_preserves_discoveryTimeInvariant G hnpos (by simpa using hw)
hdt0 hbf0 hdf0
have hbf' : ∀ x, st'.color x = Color.black → finishTime st' x < st'.time :=
dfsVisit_black_finish_lt_time G hnpos (by simpa using hw) hbf0
have hdf' : DiscoveryFinishInvariant st' :=
dfsVisit_discovery_lt_finish G hnpos (by simpa using hw) hdf0
have hgray' : st'.color u = Color.gray := by
exact dfsVisit_preserves_gray (fuel := n) G hgray0 hwu.symm
have hrest := ih_fold st' hp' hdt' hbf' hdf' hgray'
simpa [step, hw, st'] using hrest
· simpa [step, hw] using
ih_fold st hp_st hdt_st hbf_st hdf_st hgray_st
rcases hfold (G.adj u).toList s1 hparent1 hdt1 hbf1 hdf1 hgray1 with
⟨hparent2, _hdt2, _hbf2, _hdf2, hgray2⟩
have hparent2' : ParentDiscoveryInvariant s2 := by
exact hparent2
have hparent3 : ParentDiscoveryInvariant s3 := by
intro p v hp
have hp2 : s2.parent v = some p := by simpa [s3] using hp
rcases hparent2' p v hp2 with ⟨hp_nw, hchild⟩
have hp_nw3 : s3.color p ≠ Color.white := by
by_cases hpu : p = u
· subst p
simp [s3]
· simpa [s3, hpu] using hp_nw
refine ⟨hp_nw3, ?_⟩
rcases hchild with ⟨hvwhite, hlt⟩ | ⟨hvnw, hlt⟩
· have hvu : v ≠ u := by
intro h
subst v
rw [hgray2] at hvwhite
contradiction
left
constructor
· simpa [s3, hvu] using hvwhite
· have hd : discoveryTime s3 p = discoveryTime s2 p := by
simp [s3, discoveryTime]
have ht : s3.time = s2.time + 1 := by simp [s3]
rw [hd, ht]
omega
· right
constructor
· by_cases hvu : v = u
· subst v
simp [s3]
· simpa [s3, hvu] using hvnw
· simpa [s3, discoveryTime] using hlt
rw [hout]
exact hparent3Recursive DFS over a root list preserves parent/discovery ordering.
theorem dfsFromList_preserves_parentDiscoveryInvariant {fuel : Nat}
{s0 : DFSState V} {vs : List V} (hfuel : 0 < fuel)
(hparent : ParentDiscoveryInvariant s0)
(hdt : DiscoveryTimeInvariant s0)
(hbf : ∀ x, s0.color x = Color.black → finishTime s0 x < s0.time)
(hdf : DiscoveryFinishInvariant s0) :
ParentDiscoveryInvariant (dfsFromList G fuel vs s0) := by
induction vs generalizing s0 with
| nil => simpa [dfsFromList] using hparent
| cons u us ih =>
simp only [dfsFromList]
by_cases hwhite : s0.color u = Color.white
· rw [if_pos hwhite]
let s1 := dfsVisit G fuel u s0
have hp1 : ParentDiscoveryInvariant s1 :=
dfsVisit_preserves_parentDiscoveryInvariant G hfuel hwhite hparent hdt hbf hdf
have hdt1 : DiscoveryTimeInvariant s1 :=
dfsVisit_preserves_discoveryTimeInvariant G hfuel hwhite hdt hbf hdf
have hbf1 : ∀ x, s1.color x = Color.black → finishTime s1 x < s1.time :=
dfsVisit_black_finish_lt_time G hfuel hwhite hbf
have hdf1 : DiscoveryFinishInvariant s1 :=
dfsVisit_discovery_lt_finish G hfuel hwhite hdf
exact ih hp1 hdt1 hbf1 hdf1
· rw [if_neg hwhite]
exact ih hparent hdt hbf hdfA parent edge in the final DFS forest strictly increases discovery time.
theorem dfs_parent_discovery_lt {u v : V}
(hparent : (G.dfs).parent v = some u) :
discoveryTime (G.dfs) u < discoveryTime (G.dfs) v := by
have hfuel : 0 < G.vertices.card + 1 := by omega
have hp0 : ParentDiscoveryInvariant (dfsInit : DFSState V) := by
intro x y h
simp [dfsInit] at h
have hdt0 : DiscoveryTimeInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hbf0 : ∀ x, (dfsInit : DFSState V).color x = Color.black →
finishTime (dfsInit : DFSState V) x < (dfsInit : DFSState V).time := by
intro x hx
simp [dfsInit] at hx
have hdf0 : DiscoveryFinishInvariant (dfsInit : DFSState V) := by
intro x hx
simp [dfsInit] at hx
have hp_final : ParentDiscoveryInvariant (G.dfs) := by
simpa [dfs] using
(dfsFromList_preserves_parentDiscoveryInvariant (G := G)
(fuel := G.vertices.card + 1) (s0 := dfsInit) (vs := G.vertices.toList)
hfuel hp0 hdt0 hbf0 hdf0)
have hadj : G.Adj u v := dfs_parent_edge G hparent
have hv : v ∈ G.vertices := G.adj_mem_right hadj
have hvblack : (G.dfs).color v = Color.black := G.dfs_all_black hv
rcases hp_final u v hparent with ⟨_hu_nw, hchild⟩
rcases hchild with ⟨hvwhite, _hlt⟩ | ⟨_hvnw, hlt⟩
· rw [hvblack] at hvwhite
contradiction
· exact hltA final DFS ancestor is either the vertex itself or was discovered strictly earlier.
theorem IsDFSAncestor.eq_or_discovery_lt {u v : V}
(h : IsDFSAncestor (G.dfs) u v) :
u = v ∨ discoveryTime (G.dfs) u < discoveryTime (G.dfs) v := by
induction h with
| refl => exact Or.inl rfl
| @tail x y hxy hyz ih =>
have hyz_lt := dfs_parent_discovery_lt G hyz
rcases ih with hxy_eq | hxy_lt
· subst x
exact Or.inr hyz_lt
· exact Or.inr (by omega)end WhitePathTheoremend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S3_Bridge
Bridge lemma: white→nonwhite during dfsVisit → discovery time ≥ input clock
The single key lemma needed for Case 2 of scc_finish_time_order. The
proof uses induction on fuel. Case v = u:
setDiscovery sets d[u] = s.time. Case v ≠ u:
dfsVisit_fold_blackens_loc_prefix finds the exact fold position; the
recursive call has smaller fuel, so the induction hypothesis applies. The
returned hbf_s2 and hmono_s2 provide the needed fold-accumulator
invariants, eliminating the need for separate fold-level analysis.
If v turns from white to non-white during
dfsVisit G fuel u s, then discoveryTime in the output is at
least s.time.
Uses h_bf : ∀ w, s.color w = Color.black → finishTime s w < s.time to
satisfy dfsVisit_fold_blackens_loc_prefix's hinv hypothesis.
For the outer-loop accumulator states used in the SCC proof, h_bf is
available from exists_discovery_state.
theorem dfsVisit_white_to_nonwhite_disc_ge_time {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : 0 < fuel)
(h_bf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hwhite_v : s.color v = Color.white)
(h_nonwhite_result : (dfsVisit G fuel u s).color v ≠ Color.white) :
discoveryTime (dfsVisit G fuel u s) v ≥ s.time := by
induction fuel generalizing u s with
| zero =>
simp [dfsVisit] at h_nonwhite_result
rw [hwhite_v] at h_nonwhite_result
contradiction
| succ k ih =>
by_cases hu_white : s.color u = Color.white
· -- expand dfsVisit; h_eq captures the full expansion
-- dfsVisit expands: s1 = setDiscovery u, s2 = fold, s3 = setFinish u
let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G k w (s'.setParent w u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have h_eq : dfsVisit G (k+1) u s = s3 := by
simp [s3, s2, s1, step, dfsVisit, hu_white]
rw [h_eq] at h_nonwhite_result ⊢
by_cases hvu : v = u
· -- v = u: discovered at setDiscovery, d[u] = s.time
subst v
have h_s3_d : s3.d u = some (s.time) := by
have h_s1 : s1.d u = some (s.time) := by simp [s1]
have h_s2 : s2.d u = s1.d u :=
dfsVisit_fold_preserves_d_of_not_white G (u := u) (v := u) s1
(l := (G.adj u).toList) (by simp [s1])
simp [s3, h_s1, h_s2]
simp [discoveryTime, h_s3_d]
· -- v ≠ u: v turned non-white during the fold
have hwhite_v_s1 : s1.color v = Color.white := by simp [s1, hvu, hwhite_v]
-- s3.color v = s2.color v (setFinish doesn't change v, v ≠ u)
have h_nonwhite_s2 : s2.color v ≠ Color.white := by
intro hw; apply h_nonwhite_result; simp [s3, hvu, hw]
-- s2.color v is black: not white (above) and not gray (fold_no_new_gray)
have h_black_s2 : s2.color v = Color.black := by
have h_no_gray : s2.color v ≠ Color.gray := by
intro hg
have h_s1_gray : s1.color v = Color.gray :=
dfsVisit_fold_no_new_gray G s1 (by simpa [s2, step] using hg)
rw [hwhite_v_s1] at h_s1_gray
simp at h_s1_gray
cases hcolor : s2.color v with
| white => exact (h_nonwhite_s2 hcolor).elim
| gray => exact (h_no_gray hcolor).elim
| black => rfl
-- Build h_bf_init for s1 (from h_bf for s)
have h_bf_init : ∀ z, s1.color z = Color.black → finishTime s1 z < s1.time := by
intro z hblack
have hz_ne_u : z ≠ u := by intro heq; subst z; simp [s1] at hblack
have hblack_s : s.color z = Color.black := by simpa [s1, hz_ne_u] using hblack
have h_fin_s : finishTime s z < s.time := h_bf z hblack_s
have h_fin_s1 : finishTime s1 z = finishTime s z := by simp [s1, finishTime]
have h_time_s1 : s1.time = s.time + 1 := by simp [s1]
rw [h_fin_s1, h_time_s1]; omega
-- Apply dfsVisit_fold_blackens_loc_prefix to find fold position
rcases dfsVisit_fold_blackens_loc_prefix G h_bf_init hwhite_v_s1 h_black_s2
with ⟨pre, post, w, s2_acc, hadj_eq, hs2_eq, hw_white, hv_white_s2_acc,
hw_disc_v, hmono_s2, hbf_s2⟩
-- s2_acc is the accumulator just before processing w.
-- The recursive call dfsVisit G k w (s2_acc.setParent w u) discovers v.
by_cases hw_eq_v : w = v
· -- w = v: the recursive call directly discovers v
subst w
let s_rec_in := s2_acc.setParent v u
have hwhite_rec_in : s_rec_in.color v = Color.white := by
simp [s_rec_in, hv_white_s2_acc]
have h_nonwhite_rec_out : (dfsVisit G k v s_rec_in).color v ≠ Color.white := by
rw [hw_disc_v]; decide
have h_bf_rec : ∀ z, s_rec_in.color z = Color.black →
finishTime s_rec_in z < s_rec_in.time := by
intro z hblack
have hblack_s2_acc : s2_acc.color z = Color.black := by
simpa [s_rec_in] using hblack
have h_lt := hbf_s2 z hblack_s2_acc
simpa [s_rec_in, finishTime] using h_lt
-- Apply IH at smaller fuel k
have hk_pos_v : 0 < k := by
by_cases hz : k = 0
· subst hz
have h_eq : dfsVisit G 0 v s_rec_in = s_rec_in := by simp [dfsVisit]
rw [h_eq] at h_nonwhite_rec_out
rw [hwhite_rec_in] at h_nonwhite_rec_out
simp at h_nonwhite_rec_out
· omega
have h_disc_ge := ih (u := v) (s := s_rec_in) hk_pos_v h_bf_rec hwhite_rec_in h_nonwhite_rec_out
-- h_disc_ge: discoveryTime (dfsVisit G k v s_rec_in) v ≥ s_rec_in.time = s2_acc.time
have h_time_acc : s_rec_in.time = s2_acc.time := by simp [s_rec_in]
rw [h_time_acc] at h_disc_ge
-- d[v] preserved through rest of fold (post) and setFinish
have h_d_post : (List.foldl step (dfsVisit G k v s_rec_in) post).d v =
(dfsVisit G k v s_rec_in).d v :=
dfsVisit_fold_preserves_d_of_black G
(s1 := dfsVisit G k v s_rec_in) (l := post) hw_disc_v
-- Decompose the full fold using hadj_eq and hs2_eq
have h_full_fold : s2 = List.foldl step (dfsVisit G k v s_rec_in) post := by
-- s2 = foldl step s1 (G.adj u).toList
-- = foldl step s1 (pre ++ v :: post) [hadj_eq]
-- = foldl step (foldl step s1 pre) (v :: post) [List.foldl_append]
-- = foldl step s2_acc (v :: post) [hs2_eq]
-- = foldl step (step s2_acc v) post [List.foldl]
-- = foldl step (dfsVisit G k v (s2_acc.setParent v u)) post [...]
calc
s2 = List.foldl step s1 (G.adj u).toList := rfl
_ = List.foldl step s1 (pre ++ v :: post) := by rw [hadj_eq]
_ = List.foldl step (List.foldl step s1 pre) (v :: post) := by rw [List.foldl_append]
_ = List.foldl step s2_acc (v :: post) := by rw [hs2_eq]
_ = List.foldl step (step s2_acc v) post := rfl
_ = List.foldl step (dfsVisit G k v (s2_acc.setParent v u)) post := by
simp [step, hw_white]
_ = List.foldl step (dfsVisit G k v s_rec_in) post := rfl
have h_s3_d : s3.d v = (dfsVisit G k v s_rec_in).d v := by
simp [s3, h_full_fold, h_d_post]
dsimp [discoveryTime] at h_disc_ge ⊢
rw [h_s3_d]
-- h_disc_ge says: (dfsVisit ...).d v .getD 0 ≥ s2_acc.time
-- Need: (dfsVisit ...).d v .getD 0 ≥ s.time
-- Since s2_acc is a fold accumulator from s1, s2_acc.time ≥ s1.time ≥ s.time
have h_time_ge : s2_acc.time ≥ s1.time := by
-- s2_acc = foldl step s1 pre; dfsVisit_fold_time_ge gives clock monotonicity
rw [hs2_eq]
simpa [step] using @dfsVisit_fold_time_ge V _ G k u s1 pre
have h_s1_time : s1.time = s.time + 1 := by simp [s1]
have h_s2_acc_ge_s_time : s2_acc.time ≥ s.time := by omega
exact le_trans h_s2_acc_ge_s_time h_disc_ge
· -- w ≠ v: v is discovered inside the recursive call on w.
-- By IH (fuel k) on that call, d[v] ≥ s2_acc.time.
-- Then d-preservation through post and setFinish.
let s_rec_in := s2_acc.setParent w u
have hwhite_rec_in : s_rec_in.color v = Color.white := by
simp [s_rec_in, hv_white_s2_acc]
have h_bf_rec : ∀ z, s_rec_in.color z = Color.black →
finishTime s_rec_in z < s_rec_in.time := by
intro z hblack
have hblack_s2_acc : s2_acc.color z = Color.black := by
simpa [s_rec_in] using hblack
have h_lt := hbf_s2 z hblack_s2_acc
simpa [s_rec_in, finishTime] using h_lt
have hk_pos_w : 0 < k := by
by_cases hz : k = 0
· subst hz
have h_eq : dfsVisit G 0 w s_rec_in = s_rec_in := by simp [dfsVisit]
rw [h_eq] at hw_disc_v
rw [hwhite_rec_in] at hw_disc_v
simp at hw_disc_v
· omega
have h_nonwhite_w : (dfsVisit G k w s_rec_in).color v ≠ Color.white := by
rw [hw_disc_v]; decide
have h_disc_ge := ih (u := w) (s := s_rec_in) hk_pos_w h_bf_rec hwhite_rec_in h_nonwhite_w
-- hw_disc_v: (dfsVisit G k w s_rec_in).color v = Color.black ≠ white
-- So h_disc_ge: discoveryTime (dfsVisit G k w s_rec_in) v ≥ s_rec_in.time
have h_time_rec : s_rec_in.time = s2_acc.time := by simp [s_rec_in]
rw [h_time_rec] at h_disc_ge
-- d[v] preserved through rest of fold (post) and setFinish
have h_d_post : (List.foldl step (dfsVisit G k w s_rec_in) post).d v =
(dfsVisit G k w s_rec_in).d v :=
dfsVisit_fold_preserves_d_of_black G
(s1 := dfsVisit G k w s_rec_in) (l := post) hw_disc_v
-- Decompose the full fold
have h_full_fold : s2 = List.foldl step (dfsVisit G k w s_rec_in) post := by
calc
s2 = List.foldl step s1 (G.adj u).toList := rfl
_ = List.foldl step s1 (pre ++ w :: post) := by rw [hadj_eq]
_ = List.foldl step (List.foldl step s1 pre) (w :: post) := by rw [List.foldl_append]
_ = List.foldl step s2_acc (w :: post) := by rw [hs2_eq]
_ = List.foldl step (step s2_acc w) post := rfl
_ = List.foldl step (dfsVisit G k w s_rec_in) post := by
simp [step, hw_white, s_rec_in]
have h_s3_d : s3.d v = (dfsVisit G k w s_rec_in).d v := by
simp [s3, h_full_fold, h_d_post]
dsimp [discoveryTime] at h_disc_ge ⊢
rw [h_s3_d]
-- h_disc_ge: discoveryTime (dfsVisit ...) v ≥ s2_acc.time ≥ s.time
have h_s2_acc_ge_s_time : s2_acc.time ≥ s.time := by
rw [hs2_eq]
have h_ge : (List.foldl step s1 pre).time ≥ s1.time := by
simpa [step] using @dfsVisit_fold_time_ge V _ G k u s1 pre
have h_s1_ge_s : s1.time ≥ s.time := by
have : s1.time = s.time + 1 := by simp [s1]
omega
exact le_trans h_s1_ge_s h_ge
exact le_trans h_s2_acc_ge_s_time h_disc_ge
· -- u is not white: dfsVisit returns s unchanged
simp [dfsVisit, hu_white] at h_nonwhite_result ⊢
exact (h_nonwhite_result hwhite_v).elim
Corollary: dfsFromList version
The lemma lifts to dfsFromList by induction on the vertex list.
If v turns from white to non-white during the neighbor-processing fold
inside a DFS visit, then its discovery time in the fold output is at least the
input state's clock.
theorem dfsVisit_fold_white_to_nonwhite_disc_ge_time {n : Nat} {u : V} {l : List V}
{s0 : DFSState V} {v : V}
(hfuel : 0 < n)
(h_bf_s0 : ∀ w, s0.color w = Color.black → finishTime s0 w < s0.time)
(hwhite_s0 : s0.color v = Color.white)
(h_nonwhite_result : (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s0 l).color v ≠
Color.white) :
discoveryTime (List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s0 l) v ≥
s0.time := by
induction l generalizing s0 with
| nil =>
simp at h_nonwhite_result
rw [hwhite_s0] at h_nonwhite_result
contradiction
| cons w ws ih =>
simp at h_nonwhite_result ⊢
by_cases hw_white : s0.color w = Color.white
· simp [hw_white] at h_nonwhite_result ⊢
let s_parent := s0.setParent w u
let s1 := dfsVisit G n w s_parent
have h_bf_parent : ∀ z, s_parent.color z = Color.black →
finishTime s_parent z < s_parent.time := by
intro z hz
have hz0 : s0.color z = Color.black := by
simpa [s_parent] using hz
have hlt := h_bf_s0 z hz0
simpa [s_parent, finishTime] using hlt
by_cases hv_white_s1 : s1.color v = Color.white
· have h_bf_s1 : ∀ z, s1.color z = Color.black → finishTime s1 z < s1.time := by
exact dfsVisit_black_finish_lt_time G hfuel (by simpa [s_parent] using hw_white) h_bf_parent
have htime_ge : s1.time ≥ s0.time := by
have h := G.dfsVisit_time_ge (fuel := n) (u := w) (s := s_parent)
simpa [s1, s_parent] using h
have h_ih := ih (s0 := s1) h_bf_s1 hv_white_s1 h_nonwhite_result
exact le_trans htime_ge h_ih
· have hwhite_parent : s_parent.color v = Color.white := by
simpa [s_parent] using hwhite_s0
have h_disc_ge_s1 : discoveryTime s1 v ≥ s0.time := by
have h := dfsVisit_white_to_nonwhite_disc_ge_time G hfuel h_bf_parent
hwhite_parent hv_white_s1
simpa [s1, s_parent] using h
have hblack_s1 : s1.color v = Color.black := by
have h_no_gray : s1.color v ≠ Color.gray := by
intro hg
have h_input_gray : s_parent.color v = Color.gray := dfsVisit_no_new_gray G v hg
rw [hwhite_parent] at h_input_gray
contradiction
cases hcolor : s1.color v with
| white => exact (hv_white_s1 hcolor).elim
| gray => exact (h_no_gray hcolor).elim
| black => rfl
have h_d_rest :
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s') s1 ws).d v =
s1.d v :=
dfsVisit_fold_preserves_d_of_black G (u := u) (v := v) (s1 := s1) (l := ws) hblack_s1
dsimp [discoveryTime] at h_disc_ge_s1 ⊢
rw [h_d_rest]
exact h_disc_ge_s1
· simp [hw_white] at h_nonwhite_result ⊢
exact ih h_bf_s0 hwhite_s0 h_nonwhite_resultNamed predicate for the bridge facts produced by a local discovery-state argument.
The state argument is the input state to the recursive dfsVisit
that discovers v; outer is the enclosing DFS state in which the
discovery is observed. Keeping this witness in Prop lets the proof use ordinary
existential elimination over fold-location lemmas.
def DFSDiscoveryBridge (G : Graph V) (outer : DFSState V) (v : V)
(state : DFSState V) (fuel : Nat) : Prop :=
state.color v = Color.white ∧
(dfsVisit G fuel v state).color v = Color.black ∧
discoveryTime outer v = state.time ∧
(∀ w, state.color w ≠ Color.white → discoveryTime outer w < state.time) ∧
(∀ w, state.color w = Color.black → finishTime state w < state.time) ∧
(∀ w, state.color w = Color.gray → G.Reachable w v) ∧
(∀ w, state.color w ≠ Color.white → outer.color w ≠ Color.white) ∧
(∀ w, (dfsVisit G fuel v state).color w = Color.black →
outer.color w = Color.black ∧
finishTime outer w = finishTime (dfsVisit G fuel v state) w) ∧
fuel ≥ (whiteReachableSet G state v).card + 1 ∧
(∀ w, (dfsVisit G fuel v state).color w = Color.white →
outer.color w ≠ Color.white →
(dfsVisit G fuel v state).time ≤ discoveryTime outer w)
Local discovery-state theorem for a single dfsVisit.
If a sufficiently-fuelled visit from u discovers a white vertex
v, this returns the actual state immediately before the recursive call on
v, packaged as a DFSDiscoveryBridge.
theorem dfsVisit_discovery_bridge {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1)
(hwhite : s.color u = Color.white)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hdf : DiscoveryFinishInvariant s)
(hb : (dfsVisit G fuel u s).color v = Color.black)
(hw : WhiteReachable G s u v)
(hv : s.color v = Color.white)
(hgray : ∀ w, s.color w = Color.gray → G.Reachable w u) :
∃ (s' : DFSState V) (fuel' : Nat),
DFSDiscoveryBridge G (dfsVisit G fuel u s) v s' fuel' := by
induction fuel generalizing u s with
| zero =>
simp [dfsVisit] at hb
rw [hv] at hb
contradiction
| succ n ih =>
by_cases hvu : v = u
· subst v
have hfuel_pos : 0 < n + 1 := by omega
have hdisc : discoveryTime (dfsVisit G (n + 1) u s) u = s.time :=
dfsVisit_discovery_source G hfuel_pos hwhite
have h_nonwhite : ∀ x, s.color x ≠ Color.white →
discoveryTime (dfsVisit G (n + 1) u s) x < s.time := by
intro x hnw
have hxu : x ≠ u := by
intro h
subst x
exact hnw hwhite
have hd : (dfsVisit G (n + 1) u s).d x = s.d x :=
dfsVisit_preserves_d_of_not_white G hxu hnw
have hlt := hdt x hnw
dsimp [discoveryTime] at hlt ⊢
rw [hd]
exact hlt
have h_nonwhite_pres : ∀ x, s.color x ≠ Color.white →
(dfsVisit G (n + 1) u s).color x ≠ Color.white := by
intro x hnw
have hxu : x ≠ u := by
intro h
subst x
exact hnw hwhite
exact dfsVisit_preserves_not_white G hxu hnw
have h_f_pres : ∀ x, (dfsVisit G (n + 1) u s).color x = Color.black →
(dfsVisit G (n + 1) u s).color x = Color.black ∧
finishTime (dfsVisit G (n + 1) u s) x = finishTime (dfsVisit G (n + 1) u s) x := by
intro x hblack
exact ⟨hblack, rfl⟩
have h_later : ∀ x, (dfsVisit G (n + 1) u s).color x = Color.white →
(dfsVisit G (n + 1) u s).color x ≠ Color.white →
(dfsVisit G (n + 1) u s).time ≤ discoveryTime (dfsVisit G (n + 1) u s) x := by
intro x hw hnw
exact False.elim (hnw hw)
exact ⟨s, n + 1, hwhite, hb, hdisc, h_nonwhite, hbf, hgray,
h_nonwhite_pres, h_f_pres, hfuel, h_later⟩
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let step : DFSState V → V → DFSState V := fun s' x =>
if s'.color x = Color.white then dfsVisit G n x (s'.setParent x u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have heq_state : dfsVisit G (n + 1) u s = s3 := by
simp [s3, s2, s1, step, dfsVisit, hwhite]
have hv_s3 : s3.color v = Color.black := by
rw [← heq_state]
exact hb
have hfold_black : s2.color v = Color.black := by
simp [s3] at hv_s3
exact hv_s3 hvu
have hwhite_v_s1 : s1.color v = Color.white := by
simp [s1, hvu, hv]
have hbf_s1 : ∀ z, s1.color z = Color.black → finishTime s1 z < s1.time := by
intro z hz
have hzu : z ≠ u := by
intro h
subst z
simp [s1] at hz
have hz0 : s.color z = Color.black := by
simpa [s1, hzu] using hz
have hlt := hbf z hz0
have hf_eq : finishTime s1 z = finishTime s z := by simp [s1, finishTime]
have ht_eq : s1.time = s.time + 1 := by simp [s1]
rw [hf_eq, ht_eq]
omega
have hdt_s1 : DiscoveryTimeInvariant s1 := by
intro z hnw
by_cases hzu : z = u
· subst z
simp [s1, discoveryTime]
· have hnw0 : s.color z ≠ Color.white := by
simpa [s1, hzu] using hnw
have hlt := hdt z hnw0
have hd_eq : discoveryTime s1 z = discoveryTime s z := by
simp [s1, discoveryTime, hzu]
have ht_eq : s1.time = s.time + 1 := by simp [s1]
rw [hd_eq, ht_eq]
omega
have hdf_s1 : DiscoveryFinishInvariant s1 := by
intro z hblack
have hzu : z ≠ u := by
intro h
subst z
simp [s1] at hblack
have hblack0 : s.color z = Color.black := by
simpa [s1, hzu] using hblack
have hd_eq : discoveryTime s1 z = discoveryTime s z := by
simp [s1, discoveryTime, hzu]
have hf_eq : finishTime s1 z = finishTime s z := by
simp [s1, finishTime]
rw [hd_eq, hf_eq]
exact hdf z hblack0
rcases dfsVisit_fold_blackens_loc_prefix_full G hbf_s1 hdt_s1 hdf_s1 hwhite_v_s1 hfold_black with
⟨pre, post, w, s2_acc, hadj_eq, hs2_eq, hw_white, hv_white_s2,
hw_disc_v, hmono_s2, hbf_s2, hdt_s2⟩
let s_input := s2_acc.setParent w u
have hwhite_w_input : s_input.color w = Color.white := by
simp [s_input, hw_white]
have hwhite_v_input : s_input.color v = Color.white := by
simp [s_input, hv_white_s2]
have hblack_v_input : (dfsVisit G n w s_input).color v = Color.black := by
simpa [s_input] using hw_disc_v
have hn_pos : 0 < n := by
by_contra h
have hn0 : n = 0 := by omega
subst n
simp [dfsVisit] at hblack_v_input
rw [hwhite_v_input] at hblack_v_input
contradiction
have hadj_uw : G.Adj u w := by
have hw_mem : w ∈ (G.adj u).toList := by
rw [hadj_eq]
simp
simpa [Graph.Adj, Finset.mem_toList] using hw_mem
have hu_vertices : u ∈ G.vertices := G.adj_mem_left hadj_uw
have hw_vertices : w ∈ G.vertices := G.adj_mem_right hadj_uw
have hs2_gray_u : s2_acc.color u = Color.gray := by
rw [hs2_eq]
have hfold : ∀ (l : List V) (t : DFSState V),
t.color u = Color.gray →
(List.foldl step t l).color u = Color.gray := by
intro l
induction l with
| nil =>
intro t ht
simpa using ht
| cons x xs ihxs =>
intro t ht
simp [step]
by_cases hx : t.color x = Color.white
· simp [hx]
apply ihxs
have hsp : (t.setParent x u).color u = Color.gray := by
simp [ht]
have hne : u ≠ x := by
intro hux
subst x
rw [ht] at hx
contradiction
exact dfsVisit_preserves_gray G hsp hne
· simp [hx]
exact ihxs t ht
exact hfold pre s1 (by simp [s1])
have hinput_u_gray : s_input.color u = Color.gray := by
simp [s_input, hs2_gray_u]
have huw : u ≠ w := by
intro h
subst w
rw [hs2_gray_u] at hw_white
contradiction
have h_fuel_input : n ≥ (whiteReachableSet G s_input w).card + 1 := by
have hnot_u : u ∉ whiteReachableSet G s_input w := by
intro huin
have hwr : WhiteReachable G s_input w u :=
(mem_whiteReachableSet_iff G hw_vertices).mp huin
have hu_white : s_input.color u = Color.white :=
whiteReachable_target_white G hwhite_w_input hwr
rw [hinput_u_gray] at hu_white
contradiction
have hsub : whiteReachableSet G s_input w ⊆ whiteReachableSet G s u := by
intro x hx
have hxw : WhiteReachable G s_input w x :=
(mem_whiteReachableSet_iff G hw_vertices).mp hx
have hwu : WhiteReachable G s u w := by
have hwhite_w_s : s.color w = Color.white := by
have h1 : s1.color w = Color.white := hmono_s2 w hw_white
have hwu_ne : w ≠ u := by exact fun h => huw h.symm
simpa [s1, hwu_ne] using h1
exact whiteReachable_step G (whiteReachable_refl G s u) hadj_uw hwhite_w_s
have hwx_s : WhiteReachable G s w x := by
have hcolors : ∀ y, s_input.color y = Color.white → s.color y = Color.white := by
intro y hy
have hy2 : s2_acc.color y = Color.white := by
simpa [s_input] using hy
have hy1 : s1.color y = Color.white := hmono_s2 y hy2
have hyu : y ≠ u := by
intro h
subst y
simp [s1] at hy1
simpa [s1, hyu] using hy1
exact whiteReachable_mono_of_color_superset G hcolors hxw
exact (mem_whiteReachableSet_iff G hu_vertices).mpr
(whiteReachable_trans G hwu hwx_s)
have hcard_lt : (whiteReachableSet G s_input w).card < (whiteReachableSet G s u).card := by
apply Finset.card_lt_card
apply Finset.ssubset_iff_subset_ne.mpr
refine ⟨hsub, ?_⟩
intro heq
have hu_in : u ∈ whiteReachableSet G s u := by
exact (mem_whiteReachableSet_iff G hu_vertices).mpr (whiteReachable_refl G s u)
exact hnot_u (heq ▸ hu_in)
have hcard_le : (whiteReachableSet G s_input w).card + 1 ≤
(whiteReachableSet G s u).card := by
omega
omega
have hdt_input : DiscoveryTimeInvariant s_input := by
intro z hnw
have hnw2 : s2_acc.color z ≠ Color.white := by
simpa [s_input] using hnw
have hlt := hdt_s2 z hnw2
simpa [s_input, discoveryTime] using hlt
have hdf_s2 : DiscoveryFinishInvariant s2_acc := by
rw [hs2_eq]
exact dfsVisit_fold_preserves_discoveryFinishInvariant (G := G) (n := n) (u := u)
(s1 := s1) (l := pre) hdt_s1 hbf_s1 hdf_s1
have hdf_input : DiscoveryFinishInvariant s_input := by
intro z hblack
have hblack2 : s2_acc.color z = Color.black := by
simpa [s_input] using hblack
have h := hdf_s2 z hblack2
simpa [s_input, discoveryTime, finishTime] using h
have hbf_input : ∀ z, s_input.color z = Color.black → finishTime s_input z < s_input.time := by
intro z hblack
have hblack2 : s2_acc.color z = Color.black := by
simpa [s_input] using hblack
have h := hbf_s2 z hblack2
simpa [s_input, finishTime] using h
have hgray_input : ∀ z, s_input.color z = Color.gray → G.Reachable z w := by
intro z hz
have hz2 : s2_acc.color z = Color.gray := by
simpa [s_input] using hz
have hz1 : s1.color z = Color.gray := by
rw [hs2_eq] at hz2
exact dfsVisit_fold_no_new_gray G s1 hz2
have hzu_or : z = u ∨ s.color z = Color.gray := by
by_cases hzu : z = u
· exact Or.inl hzu
· right
simpa [s1, hzu] using hz1
rcases hzu_or with (hzu | hz_gray)
· subst z
exact Relation.ReflTransGen.single hadj_uw
· exact Relation.ReflTransGen.trans (hgray z hz_gray)
(Relation.ReflTransGen.single hadj_uw)
have hwreach : WhiteReachable G s_input w v :=
dfsVisit_blackens_implies_whiteReachable G hwhite_w_input hn_pos
hwhite_v_input hblack_v_input
rcases ih (u := w) (s := s_input) h_fuel_input hwhite_w_input hdt_input
hbf_input hdf_input hblack_v_input hwreach hwhite_v_input hgray_input with
⟨s_rec, f_rec, hs_rec_white, hf_rec_black, hdisc_rec, h_nonwhite_rec,
hbf_rec_state, h_gray_rec, h_nonwhite_pres_rec, h_f_pres_rec,
h_fuel_rec, h_later_rec⟩
have h_full_fold : List.foldl step s1 (G.adj u).toList =
List.foldl step (dfsVisit G n w s_input) post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s1 pre post s2_acc hadj_eq hs2_eq hw_white
simpa [s_input] using h
have h_s3_d_of_rec_not_white : ∀ x,
(dfsVisit G n w s_input).color x ≠ Color.white →
s3.d x = (dfsVisit G n w s_input).d x := by
intro x hnw_rec
have h_post_d : (List.foldl step (dfsVisit G n w s_input) post).d x =
(dfsVisit G n w s_input).d x :=
dfsVisit_fold_preserves_d_of_not_white G
(u := u) (v := x) (s1 := dfsVisit G n w s_input) (l := post) hnw_rec
simp [s3, s2]
calc
(List.foldl step s1 (G.adj u).toList).d x
= (List.foldl step (dfsVisit G n w s_input) post).d x := by
simpa using congrArg (fun st => st.d x) h_full_fold
_ = (dfsVisit G n w s_input).d x := h_post_d
have h_s3_nonwhite_of_rec : ∀ x,
(dfsVisit G n w s_input).color x ≠ Color.white →
s3.color x ≠ Color.white := by
intro x hnw_rec
by_cases hxu : x = u
· subst x
simp [s3]
· have hpost_nw :
(List.foldl step (dfsVisit G n w s_input) post).color x ≠ Color.white :=
dfsVisit_fold_preserves_not_white G
(u := u) (v := x) (s1 := dfsVisit G n w s_input) (l := post) hxu hnw_rec
simpa [s3, s2, hxu, h_full_fold] using hpost_nw
have h_s3_black_f_of_rec_black : ∀ x,
(dfsVisit G n w s_input).color x = Color.black →
s3.color x = Color.black ∧
finishTime s3 x = finishTime (dfsVisit G n w s_input) x := by
intro x hblack_rec
have hxu : x ≠ u := by
intro h
subst x
have hrec_u_gray : (dfsVisit G n w s_input).color u = Color.gray :=
dfsVisit_preserves_gray G hinput_u_gray huw
rw [hrec_u_gray] at hblack_rec
contradiction
have hpost_black : (List.foldl step (dfsVisit G n w s_input) post).color x = Color.black :=
dfsVisit_fold_preserves_black G
(u := u) (x := x) (s1 := dfsVisit G n w s_input) (l := post) hblack_rec
have hpost_f : (List.foldl step (dfsVisit G n w s_input) post).f x =
(dfsVisit G n w s_input).f x :=
dfsVisit_fold_preserves_f_of_black G
(u := u) (v := x) (s1 := dfsVisit G n w s_input) (l := post) hblack_rec
constructor
· simp [s3, s2, hxu, h_full_fold, hpost_black]
· simp [s3, s2, finishTime, hxu, h_full_fold, hpost_f]
have h_sub_time_le_rec : (dfsVisit G f_rec v s_rec).time ≤
(dfsVisit G n w s_input).time := by
have hf_rec_pos : 0 < f_rec := by omega
have hfinish_src :
finishTime (dfsVisit G f_rec v s_rec) v =
(dfsVisit G f_rec v s_rec).time - 1 :=
dfsVisit_finishTime_source_eq_pred_time G hf_rec_pos hs_rec_white
have hlocal_v := h_f_pres_rec v hf_rec_black
have hfinish_lt :
finishTime (dfsVisit G n w s_input) v <
(dfsVisit G n w s_input).time :=
dfsVisit_black_finish_lt_time G hn_pos hwhite_w_input hbf_input v hlocal_v.1
rw [hlocal_v.2, hfinish_src] at hfinish_lt
have htime_pos : (dfsVisit G f_rec v s_rec).time > 0 := by
have hgt := dfsVisit_time_gt_of_white G hf_rec_pos hs_rec_white
exact lt_of_le_of_lt (Nat.zero_le s_rec.time) hgt
omega
have h_rec_time_le_s3 : (dfsVisit G n w s_input).time ≤ s3.time := by
have htime_post : (dfsVisit G n w s_input).time ≤
(List.foldl step (dfsVisit G n w s_input) post).time :=
dfsVisit_fold_time_ge G (u := u) (s1 := dfsVisit G n w s_input) (l := post)
have htime_s3 : s3.time =
(List.foldl step (dfsVisit G n w s_input) post).time + 1 := by
simp [s3, s2, h_full_fold]
omega
have h_sub_time_le_s3 : (dfsVisit G f_rec v s_rec).time ≤ s3.time :=
le_trans h_sub_time_le_rec h_rec_time_le_s3
have h_nonwhite : ∀ x, s_rec.color x ≠ Color.white →
discoveryTime (dfsVisit G (n + 1) u s) x < s_rec.time := by
intro x hnw
have hlt_rec := h_nonwhite_rec x hnw
have hnw_rec := h_nonwhite_pres_rec x hnw
have h_s3_d_x := h_s3_d_of_rec_not_white x hnw_rec
rw [heq_state]
dsimp [discoveryTime] at hlt_rec ⊢
rw [h_s3_d_x]
exact hlt_rec
have h_nonwhite_pres : ∀ x, s_rec.color x ≠ Color.white →
(dfsVisit G (n + 1) u s).color x ≠ Color.white := by
intro x hnw
have hnw_rec := h_nonwhite_pres_rec x hnw
rw [heq_state]
exact h_s3_nonwhite_of_rec x hnw_rec
have h_f_pres : ∀ x, (dfsVisit G f_rec v s_rec).color x = Color.black →
(dfsVisit G (n + 1) u s).color x = Color.black ∧
finishTime (dfsVisit G (n + 1) u s) x = finishTime (dfsVisit G f_rec v s_rec) x := by
intro x hblack_sub
have hlocal := h_f_pres_rec x hblack_sub
have hs3 := h_s3_black_f_of_rec_black x hlocal.1
rw [heq_state]
exact ⟨hs3.1, by rw [hs3.2, hlocal.2]⟩
have h_later : ∀ x, (dfsVisit G f_rec v s_rec).color x = Color.white →
(dfsVisit G (n + 1) u s).color x ≠ Color.white →
(dfsVisit G f_rec v s_rec).time ≤ discoveryTime (dfsVisit G (n + 1) u s) x := by
intro x hwhite_sub hfinal
rw [heq_state] at hfinal ⊢
by_cases hwhite_rec_x : (dfsVisit G n w s_input).color x = Color.white
· have hxu : x ≠ u := by
intro h
subst x
have hrec_u_gray : (dfsVisit G n w s_input).color u = Color.gray :=
dfsVisit_preserves_gray G hinput_u_gray huw
rw [hrec_u_gray] at hwhite_rec_x
contradiction
have h_s3_color_x : s3.color x =
(List.foldl step (dfsVisit G n w s_input) post).color x := by
simp [s3, s2, hxu, h_full_fold]
have h_nonwhite_post :
(List.foldl step (dfsVisit G n w s_input) post).color x ≠ Color.white := by
intro hpost
apply hfinal
rw [h_s3_color_x, hpost]
have h_bf_rec_out : ∀ z, (dfsVisit G n w s_input).color z = Color.black →
finishTime (dfsVisit G n w s_input) z < (dfsVisit G n w s_input).time :=
dfsVisit_black_finish_lt_time G hn_pos hwhite_w_input hbf_input
have h_disc_ge_post :
(dfsVisit G n w s_input).time ≤
discoveryTime (List.foldl step (dfsVisit G n w s_input) post) x :=
dfsVisit_fold_white_to_nonwhite_disc_ge_time G hn_pos h_bf_rec_out
hwhite_rec_x h_nonwhite_post
have h_s3_d_fold_x : s3.d x =
(List.foldl step (dfsVisit G n w s_input) post).d x := by
simp [s3, s2, h_full_fold]
dsimp [discoveryTime] at h_disc_ge_post ⊢
rw [h_s3_d_fold_x]
exact le_trans h_sub_time_le_rec h_disc_ge_post
· have h_later_rec_x := h_later_rec x hwhite_sub hwhite_rec_x
have h_s3_d_x := h_s3_d_of_rec_not_white x hwhite_rec_x
dsimp [discoveryTime] at h_later_rec_x ⊢
rw [h_s3_d_x]
exact h_later_rec_x
refine ⟨s_rec, f_rec, hs_rec_white, hf_rec_black, ?_, h_nonwhite,
hbf_rec_state, h_gray_rec, h_nonwhite_pres, h_f_pres, h_fuel_rec, h_later⟩
have h_rec_nonwhite_v : (dfsVisit G n w s_input).color v ≠ Color.white := by
rw [hblack_v_input]
decide
have h_s3_d_v := h_s3_d_of_rec_not_white v h_rec_nonwhite_v
rw [heq_state]
dsimp [discoveryTime] at hdisc_rec ⊢
rw [h_s3_d_v]
exact hdisc_recCompatibility wrapper for callers that still destructure the bridge as an existential/conjunction package.
theorem dfsVisit_discovery_state_with_bridges {fuel : Nat} {u v : V} {s : DFSState V}
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1)
(hwhite : s.color u = Color.white)
(hdt : DiscoveryTimeInvariant s)
(hbf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hdf : DiscoveryFinishInvariant s)
(hb : (dfsVisit G fuel u s).color v = Color.black)
(hw : WhiteReachable G s u v)
(hv : s.color v = Color.white)
(hgray : ∀ w, s.color w = Color.gray → G.Reachable w u) :
∃ (s' : DFSState V) (fuel' : Nat),
s'.color v = Color.white ∧
(dfsVisit G fuel' v s').color v = Color.black ∧
discoveryTime (dfsVisit G fuel u s) v = s'.time ∧
(∀ w, s'.color w ≠ Color.white →
discoveryTime (dfsVisit G fuel u s) w < s'.time) ∧
(∀ w, s'.color w = Color.black → finishTime s' w < s'.time) ∧
(∀ w, s'.color w = Color.gray → G.Reachable w v) ∧
(∀ w, s'.color w ≠ Color.white →
(dfsVisit G fuel u s).color w ≠ Color.white) ∧
(∀ w, (dfsVisit G fuel' v s').color w = Color.black →
(dfsVisit G fuel u s).color w = Color.black ∧
finishTime (dfsVisit G fuel u s) w = finishTime (dfsVisit G fuel' v s') w) ∧
fuel' ≥ (whiteReachableSet G s' v).card + 1 ∧
(∀ w, (dfsVisit G fuel' v s').color w = Color.white →
(dfsVisit G fuel u s).color w ≠ Color.white →
(dfsVisit G fuel' v s').time ≤ discoveryTime (dfsVisit G fuel u s) w) := by
simpa [DFSDiscoveryBridge] using
(dfsVisit_discovery_bridge G hfuel hwhite hdt hbf hdf hb hw hv hgray)
If v turns from white to non-white during dfsFromList, then
discoveryTime in the result is at least s0.time.
theorem dfsFromList_white_to_nonwhite_disc_ge_time {fuel : Nat} {vs : List V}
{s0 : DFSState V} {v : V}
(hfuel : 0 < fuel)
(h_bf_s0 : ∀ w, s0.color w = Color.black → finishTime s0 w < s0.time)
(hwhite_s0 : s0.color v = Color.white)
(h_nonwhite_result : (dfsFromList G fuel vs s0).color v ≠ Color.white) :
discoveryTime (dfsFromList G fuel vs s0) v ≥ s0.time := by
induction vs generalizing s0 with
| nil =>
simp [dfsFromList] at h_nonwhite_result
rw [hwhite_s0] at h_nonwhite_result
contradiction
| cons u us ih =>
simp [dfsFromList] at h_nonwhite_result ⊢
by_cases hu_white : s0.color u = Color.white
· rw [if_pos hu_white] at h_nonwhite_result ⊢
let s1 := dfsVisit G fuel u s0
by_cases hv_white_s1 : s1.color v = Color.white
· -- v stayed white; apply IH on rest
have h_bf_s1 : ∀ w, s1.color w = Color.black → finishTime s1 w < s1.time := by
simpa [s1] using
dfsVisit_black_finish_lt_time (G := G) (fuel := fuel) (u := u) (s := s0) hfuel hu_white h_bf_s0
have h_time_ge_s1 : s1.time ≥ s0.time := G.dfsVisit_time_ge (fuel := fuel) (u := u) (s := s0)
have h_ih := ih (s0 := s1) h_bf_s1 hv_white_s1 h_nonwhite_result
exact le_trans h_time_ge_s1 h_ih
· -- v turned non-white during dfsVisit from u
have h_disc_ge : discoveryTime s1 v ≥ s0.time :=
dfsVisit_white_to_nonwhite_disc_ge_time G hfuel h_bf_s0 hwhite_s0 hv_white_s1
-- d[v] preserved through dfsFromList on rest
have h_black_s1 : s1.color v = Color.black := by
-- dfsVisit output has no gray for v ≠ u; v is non-white, so it's black
by_cases hvu : v = u
· subst v; exact dfsVisit_blackens_u_pos (G := G) hfuel hu_white
· have h_no_gray : s1.color v ≠ Color.gray := by
intro hg
have h_input_gray : s0.color v = Color.gray := dfsVisit_no_new_gray G v hg
rw [hwhite_s0] at h_input_gray; contradiction
cases hcolor : s1.color v with
| white => exact (hv_white_s1 hcolor).elim
| gray => exact (h_no_gray hcolor).elim
| black => rfl
have hd_preserved : (dfsFromList G fuel us s1).d v = s1.d v :=
dfsFromList_preserves_d_of_black G hfuel (x := v) h_black_s1
dsimp [discoveryTime] at h_disc_ge ⊢
rw [hd_preserved]
simpa [discoveryTime] using h_disc_ge
· rw [if_neg hu_white] at h_nonwhite_result ⊢
exact ih (s0 := s0) h_bf_s0 hwhite_s0 h_nonwhite_resultend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S4_SCC
DFS theory: finish-time ordering of SCCs
This file proves the key lemma connecting DFS timestamps to SCC finish-time ordering, and provides the discovery-state existence lemma.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V] (G : Graph V)section SCCFinishOrderingFinish-time ordering of SCCs
For a full DFS of G, if SCC C has an edge to a different SCC
D, then the maximum finish time in C is strictly larger than the
maximum finish time in D. This is Lemma 20.14 of CLRS and is the key
property used by Kosaraju's second pass.
The maximum finish time of a vertex set C after a full DFS.
open Classical innoncomputable def maxFinish (s : DFSState V) (C : Set V) : Nat :=
Finset.sup (@Finset.filter V (fun v => v ∈ C) (Classical.decPred (fun v => v ∈ C)) G.vertices)
(fun v => finishTime s v)
The maximum finish time is attained at some vertex of C.
theorem maxFinish_exists {s : DFSState V} {C : Set V} (hC : C.Nonempty) (hsub : C ⊆ G.vertices) :
∃ v ∈ C, maxFinish G s C = finishTime s v := by
rw [maxFinish]
let sC := @Finset.filter V (fun v => v ∈ C) (Classical.decPred (fun v => v ∈ C)) G.vertices
have hfin : sC.Nonempty := by
rcases hC with ⟨v, hvC⟩
have hvV : v ∈ G.vertices := hsub hvC
refine ⟨v, ?_⟩
simp [sC, hvV, hvC]
rcases Finset.exists_mem_eq_sup sC hfin (fun v => finishTime s v) with ⟨v, hv, heq⟩
use v
constructor
· simp [sC] at hv
exact hv.2
· exact heq
If v ∈ C then its finish time is at most the maximum finish time of
C.
theorem finish_le_maxFinish {s : DFSState V} {C : Set V} {v : V}
(hsub : C ⊆ G.vertices) (hv : v ∈ C) : finishTime s v ≤ maxFinish G s C := by
rw [maxFinish]
let sC := @Finset.filter V (fun x => x ∈ C) (Classical.decPred (fun x => x ∈ C)) G.vertices
have hV : v ∈ G.vertices := hsub hv
have hmem : v ∈ sC := by
simp [sC, hV, hv]
exact Finset.le_sup (s := sC) (f := fun x => finishTime s x) hmem
If every member of C has finish time at most n, then
Graph.maxFinish of C is at most n.
theorem maxFinish_le_of_forall_finish_le {s : DFSState V} {C : Set V} {n : Nat}
(hle : ∀ v ∈ C, finishTime s v ≤ n) :
maxFinish G s C ≤ n := by
rw [maxFinish]
apply Finset.sup_le
intro v hv
simp at hv
exact hle v hv.2
If c witnesses the maximum finish time of C, then every member
of C finishes no later than c.
theorem finish_le_maxFinish_witness {s : DFSState V} {C : Set V} {r c : V}
(hsub : C ⊆ G.vertices) (hr : r ∈ C)
(hc_max : maxFinish G s C = finishTime s c) :
finishTime s r ≤ finishTime s c := by
have h := finish_le_maxFinish G (s := s) (C := C) hsub hr
rw [hc_max] at h
exact h
If every finish time in C is at most the finish time of r ∈ C,
then r attains Graph.maxFinish.
theorem maxFinish_eq_of_forall_finish_le {s : DFSState V} {C : Set V} {r : V}
(hsub : C ⊆ G.vertices) (hr : r ∈ C)
(hle : ∀ v ∈ C, finishTime s v ≤ finishTime s r) :
maxFinish G s C = finishTime s r := by
apply Nat.le_antisymm
· exact maxFinish_le_of_forall_finish_le G hle
· exact finish_le_maxFinish G hsub hrFirst-discovered vertex
For a nonempty subset C of vertices, there exists a vertex in
C whose discovery time is minimal among all vertices in C.
theorem exists_firstDiscovered {s : DFSState V} {C : Set V}
(hC : C.Nonempty) (hsub : C ⊆ G.vertices) :
∃ r, r ∈ C ∧ ∀ v ∈ C, discoveryTime s r ≤ discoveryTime s v := by
let sC := @Finset.filter V (fun v => v ∈ C) (Classical.decPred (fun v => v ∈ C)) G.vertices
have h_sC : sC.Nonempty := by
rcases hC with ⟨v, hv⟩
have hvV : v ∈ G.vertices := hsub hv
refine ⟨v, ?_⟩
simp [sC, hvV, hv]
-- Image of discovery times on sC (a nonempty Finset of ℕ)
let times := Finset.image (fun v => discoveryTime s v) sC
have h_times : times.Nonempty := by
rcases h_sC with ⟨v, hv⟩
exact ⟨discoveryTime s v, Finset.mem_image.mpr ⟨v, hv, rfl⟩⟩
let m := times.min' h_times
have hm_mem : m ∈ times := Finset.min'_mem times h_times
rcases Finset.mem_image.mp hm_mem with ⟨r, hr_sC, hm⟩
have hrC : r ∈ C := by
simp [sC] at hr_sC; exact hr_sC.2
refine ⟨r, hrC, ?_⟩
intro v hv
have hvV : v ∈ G.vertices := hsub hv
have hv_sC : v ∈ sC := by
simp [sC, hvV, hv]
have : discoveryTime s v ∈ times := Finset.mem_image.mpr ⟨v, hv_sC, rfl⟩
have hm_le : m ≤ discoveryTime s v := Finset.min'_le times (discoveryTime s v) this
rw [hm]
exact hm_le
The vertex in C with minimum discovery time. Requires C to
be nonempty and a subset of G.vertices so the choice is well-defined.
open Classical innoncomputable def firstDiscoveredVertex (s : DFSState V) (C : Set V)
(hC : C.Nonempty) (hsub : C ⊆ G.vertices) : V :=
Classical.choose (exists_firstDiscovered G (s := s) (C := C) hC hsub)
The first-discovered vertex of C belongs to C.
theorem firstDiscoveredVertex_mem {s : DFSState V} {C : Set V}
(hC : C.Nonempty) (hsub : C ⊆ G.vertices) :
firstDiscoveredVertex G s C hC hsub ∈ C :=
(Classical.choose_spec (exists_firstDiscovered G (s := s) (C := C) hC hsub)).1
Every vertex in C has discovery time at least that of the
first-discovered vertex.
theorem firstDiscoveredVertex_min {s : DFSState V} {C : Set V} {v : V}
(hC : C.Nonempty) (hsub : C ⊆ G.vertices) (hv : v ∈ C) :
discoveryTime s (firstDiscoveredVertex G s C hC hsub) ≤ discoveryTime s v :=
(Classical.choose_spec (exists_firstDiscovered G (s := s) (C := C) hC hsub)).2 v hv
Bundled membership and minimality facts for Graph.firstDiscoveredVertex.
theorem firstDiscoveredVertex_mem_min {s : DFSState V} {C : Set V}
(hC : C.Nonempty) (hsub : C ⊆ G.vertices) :
let r := firstDiscoveredVertex G s C hC hsub
r ∈ C ∧ ∀ v ∈ C, discoveryTime s r ≤ discoveryTime s v := by
intro r
exact ⟨firstDiscoveredVertex_mem G (s := s) (C := C) hC hsub,
fun v hv => firstDiscoveredVertex_min G (s := s) (C := C) hC hsub hv⟩Discovery state of a vertex
For the SCC finish-time proof we need access to the discovery state of a
vertex v: the state just before dfsVisit is called with
v white. At this state the clock equals d[v] in the final DFS.
The lemma walks through the dfsFromList computation, handling both
top-level discovery (outer-loop dfsVisit) and nested discovery
(recursive dfsVisit inside a fold).
For a vertex v that is black in G.dfs, there exists a state
s and fuel f such that s is the input to the
dfsVisit call that discovers v: v is white in s,
the call blackens it, and discoveryTime (G.dfs) v = s.time.
Moreover, s satisfies DiscoveryTimeInvariant and the
black-finish invariant.
theorem exists_discovery_state (v : V) (hv : v ∈ G.vertices) :
∃ (s : DFSState V) (f : Nat),
s.color v = Color.white ∧
(dfsVisit G f v s).color v = Color.black ∧
discoveryTime (G.dfs) v = s.time ∧
(∀ w, s.color w ≠ Color.white → discoveryTime (G.dfs) w < s.time) ∧
(∀ w, s.color w = Color.black → finishTime s w < s.time) ∧
(∀ w, s.color w = Color.gray → G.Reachable w v) ∧
(∀ w, (dfsVisit G f v s).color w = Color.black →
finishTime (G.dfs) w = finishTime (dfsVisit G f v s) w) ∧
(f ≥ (whiteReachableSet G s v).card + 1) ∧
(∀ w, (dfsVisit G f v s).color w = Color.white →
(G.dfs).color w ≠ Color.white →
(dfsVisit G f v s).time ≤ discoveryTime (G.dfs) w) := by
set n := G.vertices.card + 1 with hn
have hn_pos : 0 < n := by
have hcard := Finset.card_pos.mpr ⟨v, hv⟩
omega
have h_dfs : G.dfs = dfsFromList G n G.vertices.toList dfsInit := rfl
-- We walk through the `dfsFromList` computation, carrying three invariants:
-- (ng) no gray vertices: ∀ w, s0.color w = Color.white ∨ s0.color w = Color.black
-- (bf) black-finish: ∀ w, s0.color w = Color.black → finishTime s0 w < s0.time
-- (disc) discovery-time: DiscoveryTimeInvariant (G := G) s0 (not needed directly)
-- All three hold for `dfsInit` and are preserved by `dfsVisit`.
have h_ind : ∀ (vs : List V) (s0 : DFSState V),
(∀ w, s0.color w = Color.white ∨ s0.color w = Color.black) →
(∀ w, s0.color w = Color.black → finishTime s0 w < s0.time) →
DiscoveryTimeInvariant s0 →
DiscoveryFinishInvariant s0 →
(s0.color v = Color.white) →
((dfsFromList G n vs s0).color v = Color.black) →
∃ (s : DFSState V) (f : Nat),
s.color v = Color.white ∧
(dfsVisit G f v s).color v = Color.black ∧
discoveryTime (dfsFromList G n vs s0) v = s.time ∧
(∀ w, s.color w ≠ Color.white → discoveryTime (dfsFromList G n vs s0) w < s.time) ∧
(∀ w, s.color w = Color.black → finishTime s w < s.time) ∧
(∀ w, s.color w = Color.gray → G.Reachable w v) ∧
(∀ w, (dfsVisit G f v s).color w = Color.black →
finishTime (dfsFromList G n vs s0) w = finishTime (dfsVisit G f v s) w) ∧
(f ≥ (whiteReachableSet G s v).card + 1) ∧
(∀ w, (dfsVisit G f v s).color w = Color.white →
(dfsFromList G n vs s0).color w ≠ Color.white →
(dfsVisit G f v s).time ≤ discoveryTime (dfsFromList G n vs s0) w) := by
intro vs s0 h_ng h_bf hdt h_df hwhite_s0 hblack_result
induction vs generalizing s0 with
| nil =>
simp [dfsFromList, hwhite_s0] at hblack_result
| cons u us ih =>
simp [dfsFromList] at hblack_result
by_cases hu_white : s0.color u = Color.white
· rw [if_pos hu_white] at hblack_result
set s1 := dfsVisit G n u s0 with hs1
-- Invariants are preserved through dfsVisit
have h_ng_s1 : ∀ w, s1.color w = Color.white ∨ s1.color w = Color.black :=
dfsVisit_output_no_gray (G := G) (fuel := n) (u := u) (s := s0) h_ng
have h_bf_s1 : ∀ w, s1.color w = Color.black → finishTime s1 w < s1.time :=
dfsVisit_black_finish_lt_time (G := G) (fuel := n) (u := u) (s := s0) hn_pos hu_white h_bf
have hdt_s1 : DiscoveryTimeInvariant s1 :=
dfsVisit_preserves_discoveryTimeInvariant (G := G) (fuel := n) (u := u) (s := s0)
hn_pos hu_white hdt h_bf h_df
have h_df_s1 : DiscoveryFinishInvariant s1 :=
dfsVisit_discovery_lt_finish (G := G) (fuel := n) (u := u) (s := s0) hn_pos hu_white h_df
by_cases hv_white_s1 : s1.color v = Color.white
· -- v stayed white; continue with the rest
rcases ih s1 h_ng_s1 h_bf_s1 hdt_s1 h_df_s1 hv_white_s1 hblack_result with
⟨s, f, hs, hf, hdisc, h_nonwhite_ih, h_bf_s_ih, h_gray_s_ih, h_f_pres_ih, h_fuel_ih, h_later_ih⟩
have h_nonwhite' : ∀ w, s.color w ≠ Color.white →
discoveryTime (dfsFromList G n (u :: us) s0) w < s.time := by
intro w hnw
have h := h_nonwhite_ih w hnw
simpa [dfsFromList, hu_white] using h
have h_f_pres' : ∀ w, (dfsVisit G f v s).color w = Color.black →
finishTime (dfsFromList G n (u :: us) s0) w = finishTime (dfsVisit G f v s) w := by
intro w hblack
have h := h_f_pres_ih w hblack
simpa [dfsFromList, hu_white] using h
have h_later' : ∀ w, (dfsVisit G f v s).color w = Color.white →
(dfsFromList G n (u :: us) s0).color w ≠ Color.white →
(dfsVisit G f v s).time ≤ discoveryTime (dfsFromList G n (u :: us) s0) w := by
intro w hw hfinal
have h := h_later_ih w hw (by simpa [dfsFromList, hu_white] using hfinal)
simpa [dfsFromList, hu_white] using h
refine ⟨s, f, hs, hf, ?_, h_nonwhite', h_bf_s_ih, h_gray_s_ih, h_f_pres', h_fuel_ih, h_later'⟩
dsimp [dfsFromList]; rw [if_pos hu_white]; exact hdisc
· -- v turned non-white during dfsVisit from u
by_cases hvu : v = u
· -- v = u: the accumulator s0 is the discovery state
subst v
have h_black_u : s1.color u = Color.black :=
dfsVisit_blackens_u_pos (G := G) hn_pos hu_white
have h_disc_src : discoveryTime s1 u = s0.time :=
dfsVisit_discovery_source G hn_pos hu_white
-- d[u] is preserved through the rest of dfsFromList
have hd_preserved : (dfsFromList G n us s1).d u = s1.d u :=
dfsFromList_preserves_d_of_black G hn_pos (x := u) h_black_u
-- h_nonwhite for s0: non-white w in s0 → d_final[w] < s0.time
have h_nonwhite_s0 : ∀ w, s0.color w ≠ Color.white →
discoveryTime (dfsFromList G n (u :: us) s0) w < s0.time := by
intro w hnw
have h_black_w : s0.color w = Color.black := by
rcases h_ng w with (hw | hb)
· exact (hnw hw).elim
· exact hb
have hne_wu : w ≠ u := by
intro heq; subst w; apply hnw; exact hu_white
have h_disc_lt_fin : discoveryTime s0 w < finishTime s0 w := h_df w h_black_w
have h_fin_lt_time : finishTime s0 w < s0.time := h_bf w h_black_w
-- d-preservation from s0 through dfsVisit u and dfsFromList us
have h_d_s1_eq : s1.d w = s0.d w :=
@dfsVisit_preserves_d_of_not_white V _ G n u w s0 hne_wu hnw
have h_black_s1 : s1.color w = Color.black :=
@dfsVisit_preserves_black V _ G n u w s0 h_black_w
have h_d_result_eq : (dfsFromList G n us s1).d w = s1.d w :=
dfsFromList_preserves_d_of_black G hn_pos (x := w) h_black_s1
have h_disc_result : discoveryTime (dfsFromList G n us s1) w = discoveryTime s0 w := by
dsimp [discoveryTime]; rw [h_d_result_eq, h_d_s1_eq]
-- Now: discoveryTime (dfsFromList (u::us) s0) w
-- = discoveryTime (dfsFromList us s1) w (since hu_white)
-- = discoveryTime s0 w (by h_disc_result)
-- < finishTime s0 w (by h_disc_lt_fin)
-- < s0.time (by h_fin_lt_time)
dsimp [dfsFromList]
rw [if_pos hu_white, h_disc_result]
omega
have h_f_preserved : ∀ w, s1.color w = Color.black →
finishTime (dfsFromList G n (u :: us) s0) w = finishTime s1 w := by
intro w hblack
dsimp [dfsFromList]; rw [if_pos hu_white]
have h := dfsFromList_preserves_f_of_black (G := G) (vs := us) hn_pos (x := w) hblack
rw [finishTime, finishTime, h]
have h_gray_s0 : ∀ w, s0.color w = Color.gray → G.Reachable w u := by
intro w hgray
rcases h_ng w with (hw | hb)
· rw [hw] at hgray; contradiction
· rw [hb] at hgray; contradiction
have h_fuel_bound : n ≥ (whiteReachableSet G s0 u).card + 1 := by
have hcard : (whiteReachableSet G s0 u).card ≤ G.vertices.card :=
Finset.card_le_card (whiteReachableSet_subset_vertices G s0 u hv)
dsimp [n]; omega
have h_later_s0 : ∀ w, s1.color w = Color.white →
(dfsFromList G n (u :: us) s0).color w ≠ Color.white →
s1.time ≤ discoveryTime (dfsFromList G n (u :: us) s0) w := by
intro w hwhite_w hfinal
dsimp [dfsFromList] at hfinal ⊢
rw [if_pos hu_white] at hfinal ⊢
exact dfsFromList_white_to_nonwhite_disc_ge_time G hn_pos h_bf_s1 hwhite_w hfinal
refine ⟨s0, n, hu_white, h_black_u, ?_, h_nonwhite_s0, h_bf, h_gray_s0, h_f_preserved, h_fuel_bound, h_later_s0⟩
dsimp [dfsFromList]
rw [if_pos hu_white, discoveryTime, hd_preserved, ← discoveryTime]
exact h_disc_src
· -- v ≠ u: v discovered inside dfsVisit from u
have hv_black_s1 : s1.color v = Color.black := by
rcases h_ng_s1 v with (hw | hb)
· exact (hv_white_s1 hw).elim
· exact hb
-- Name the step function to avoid lambda-matching issues
let step : DFSState V → V → DFSState V := fun s' x =>
if s'.color x = Color.white then dfsVisit G (n-1) x (s'.setParent x u) else s'
-- Use dfsVisit_fold_blackens_loc_prefix to find v in the outer fold
set s_init := s0.setColor u Color.gray |>.setDiscovery u with hs_init
have hwhite_v_init : s_init.color v = Color.white := by simp [s_init, hvu, hwhite_s0]
have h_bf_init : ∀ z, s_init.color z = Color.black →
finishTime s_init z < s_init.time := by
intro z hz
have hz0 : s0.color z = Color.black := by
simp [s_init] at hz
by_cases hzu : z = u; · subst z; simp at hz
· simpa [hzu] using hz
have h_fin : finishTime s_init z = finishTime s0 z := by simp [s_init, finishTime]
have h_time : s_init.time = s0.time + 1 := by simp [s_init]
rw [h_fin, h_time]; have h := h_bf z hz0; omega
have hdt_init : DiscoveryTimeInvariant s_init := by
intro z hnw
by_cases hzu : z = u
· subst z
simp [s_init, discoveryTime]
· have hnw0 : s0.color z ≠ Color.white := by
simpa [s_init, hzu] using hnw
have hblack0 : s0.color z = Color.black := by
rcases h_ng z with (hw | hb)
· exact False.elim (hnw0 hw)
· exact hb
have hd_eq : discoveryTime s_init z = discoveryTime s0 z := by
simp [s_init, discoveryTime, hzu]
have htime : s_init.time = s0.time + 1 := by simp [s_init]
have hdisc_lt_fin : discoveryTime s0 z < finishTime s0 z := h_df z hblack0
have hfin_lt_time : finishTime s0 z < s0.time := h_bf z hblack0
rw [hd_eq, htime]
omega
have hdf_init : DiscoveryFinishInvariant s_init := by
intro z hblack
have hzu : z ≠ u := by
intro h
subst z
simp [s_init] at hblack
have hblack0 : s0.color z = Color.black := by
simpa [s_init, hzu] using hblack
have hd_eq : discoveryTime s_init z = discoveryTime s0 z := by
simp [s_init, discoveryTime, hzu]
have hf_eq : finishTime s_init z = finishTime s0 z := by
simp [s_init, finishTime]
rw [hd_eq, hf_eq]
exact h_df z hblack0
have hcolor : (List.foldl step s_init (G.adj u).toList).color v = s1.color v := by
rw [hs1, dfsVisit, hu_white]
-- Goal: foldl.color v = (foldl.setColor u black |>.setFinish u).color v
-- Both setColor and setFinish don't change color for v ≠ u
have h_simplify : ((List.foldl step s_init (G.adj u).toList).setColor u Color.black |>.setFinish u).color v =
(List.foldl step s_init (G.adj u).toList).color v := by
simp [hvu]
apply h_simplify.symm
have hfold_black : (List.foldl step s_init (G.adj u).toList).color v = Color.black := by
rw [hcolor, hv_black_s1]
rcases dfsVisit_fold_blackens_loc_prefix_full G h_bf_init hdt_init hdf_init hwhite_v_init hfold_black
with ⟨pre, post, w, s2, hadj_eq, hs2_eq, hw_white, hv_white_s2, hw_disc_v, hmono_s2, hbf_s2, hdt_s2⟩
by_cases hw_eq_v : w = v
· -- w = v: v is directly discovered as u's neighbor.
-- Sub-problem 2: prove s1.d v = some (s2.time)
subst w
let s' := s2.setParent v u
have hs'_white : s'.color v = Color.white := by simp [s', hv_white_s2]
have hs'_time : s'.time = s2.time := by simp [s']
have hf'_black : (dfsVisit G (n-1) v s').color v = Color.black := hw_disc_v
have hfuel' : 0 < n-1 := by
have hcard : 1 ≤ G.vertices.card := Finset.card_pos.mpr ⟨v, hv⟩
dsimp [n]; omega
-- Step 1: d[v] in recursive call = some (s2.time)
have h_rec_d : (dfsVisit G (n-1) v s').d v = some (s2.time) := by
rw [← hs'_time]
exact dfsVisit_discovery_source_d_eq G hfuel' hs'_white
-- Step 2: d[v] preserved through rest of outer fold (post)
have h_fold_d : (List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G (n-1) x (s'.setParent x u) else s')
(dfsVisit G (n-1) v s') post).d v = (dfsVisit G (n-1) v s').d v :=
dfsVisit_fold_preserves_d_of_black G
(s1 := dfsVisit G (n-1) v s') (l := post) hf'_black
-- Step 3: s1.d v = some (s2.time) using the fold decomposition lemma
have h_s1_d : s1.d v = some (s2.time) := by
rw [hs1, dfsVisit, hu_white]
-- Goal: (foldl step s_init adj |>.setColor u black |>.setFinish u).d v = some (s2.time)
-- setColor/setFinish don't change d[v]
simp
-- Goal: (foldl step s_init (G.adj u).toList).d v = some (s2.time)
have h_fold_split := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hv_white_s2
-- From h_fold_split: full_fold = foldl step (dfsVisit ...) post
-- Take .d v on both sides, then chain with h_fold_d and h_rec_d
calc
(List.foldl step s_init (G.adj u).toList).d v
= (List.foldl step (dfsVisit G (n-1) v (s2.setParent v u)) post).d v := by
simpa using congrArg (fun f => f.d v) h_fold_split
_ = (List.foldl step (dfsVisit G (n-1) v s') post).d v := by simp [s']
_ = (dfsVisit G (n-1) v s').d v := by rw [h_fold_d]
_ = some (s2.time) := h_rec_d
-- Step 4: d preserved through dfsFromList
have h_result_d : (dfsFromList G n us s1).d v = s1.d v :=
dfsFromList_preserves_d_of_black G hn_pos (x := v) hv_black_s1
-- h_nonwhite for s' (fold accumulator): follows from fold invariants
have h_nonwhite_s' : ∀ w, s'.color w ≠ Color.white →
discoveryTime (dfsFromList G n (u :: us) s0) w < s'.time := by
intro x hnw
have hnw_s2 : s2.color x ≠ Color.white := by
simpa [s'] using hnw
have hlt_s2 : discoveryTime s2 x < s2.time := hdt_s2 x hnw_s2
have hx_ne_v : x ≠ v := by
intro hxv
subst x
exact hnw hs'_white
have hd_visit : (dfsVisit G (n - 1) v s').d x = s'.d x :=
dfsVisit_preserves_d_of_not_white G hx_ne_v hnw
have hnw_visit : (dfsVisit G (n - 1) v s').color x ≠ Color.white :=
dfsVisit_preserves_not_white G hx_ne_v hnw
have h_full_fold : List.foldl step s_init (G.adj u).toList =
List.foldl step (dfsVisit G (n - 1) v s') post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hv_white_s2
simpa [s'] using h
have h_post_d : (List.foldl step (dfsVisit G (n - 1) v s') post).d x =
(dfsVisit G (n - 1) v s').d x :=
dfsVisit_fold_preserves_d_of_not_white G
(u := u) (v := x) (s1 := dfsVisit G (n - 1) v s') (l := post) hnw_visit
have h_s1_d_x : s1.d x = s2.d x := by
rw [hs1, dfsVisit, hu_white]
simp
calc
(List.foldl step s_init (G.adj u).toList).d x
= (List.foldl step (dfsVisit G (n - 1) v s') post).d x := by
simpa using congrArg (fun st => st.d x) h_full_fold
_ = (dfsVisit G (n - 1) v s').d x := h_post_d
_ = s'.d x := hd_visit
_ = s2.d x := by simp [s']
have hnw_s1 : s1.color x ≠ Color.white := by
by_cases hxu : x = u
· subst x
have hblack_u : s1.color u = Color.black := by
have h := dfsVisit_blackens_u_pos (G := G) hn_pos hu_white
simpa [hs1] using h
rw [hblack_u]
decide
· have hnw_post :
(List.foldl step (dfsVisit G (n - 1) v s') post).color x ≠ Color.white :=
dfsVisit_fold_preserves_not_white G
(u := u) (v := x) (s1 := dfsVisit G (n - 1) v s') (l := post)
hxu hnw_visit
intro hwhite_s1
have hwhite_full : (List.foldl step s_init (G.adj u).toList).color x = Color.white := by
rw [hs1, dfsVisit, hu_white] at hwhite_s1
simpa [step, s_init, hn, hxu] using hwhite_s1
rw [h_full_fold] at hwhite_full
exact hnw_post hwhite_full
have hblack_s1_x : s1.color x = Color.black := by
rcases h_ng_s1 x with (hw | hb)
· exact False.elim (hnw_s1 hw)
· exact hb
have h_final_d : (dfsFromList G n (u :: us) s0).d x = s2.d x := by
dsimp [dfsFromList]
rw [if_pos hu_white]
calc
(dfsFromList G n us s1).d x = s1.d x :=
dfsFromList_preserves_d_of_black G hn_pos (x := x) hblack_s1_x
_ = s2.d x := h_s1_d_x
dsimp [discoveryTime] at hlt_s2 ⊢
rw [h_final_d]
simpa [s'] using hlt_s2
have h_bf_s' : ∀ w, s'.color w = Color.black → finishTime s' w < s'.time := by
intro w hblack
have hblack_s2 : s2.color w = Color.black := by
simpa [s'] using hblack
have h_lt : finishTime s2 w < s2.time := hbf_s2 w hblack_s2
simpa [s', finishTime] using h_lt
have hs2_gray_u : s2.color u = Color.gray := by
rw [hs2_eq]
have hfold : ∀ (l : List V) (t : DFSState V),
t.color u = Color.gray →
(List.foldl step t l).color u = Color.gray := by
intro l
induction l with
| nil =>
intro t ht
simpa using ht
| cons x xs ihxs =>
intro t ht
simp [step]
by_cases hx : t.color x = Color.white
· simp [hx]
apply ihxs
have hsp : (t.setParent x u).color u = Color.gray := by
simp [ht]
have hne : u ≠ x := by
intro hux
subst x
rw [ht] at hx
contradiction
exact dfsVisit_preserves_gray G hsp hne
· simp [hx]
exact ihxs t ht
exact hfold pre s_init (by simp [s_init])
have hs'_u_gray : s'.color u = Color.gray := by
simp [s', hs2_gray_u]
have h_f_pres_s' : ∀ w, (dfsVisit G (n-1) v s').color w = Color.black →
finishTime (dfsFromList G n (u :: us) s0) w = finishTime (dfsVisit G (n-1) v s') w := by
intro w hblack_w
dsimp [dfsFromList]; rw [if_pos hu_white]
-- Goal: finishTime (dfsFromList G n us s1) w = finishTime (dfsVisit ... v s') w
-- Step 1: through dfsFromList us (w black in s1 → f preserved)
have hblack_s1 : s1.color w = Color.black := by
have h_full_fold : List.foldl step s_init (G.adj u).toList =
List.foldl step (dfsVisit G (n - 1) v s') post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hv_white_s2
simpa [s'] using h
have hpost_black :
(List.foldl step (dfsVisit G (n - 1) v s') post).color w = Color.black :=
dfsVisit_fold_preserves_black G
(u := u) (x := w) (s1 := dfsVisit G (n - 1) v s') (l := post) hblack_w
rw [hs1, dfsVisit, hu_white]
by_cases hwu : w = u
· subst w
simp
· have hfull_black : (List.foldl step s_init (G.adj u).toList).color w = Color.black := by
rw [h_full_fold]
exact hpost_black
simpa [hwu, hfull_black]
have h_f1 : finishTime (dfsFromList G n us s1) w = finishTime s1 w := by
have h := dfsFromList_preserves_f_of_black (G := G) (vs := us) hn_pos (x := w) hblack_s1
rw [finishTime, finishTime, h]
-- Step 2: s1.w = ... = s_rec.w (through outer fold and setFinish)
-- s1 = s_fold.setColor u black |>.setFinish u
-- where s_fold = foldl step s_init (G.adj u).toList
-- Using the fold decomposition: s_fold's f[w] = s_rec's f[w] (by fold f-preservation)
have h_f2 : finishTime s1 w = finishTime (dfsVisit G (n-1) v s') w := by
have hwu : w ≠ u := by
intro h
subst w
have hu_gray_out : (dfsVisit G (n - 1) v s').color u = Color.gray := by
have huv : u ≠ v := by
intro huv
exact hvu huv.symm
exact dfsVisit_preserves_gray G hs'_u_gray huv
rw [hu_gray_out] at hblack_w
contradiction
have h_full_fold : List.foldl step s_init (G.adj u).toList =
List.foldl step (dfsVisit G (n - 1) v s') post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hv_white_s2
simpa [s'] using h
have hpost_f : (List.foldl step (dfsVisit G (n - 1) v s') post).f w =
(dfsVisit G (n - 1) v s').f w :=
dfsVisit_fold_preserves_f_of_black G
(u := u) (v := w) (s1 := dfsVisit G (n - 1) v s') (l := post) hblack_w
have hs1_f_full : s1.f w = (List.foldl step s_init (G.adj u).toList).f w := by
rw [hs1, dfsVisit, hu_white]
simp [step, s_init, hn, hwu]
have hs1_f : s1.f w =
(List.foldl step (dfsVisit G (n - 1) v s') post).f w := by
rw [hs1_f_full, h_full_fold]
rw [finishTime, finishTime, hs1_f, hpost_f]
rw [h_f1, h_f2]
have h_fuel_s' : (n-1) ≥ (whiteReachableSet G s' v).card + 1 := by
have hnot_u : u ∉ whiteReachableSet G s' v := by
intro huin
have hwr : WhiteReachable G s' v u :=
(mem_whiteReachableSet_iff G hv).mp huin
have hu_white : s'.color u = Color.white :=
whiteReachable_target_white G hs'_white hwr
rw [hs'_u_gray] at hu_white
contradiction
have hsub_vertices : whiteReachableSet G s' v ⊆ G.vertices :=
whiteReachableSet_subset_vertices G s' v hv
have hu_vertices : u ∈ G.vertices := by
have hv_mem : v ∈ (G.adj u).toList := by
rw [hadj_eq]
simp
have hadj_uv : G.Adj u v := by
simpa [Graph.Adj, Finset.mem_toList] using hv_mem
exact G.adj_mem_left hadj_uv
have hcard_le : (whiteReachableSet G s' v).card ≤ (G.vertices.erase u).card := by
apply Finset.card_le_card
intro x hx
have hxV : x ∈ G.vertices := hsub_vertices hx
have hxu : x ≠ u := by
intro h
subst x
exact hnot_u hx
simp [hxV, hxu]
have herase : (G.vertices.erase u).card = G.vertices.card - 1 :=
Finset.card_erase_of_mem hu_vertices
dsimp [n]
omega
have h_gray_s' : ∀ w, s'.color w = Color.gray → G.Reachable w v := by
intro z hz
have hz2 : s2.color z = Color.gray := by
simpa [s'] using hz
have hz_init : s_init.color z = Color.gray := by
rw [hs2_eq] at hz2
exact dfsVisit_fold_no_new_gray G s_init hz2
have hzu : z = u := by
by_cases hzu : z = u
· exact hzu
· have hz0 : s0.color z = Color.gray := by
simp [s_init, hzu] at hz_init
exact hz_init
rcases h_ng z with (hw | hb)
· rw [hw] at hz0; contradiction
· rw [hb] at hz0; contradiction
subst z
have hadj_uv : G.Adj u v := by
have hv_mem : v ∈ (G.adj u).toList := by
rw [hadj_eq]
simp
simpa [Graph.Adj, Finset.mem_toList] using hv_mem
exact Relation.ReflTransGen.single hadj_uv
have h_later_s' : ∀ w, (dfsVisit G (n - 1) v s').color w = Color.white →
(dfsFromList G n (u :: us) s0).color w ≠ Color.white →
(dfsVisit G (n - 1) v s').time ≤
discoveryTime (dfsFromList G n (u :: us) s0) w := by
intro x hwhite_rec hfinal
dsimp [dfsFromList] at hfinal ⊢
rw [if_pos hu_white] at hfinal ⊢
have h_full_fold : List.foldl step s_init (G.adj u).toList =
List.foldl step (dfsVisit G (n - 1) v s') post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hv_white_s2
simpa [s'] using h
have h_full_fold_time :
(List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G G.vertices.card x (s'.setParent x u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).time =
(List.foldl step (dfsVisit G (n - 1) v s') post).time := by
simpa [step, s_init, hn] using congrArg (fun st => st.time) h_full_fold
have htime_to_s1 : (dfsVisit G (n - 1) v s').time ≤ s1.time := by
have htime_post : (dfsVisit G (n - 1) v s').time ≤
(List.foldl step (dfsVisit G (n - 1) v s') post).time := by
simpa using dfsVisit_fold_time_ge G
(u := u) (s1 := dfsVisit G (n - 1) v s') (l := post)
have htime_s1 : s1.time =
(List.foldl step (dfsVisit G (n - 1) v s') post).time + 1 := by
rw [hs1, dfsVisit, hu_white]
simp [h_full_fold_time]
omega
by_cases hwhite_s1_x : s1.color x = Color.white
· have h_disc_ge :=
dfsFromList_white_to_nonwhite_disc_ge_time G hn_pos h_bf_s1 hwhite_s1_x hfinal
exact le_trans htime_to_s1 h_disc_ge
· have hxu : x ≠ u := by
intro h
subst x
have huv : u ≠ v := by
intro huv
exact hvu huv.symm
have hu_gray_rec : (dfsVisit G (n - 1) v s').color u = Color.gray :=
dfsVisit_preserves_gray G hs'_u_gray huv
rw [hu_gray_rec] at hwhite_rec
contradiction
have h_s1_color : s1.color x =
(List.foldl step (dfsVisit G (n - 1) v s') post).color x := by
have h_full_fold_color :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).color x =
(List.foldl step (dfsVisit G (n - 1) v s') post).color x := by
simpa [step, s_init, hn] using congrArg (fun st => st.color x) h_full_fold
rw [hs1, dfsVisit, hu_white]
simp [hxu, h_full_fold_color]
have h_nonwhite_post :
(List.foldl step (dfsVisit G (n - 1) v s') post).color x ≠ Color.white := by
intro hpost
apply hwhite_s1_x
rw [h_s1_color, hpost]
have h_bf_rec : ∀ z, (dfsVisit G (n - 1) v s').color z = Color.black →
finishTime (dfsVisit G (n - 1) v s') z <
(dfsVisit G (n - 1) v s').time :=
dfsVisit_black_finish_lt_time G hfuel' hs'_white h_bf_s'
have h_disc_ge_post :
(dfsVisit G (n - 1) v s').time ≤
discoveryTime (List.foldl step (dfsVisit G (n - 1) v s') post) x :=
dfsVisit_fold_white_to_nonwhite_disc_ge_time G hfuel' h_bf_rec hwhite_rec h_nonwhite_post
have h_s1_d : s1.d x =
(List.foldl step (dfsVisit G (n - 1) v s') post).d x := by
have h_full_fold_d :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).d x =
(List.foldl step (dfsVisit G (n - 1) v s') post).d x := by
simpa [step, s_init, hn] using congrArg (fun st => st.d x) h_full_fold
rw [hs1, dfsVisit, hu_white]
simp [h_full_fold_d]
have hblack_s1_x : s1.color x = Color.black := by
rcases h_ng_s1 x with (hw | hb)
· exact False.elim (hwhite_s1_x hw)
· exact hb
have h_final_d : (dfsFromList G n us s1).d x = s1.d x :=
dfsFromList_preserves_d_of_black G hn_pos (x := x) hblack_s1_x
dsimp [discoveryTime] at h_disc_ge_post ⊢
rw [h_final_d, h_s1_d]
exact h_disc_ge_post
refine ⟨s', n-1, hs'_white, hf'_black, ?_, h_nonwhite_s', h_bf_s', h_gray_s', h_f_pres_s', h_fuel_s', h_later_s'⟩
dsimp [discoveryTime, dfsFromList]
rw [if_pos hu_white, h_result_d, h_s1_d, hs'_time]; simp
· -- w ≠ v: v is discovered inside dfsVisit on w. Use induction on
-- the white-vertex count (same as dfsVisit_discovery_state).
let s_input := s2.setParent w u
have hwhite_w_input : s_input.color w = Color.white := by
simp [s_input, hw_white]
have hwhite_v_input : s_input.color v = Color.white := by
simp [s_input, hv_white_s2]
have hblack_v_input : (dfsVisit G (n - 1) w s_input).color v = Color.black := by
simpa [s_input] using hw_disc_v
have hfuel_rec_pos : 0 < n - 1 := by
have hcard : 1 ≤ G.vertices.card := Finset.card_pos.mpr ⟨v, hv⟩
dsimp [n]
omega
have hadj_uw : G.Adj u w := by
have hw_mem : w ∈ (G.adj u).toList := by
rw [hadj_eq]
simp
simpa [Graph.Adj, Finset.mem_toList] using hw_mem
have hu_vertices : u ∈ G.vertices := G.adj_mem_left hadj_uw
have hw_vertices : w ∈ G.vertices := G.adj_mem_right hadj_uw
have hs2_gray_u : s2.color u = Color.gray := by
rw [hs2_eq]
have hfold : ∀ (l : List V) (t : DFSState V),
t.color u = Color.gray →
(List.foldl step t l).color u = Color.gray := by
intro l
induction l with
| nil =>
intro t ht
simpa using ht
| cons x xs ihxs =>
intro t ht
simp [step]
by_cases hx : t.color x = Color.white
· simp [hx]
apply ihxs
have hsp : (t.setParent x u).color u = Color.gray := by
simp [ht]
have hne : u ≠ x := by
intro hux
subst x
rw [ht] at hx
contradiction
exact dfsVisit_preserves_gray G hsp hne
· simp [hx]
exact ihxs t ht
exact hfold pre s_init (by simp [s_init])
have hinput_u_gray : s_input.color u = Color.gray := by
simp [s_input, hs2_gray_u]
have huw : u ≠ w := by
intro h
subst w
rw [hs2_gray_u] at hw_white
contradiction
have h_fuel_input : (n - 1) ≥ (whiteReachableSet G s_input w).card + 1 := by
have hnot_u : u ∉ whiteReachableSet G s_input w := by
intro huin
have hwr : WhiteReachable G s_input w u :=
(mem_whiteReachableSet_iff G hw_vertices).mp huin
have hu_white : s_input.color u = Color.white :=
whiteReachable_target_white G hwhite_w_input hwr
rw [hinput_u_gray] at hu_white
contradiction
have hsub_vertices : whiteReachableSet G s_input w ⊆ G.vertices :=
whiteReachableSet_subset_vertices G s_input w hw_vertices
have hcard_le : (whiteReachableSet G s_input w).card ≤ (G.vertices.erase u).card := by
apply Finset.card_le_card
intro x hx
have hxV : x ∈ G.vertices := hsub_vertices hx
have hxu : x ≠ u := by
intro h
subst x
exact hnot_u hx
simp [hxV, hxu]
have herase : (G.vertices.erase u).card = G.vertices.card - 1 :=
Finset.card_erase_of_mem hu_vertices
dsimp [n]
omega
have hdt_input : DiscoveryTimeInvariant s_input := by
intro z hnw
have hnw2 : s2.color z ≠ Color.white := by
simpa [s_input] using hnw
have hlt := hdt_s2 z hnw2
simpa [s_input, discoveryTime] using hlt
have hdf_s2 : DiscoveryFinishInvariant s2 := by
rw [hs2_eq]
exact dfsVisit_fold_preserves_discoveryFinishInvariant (G := G) (n := n - 1)
(u := u) (s1 := s_init) (l := pre) hdt_init h_bf_init hdf_init
have hdf_input : DiscoveryFinishInvariant s_input := by
intro z hblack
have hblack2 : s2.color z = Color.black := by
simpa [s_input] using hblack
have h := hdf_s2 z hblack2
simpa [s_input, discoveryTime, finishTime] using h
have h_bf_input : ∀ z, s_input.color z = Color.black → finishTime s_input z < s_input.time := by
intro z hblack
have hblack2 : s2.color z = Color.black := by
simpa [s_input] using hblack
have h := hbf_s2 z hblack2
simpa [s_input, finishTime] using h
have hgray_input : ∀ z, s_input.color z = Color.gray → G.Reachable z w := by
intro z hz
have hz2 : s2.color z = Color.gray := by
simpa [s_input] using hz
have hz_init : s_init.color z = Color.gray := by
rw [hs2_eq] at hz2
exact dfsVisit_fold_no_new_gray G s_init hz2
have hzu : z = u := by
by_cases hzu : z = u
· exact hzu
· have hz0 : s0.color z = Color.gray := by
simp [s_init, hzu] at hz_init
exact hz_init
rcases h_ng z with (hw0 | hb0)
· rw [hw0] at hz0; contradiction
· rw [hb0] at hz0; contradiction
subst z
exact Relation.ReflTransGen.single hadj_uw
have hwreach : WhiteReachable G s_input w v :=
dfsVisit_blackens_implies_whiteReachable G hwhite_w_input hfuel_rec_pos
hwhite_v_input hblack_v_input
rcases dfsVisit_discovery_bridge G h_fuel_input hwhite_w_input
hdt_input h_bf_input hdf_input hblack_v_input hwreach hwhite_v_input hgray_input with
⟨s_rec, f_rec, hs_rec_white, hf_rec_black, hdisc_rec, h_nonwhite_rec,
h_bf_rec_state, h_gray_rec, h_nonwhite_pres_rec, h_f_pres_rec,
h_fuel_rec, h_later_rec⟩
have h_full_fold : List.foldl step s_init (G.adj u).toList =
List.foldl step (dfsVisit G (n - 1) w s_input) post := by
have h := dfsVisit_fold_split_at_white_neighbor G
s_init pre post s2 hadj_eq hs2_eq hw_white
simpa [s_input] using h
have h_s1_d_of_rec_not_white : ∀ x,
(dfsVisit G (n - 1) w s_input).color x ≠ Color.white →
s1.d x = (dfsVisit G (n - 1) w s_input).d x := by
intro x hnw_rec
have h_post_d : (List.foldl step (dfsVisit G (n - 1) w s_input) post).d x =
(dfsVisit G (n - 1) w s_input).d x :=
dfsVisit_fold_preserves_d_of_not_white G
(u := u) (v := x) (s1 := dfsVisit G (n - 1) w s_input) (l := post) hnw_rec
rw [hs1, dfsVisit, hu_white]
simp
calc
(List.foldl step s_init (G.adj u).toList).d x
= (List.foldl step (dfsVisit G (n - 1) w s_input) post).d x := by
simpa using congrArg (fun st => st.d x) h_full_fold
_ = (dfsVisit G (n - 1) w s_input).d x := h_post_d
have h_s1_nonwhite_of_rec : ∀ x,
(dfsVisit G (n - 1) w s_input).color x ≠ Color.white →
s1.color x ≠ Color.white := by
intro x hnw_rec
rw [hs1, dfsVisit, hu_white]
by_cases hxu : x = u
· subst x
simp
· have hpost_nw :
(List.foldl step (dfsVisit G (n - 1) w s_input) post).color x ≠ Color.white :=
dfsVisit_fold_preserves_not_white G
(u := u) (v := x) (s1 := dfsVisit G (n - 1) w s_input) (l := post)
hxu hnw_rec
have h_full_fold_color :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).color x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).color x := by
simpa [step, s_init, hn] using congrArg (fun st => st.color x) h_full_fold
simpa [hxu, h_full_fold_color] using hpost_nw
have h_s1_f_of_rec_black : ∀ x,
(dfsVisit G (n - 1) w s_input).color x = Color.black →
finishTime s1 x = finishTime (dfsVisit G (n - 1) w s_input) x := by
intro x hblack_rec
have hxu : x ≠ u := by
intro h
subst x
have hrec_u_gray : (dfsVisit G (n - 1) w s_input).color u = Color.gray :=
dfsVisit_preserves_gray G hinput_u_gray huw
rw [hrec_u_gray] at hblack_rec
contradiction
have hpost_f : (List.foldl step (dfsVisit G (n - 1) w s_input) post).f x =
(dfsVisit G (n - 1) w s_input).f x :=
dfsVisit_fold_preserves_f_of_black G
(u := u) (v := x) (s1 := dfsVisit G (n - 1) w s_input) (l := post) hblack_rec
have h_full_fold_f :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).f x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).f x := by
simpa [step, s_init, hn] using congrArg (fun st => st.f x) h_full_fold
rw [hs1, dfsVisit, hu_white]
simp [finishTime, hxu, h_full_fold_f, hpost_f]
have h_sub_time_le_rec : (dfsVisit G f_rec v s_rec).time ≤
(dfsVisit G (n - 1) w s_input).time := by
have hf_rec_pos : 0 < f_rec := by
omega
have hfinish_src :
finishTime (dfsVisit G f_rec v s_rec) v =
(dfsVisit G f_rec v s_rec).time - 1 :=
dfsVisit_finishTime_source_eq_pred_time G hf_rec_pos hs_rec_white
have hlocal_v := h_f_pres_rec v hf_rec_black
have hfinish_lt :
finishTime (dfsVisit G (n - 1) w s_input) v <
(dfsVisit G (n - 1) w s_input).time :=
dfsVisit_black_finish_lt_time G hfuel_rec_pos hwhite_w_input h_bf_input
v hlocal_v.1
rw [hlocal_v.2, hfinish_src] at hfinish_lt
have htime_pos : (dfsVisit G f_rec v s_rec).time > 0 := by
have hgt := dfsVisit_time_gt_of_white G hf_rec_pos hs_rec_white
exact lt_of_le_of_lt (Nat.zero_le s_rec.time) hgt
omega
have h_rec_time_le_s1 : (dfsVisit G (n - 1) w s_input).time ≤ s1.time := by
have htime_post : (dfsVisit G (n - 1) w s_input).time ≤
(List.foldl step (dfsVisit G (n - 1) w s_input) post).time :=
dfsVisit_fold_time_ge G
(u := u) (s1 := dfsVisit G (n - 1) w s_input) (l := post)
have h_full_fold_time :
(List.foldl (fun s' x =>
if s'.color x = Color.white then dfsVisit G G.vertices.card x (s'.setParent x u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).time =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).time := by
simpa [step, s_init, hn] using congrArg (fun st => st.time) h_full_fold
have htime_s1 : s1.time =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).time + 1 := by
rw [hs1, dfsVisit, hu_white]
simp [h_full_fold_time]
omega
have h_sub_time_le_s1 : (dfsVisit G f_rec v s_rec).time ≤ s1.time :=
le_trans h_sub_time_le_rec h_rec_time_le_s1
have h_nonwhite_s_rec : ∀ x, s_rec.color x ≠ Color.white →
discoveryTime (dfsFromList G n (u :: us) s0) x < s_rec.time := by
intro x hnw
have hlt_rec := h_nonwhite_rec x hnw
have hnw_rec := h_nonwhite_pres_rec x hnw
have h_s1_d_x := h_s1_d_of_rec_not_white x hnw_rec
have hnw_s1 := h_s1_nonwhite_of_rec x hnw_rec
have hblack_s1_x : s1.color x = Color.black := by
rcases h_ng_s1 x with (hw0 | hb0)
· exact False.elim (hnw_s1 hw0)
· exact hb0
have h_final_d : (dfsFromList G n us s1).d x = s1.d x :=
dfsFromList_preserves_d_of_black G hn_pos (x := x) hblack_s1_x
dsimp [dfsFromList]
rw [if_pos hu_white]
change discoveryTime (dfsFromList G n us s1) x < s_rec.time
dsimp [discoveryTime] at hlt_rec ⊢
rw [h_final_d, h_s1_d_x]
exact hlt_rec
have h_f_pres_s_rec : ∀ x, (dfsVisit G f_rec v s_rec).color x = Color.black →
finishTime (dfsFromList G n (u :: us) s0) x =
finishTime (dfsVisit G f_rec v s_rec) x := by
intro x hblack_sub
have hlocal := h_f_pres_rec x hblack_sub
have hnw_s1 : s1.color x ≠ Color.white :=
h_s1_nonwhite_of_rec x (by rw [hlocal.1]; decide)
have hblack_s1_x : s1.color x = Color.black := by
rcases h_ng_s1 x with (hw0 | hb0)
· exact False.elim (hnw_s1 hw0)
· exact hb0
have h_f_rest : finishTime (dfsFromList G n us s1) x = finishTime s1 x := by
have h := dfsFromList_preserves_f_of_black (G := G) (vs := us) hn_pos
(x := x) hblack_s1_x
rw [finishTime, finishTime, h]
dsimp [dfsFromList]
rw [if_pos hu_white]
calc
finishTime (dfsFromList G n us s1) x = finishTime s1 x := h_f_rest
_ = finishTime (dfsVisit G (n - 1) w s_input) x :=
h_s1_f_of_rec_black x hlocal.1
_ = finishTime (dfsVisit G f_rec v s_rec) x := hlocal.2
have h_later_s_rec : ∀ x, (dfsVisit G f_rec v s_rec).color x = Color.white →
(dfsFromList G n (u :: us) s0).color x ≠ Color.white →
(dfsVisit G f_rec v s_rec).time ≤
discoveryTime (dfsFromList G n (u :: us) s0) x := by
intro x hwhite_sub hfinal
dsimp [dfsFromList] at hfinal ⊢
rw [if_pos hu_white] at hfinal ⊢
by_cases hwhite_s1_x : s1.color x = Color.white
· have h_disc_ge :=
dfsFromList_white_to_nonwhite_disc_ge_time G hn_pos h_bf_s1 hwhite_s1_x hfinal
exact le_trans h_sub_time_le_s1 h_disc_ge
· have hblack_s1_x : s1.color x = Color.black := by
rcases h_ng_s1 x with (hw0 | hb0)
· exact False.elim (hwhite_s1_x hw0)
· exact hb0
by_cases hwhite_rec_x :
(dfsVisit G (n - 1) w s_input).color x = Color.white
· have hxu : x ≠ u := by
intro h
subst x
have hrec_u_gray : (dfsVisit G (n - 1) w s_input).color u = Color.gray :=
dfsVisit_preserves_gray G hinput_u_gray huw
rw [hrec_u_gray] at hwhite_rec_x
contradiction
have h_s1_color_x : s1.color x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).color x := by
have h_full_fold_color :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).color x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).color x := by
simpa [step, s_init, hn] using congrArg (fun st => st.color x) h_full_fold
rw [hs1, dfsVisit, hu_white]
simpa [hxu] using h_full_fold_color
have h_nonwhite_post :
(List.foldl step (dfsVisit G (n - 1) w s_input) post).color x ≠
Color.white := by
intro hpost
apply hwhite_s1_x
rw [h_s1_color_x, hpost]
have h_bf_rec_out : ∀ z,
(dfsVisit G (n - 1) w s_input).color z = Color.black →
finishTime (dfsVisit G (n - 1) w s_input) z <
(dfsVisit G (n - 1) w s_input).time :=
dfsVisit_black_finish_lt_time G hfuel_rec_pos hwhite_w_input h_bf_input
have h_disc_ge_post :
(dfsVisit G (n - 1) w s_input).time ≤
discoveryTime (List.foldl step (dfsVisit G (n - 1) w s_input) post) x :=
dfsVisit_fold_white_to_nonwhite_disc_ge_time G hfuel_rec_pos
h_bf_rec_out hwhite_rec_x h_nonwhite_post
have h_s1_d_fold_x : s1.d x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).d x := by
have h_full_fold_d :
(List.foldl (fun s' y =>
if s'.color y = Color.white then dfsVisit G G.vertices.card y (s'.setParent y u) else s')
((s0.setColor u Color.gray).setDiscovery u) (G.adj u).toList).d x =
(List.foldl step (dfsVisit G (n - 1) w s_input) post).d x := by
simpa [step, s_init, hn] using congrArg (fun st => st.d x) h_full_fold
rw [hs1, dfsVisit, hu_white]
simp
exact h_full_fold_d
have h_final_d : (dfsFromList G n us s1).d x = s1.d x :=
dfsFromList_preserves_d_of_black G hn_pos (x := x) hblack_s1_x
dsimp [discoveryTime] at h_disc_ge_post ⊢
rw [h_final_d, h_s1_d_fold_x]
exact le_trans h_sub_time_le_rec h_disc_ge_post
· have h_later_rec_x := h_later_rec x hwhite_sub hwhite_rec_x
have h_s1_d_x := h_s1_d_of_rec_not_white x hwhite_rec_x
have h_final_d : (dfsFromList G n us s1).d x = s1.d x :=
dfsFromList_preserves_d_of_black G hn_pos (x := x) hblack_s1_x
dsimp [discoveryTime] at h_later_rec_x ⊢
rw [h_final_d, h_s1_d_x]
exact h_later_rec_x
refine ⟨s_rec, f_rec, hs_rec_white, hf_rec_black, ?_,
h_nonwhite_s_rec, h_bf_rec_state, h_gray_rec, ?_, h_fuel_rec, h_later_s_rec⟩
have h_rec_nonwhite_v : (dfsVisit G (n - 1) w s_input).color v ≠ Color.white := by
rw [hblack_v_input]
decide
have h_s1_d_v := h_s1_d_of_rec_not_white v h_rec_nonwhite_v
have h_result_d : (dfsFromList G n us s1).d v = s1.d v :=
dfsFromList_preserves_d_of_black G hn_pos (x := v) hv_black_s1
· dsimp [dfsFromList]
rw [if_pos hu_white]
change discoveryTime (dfsFromList G n us s1) v = s_rec.time
dsimp [discoveryTime] at hdisc_rec ⊢
rw [h_result_d, h_s1_d_v]
exact hdisc_rec
· intro x hblack_sub
exact h_f_pres_s_rec x hblack_sub
· -- u not white; skip
rw [if_neg hu_white] at hblack_result
rcases ih s0 h_ng h_bf hdt h_df hwhite_s0 hblack_result with
⟨s, f, hs, hf, hdisc, h_nonwhite_ih, h_bf_s_ih, h_gray_s_ih, h_f_pres_ih, h_fuel_ih, h_later_ih⟩
have h_nonwhite' : ∀ w, s.color w ≠ Color.white →
discoveryTime (dfsFromList G n (u :: us) s0) w < s.time := by
intro w hnw; have h := h_nonwhite_ih w hnw
simpa [dfsFromList, hu_white] using h
have h_f_pres' : ∀ w, (dfsVisit G f v s).color w = Color.black →
finishTime (dfsFromList G n (u :: us) s0) w = finishTime (dfsVisit G f v s) w := by
intro w hblack; have h := h_f_pres_ih w hblack
simpa [dfsFromList, hu_white] using h
have h_later' : ∀ w, (dfsVisit G f v s).color w = Color.white →
(dfsFromList G n (u :: us) s0).color w ≠ Color.white →
(dfsVisit G f v s).time ≤ discoveryTime (dfsFromList G n (u :: us) s0) w := by
intro w hw hfinal
have h := h_later_ih w hw (by simpa [dfsFromList, hu_white] using hfinal)
simpa [dfsFromList, hu_white] using h
refine ⟨s, f, hs, hf, ?_, h_nonwhite', h_bf_s_ih, h_gray_s_ih, h_f_pres', h_fuel_ih, h_later'⟩
dsimp [dfsFromList]; rw [if_neg hu_white]; exact hdisc
-- Start from dfsInit
have hwhite_init : (dfsInit (V := V)).color v = Color.white := rfl
have h_ng_init : ∀ (w : V), (dfsInit (V := V)).color w = Color.white ∨ (dfsInit (V := V)).color w = Color.black :=
λ (w : V) => Or.inl rfl
have h_bf_init : ∀ (w : V), (dfsInit (V := V)).color w = Color.black → finishTime (dfsInit (V := V)) w < (dfsInit (V := V)).time := by
intro w h; dsimp [dfsInit] at h; nomatch h
have hdt_init : DiscoveryTimeInvariant (dfsInit (V := V)) := by
intro w h; dsimp [dfsInit] at h; nomatch h
have h_df_init : DiscoveryFinishInvariant (dfsInit (V := V)) := by
intro w h; dsimp [dfsInit] at h; nomatch h
have hblack_final : (dfsFromList G n G.vertices.toList dfsInit).color v = Color.black := by
rw [← h_dfs]; exact G.dfs_all_black hv
rcases h_ind G.vertices.toList dfsInit h_ng_init h_bf_init hdt_init h_df_init hwhite_init hblack_final with
⟨s, f, hs, hf, hdisc, h_nonwhite_s, h_bf_s, h_gray_s, h_f_pres, h_fuel, h_later⟩
refine ⟨s, f, hs, hf, ?_, ?_, h_bf_s, h_gray_s, ?_, h_fuel, ?_⟩
· rw [h_dfs]; exact hdisc
· intro w hnw
have h := h_nonwhite_s w hnw
simpa [h_dfs] using h
· intro w hblack
have h := h_f_pres w hblack
simpa [h_dfs] using h
· intro w hw hfinal
have h := h_later w hw (by simpa [h_dfs] using hfinal)
simpa [h_dfs] using hA proper DFS descendant is still white at the discovery state of its ancestor.
theorem IsDFSAncestor.white_at_discovery_state {u v : V} {s : DFSState V}
(h : IsDFSAncestor (G.dfs) u v) (hne : u ≠ v)
(hdisc : discoveryTime (G.dfs) u = s.time)
(hnonwhite : ∀ w, s.color w ≠ Color.white →
discoveryTime (G.dfs) w < s.time) :
s.color v = Color.white := by
by_contra hv
have hv_early := hnonwhite v hv
have huv_lt := (IsDFSAncestor.eq_or_discovery_lt G h).resolve_left hne
omegaAt an ancestor's discovery state, its final parent-chain descendants form a white-reachable path.
theorem IsDFSAncestor.whiteReachable_at_discovery_state {u v : V}
{s : DFSState V} (h : IsDFSAncestor (G.dfs) u v)
(hdisc : discoveryTime (G.dfs) u = s.time)
(hnonwhite : ∀ w, s.color w ≠ Color.white →
discoveryTime (G.dfs) w < s.time) :
WhiteReachable G s u v := by
induction h with
| refl => exact Relation.ReflTransGen.refl
| @tail x y hxy hyz ih =>
apply Relation.ReflTransGen.tail ih
constructor
· exact dfs_parent_edge G hyz
· have hxy_order := IsDFSAncestor.eq_or_discovery_lt G hxy
have hxy_lt : discoveryTime (G.dfs) u < discoveryTime (G.dfs) y := by
rcases hxy_order with hux | hux
· subst x
exact dfs_parent_discovery_lt G hyz
· have hparent_lt := dfs_parent_discovery_lt G hyz
omega
have huy : u ≠ y := by
intro h
subst y
omega
exact IsDFSAncestor.white_at_discovery_state G
(Relation.ReflTransGen.tail hxy hyz) huy hdisc hnonwhiteEvery proper ancestor in the final DFS parent forest strictly contains its descendant's timestamp interval.
theorem IsDFSAncestor.intervalNestedInside_dfs {u v : V}
(hu : u ∈ G.vertices) (hne : u ≠ v)
(h : IsDFSAncestor (G.dfs) u v) :
intervalNestedInside (G.dfs) u v := by
rcases exists_discovery_state G u hu with
⟨s, fuel, huwhite, hu_black, hdisc, hnonwhite, hbf, _hgray,
hfinish_pres, hfuel, _hlater⟩
have hvwhite : s.color v = Color.white :=
IsDFSAncestor.white_at_discovery_state G h hne hdisc hnonwhite
have hwhite_path : WhiteReachable G s u v :=
IsDFSAncestor.whiteReachable_at_discovery_state G h hdisc hnonwhite
have hv_black : (dfsVisit G fuel u s).color v = Color.black := by
apply dfsVisit_white_path_black G huwhite hu hfuel
exact WhiteReachable.mem_set G hu hwhite_path
have hfuel_pos : 0 < fuel := by omega
have hfinish_local :
finishTime (dfsVisit G fuel u s) v < finishTime (dfsVisit G fuel u s) u :=
dfsVisit_finish_lt_source_finish G hfuel_pos huwhite hbf hvwhite hv_black hne.symm
have hfinish_lt : finishTime (G.dfs) v < finishTime (G.dfs) u := by
rw [hfinish_pres v hv_black, hfinish_pres u hu_black]
exact hfinish_local
have hdiscovery_lt := (IsDFSAncestor.eq_or_discovery_lt G h).resolve_left hne
exact ⟨hdiscovery_lt, hfinish_lt⟩DFS ancestor/interval characterization. For distinct graph vertices, strict timestamp-interval containment is equivalent to ancestry in the final DFS parent forest.
theorem intervalNestedInside_dfs_iff_ancestor {u v : V}
(hu : u ∈ G.vertices) (hv : v ∈ G.vertices) (hne : u ≠ v) :
intervalNestedInside (G.dfs) u v ↔ IsDFSAncestor (G.dfs) u v := by
constructor
· exact intervalNestedInside_dfs_implies_ancestor G hu hv
· exact IsDFSAncestor.intervalNestedInside_dfs G hu hneend SCCFinishOrderingend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S5_EdgeClassification
DFS theory: edge classification
This file classifies every directed graph edge relative to the final DFS parent forest. Self-loops count as back edges, following CLRS. Besides the four structural predicates, it proves uniqueness and the standard timestamp characterizations of tree/forward, back, and cross edges.
A tree edge is the edge that installed the target's final parent pointer.
A back edge points to an ancestor in the final DFS forest. Because ancestry is reflexive, a self-loop is a back edge.
def IsDFSBackEdge (u v : V) : Prop :=
G.Adj u v ∧ IsDFSAncestor (G.dfs) v uA forward edge is a non-tree edge from a vertex to a proper descendant.
def IsDFSForwardEdge (u v : V) : Prop :=
G.Adj u v ∧ u ≠ v ∧ IsDFSAncestor (G.dfs) u v ∧
(G.dfs).parent v ≠ some uA cross edge joins vertices that are unrelated by DFS ancestry.
def IsDFSCrossEdge (u v : V) : Prop :=
G.Adj u v ∧ ¬IsDFSAncestor (G.dfs) u v ∧
¬IsDFSAncestor (G.dfs) v uAn undirected tree edge has a parent pointer in either orientation.
def IsDFSUndirectedTreeEdge (u v : V) : Prop :=
G.IsDFSTreeEdge u v ∨ G.IsDFSTreeEdge v uAn undirected back edge joins an ancestor and descendant in either orientation.
def IsDFSUndirectedBackEdge (u v : V) : Prop :=
G.IsDFSBackEdge u v ∨ G.IsDFSBackEdge v uThe four CLRS edge classes for a directed DFS forest.
inductive DFSEdgeKind where
| tree
| back
| forward
| cross
deriving DecidableEq, ReprA graph edge has a specified DFS edge kind.
def HasDFSEdgeKind (kind : DFSEdgeKind) (u v : V) : Prop :=
match kind with
| .tree => G.IsDFSTreeEdge u v
| .back => G.IsDFSBackEdge u v
| .forward => G.IsDFSForwardEdge u v
| .cross => G.IsDFSCrossEdge u vEvery graph self-loop is a DFS back edge.
theorem dfs_self_loop_is_back {u : V} (hloop : G.Adj u u) :
G.IsDFSBackEdge u u :=
⟨hloop, IsDFSAncestor.refl (G.dfs) u⟩Mutual DFS ancestry in the final parent forest implies equality.
theorem IsDFSAncestor.antisymm_dfs {u v : V}
(huv : IsDFSAncestor (G.dfs) u v)
(hvu : IsDFSAncestor (G.dfs) v u) : u = v := by
rcases IsDFSAncestor.eq_or_discovery_lt G huv with huv_eq | huv_lt
· exact huv_eq
rcases IsDFSAncestor.eq_or_discovery_lt G hvu with hvu_eq | hvu_lt
· exact hvu_eq.symm
· omegaA final parent pointer never points from a vertex to itself.
theorem dfs_parent_ne {u v : V} (hparent : (G.dfs).parent v = some u) :
u ≠ v := by
intro h
subst v
have hlt := dfs_parent_discovery_lt G hparent
omegaA final DFS tree edge cannot also be a back edge.
theorem dfs_tree_edge_not_back {u v : V}
(htree : G.IsDFSTreeEdge u v) : ¬G.IsDFSBackEdge u v := by
intro hback
have huv : IsDFSAncestor (G.dfs) u v := IsDFSAncestor.single htree.2
have huv_eq := IsDFSAncestor.antisymm_dfs G huv hback.2
exact (dfs_parent_ne G htree.2) huv_eqA tree edge cannot also be a forward edge.
theorem dfs_tree_edge_not_forward {u v : V}
(htree : G.IsDFSTreeEdge u v) : ¬G.IsDFSForwardEdge u v := by
intro hforward
exact hforward.2.2.2 htree.2A tree edge cannot also be a cross edge.
theorem dfs_tree_edge_not_cross {u v : V}
(htree : G.IsDFSTreeEdge u v) : ¬G.IsDFSCrossEdge u v := by
intro hcross
exact hcross.2.1 (IsDFSAncestor.single htree.2)A forward edge cannot also be a back edge.
theorem dfs_forward_edge_not_back {u v : V}
(hforward : G.IsDFSForwardEdge u v) : ¬G.IsDFSBackEdge u v := by
intro hback
have huv_eq := IsDFSAncestor.antisymm_dfs G hforward.2.2.1 hback.2
exact hforward.2.1 huv_eqA back edge cannot also be a cross edge.
theorem dfs_back_edge_not_cross {u v : V}
(hback : G.IsDFSBackEdge u v) : ¬G.IsDFSCrossEdge u v := by
intro hcross
exact hcross.2.2 hback.2A forward edge cannot also be a cross edge.
theorem dfs_forward_edge_not_cross {u v : V}
(hforward : G.IsDFSForwardEdge u v) : ¬G.IsDFSCrossEdge u v := by
intro hcross
exact hcross.2.1 hforward.2.2.1Every graph edge belongs to at least one DFS edge class.
theorem dfs_edge_classification {u v : V} (hadj : G.Adj u v) :
G.IsDFSTreeEdge u v ∨ G.IsDFSBackEdge u v ∨
G.IsDFSForwardEdge u v ∨ G.IsDFSCrossEdge u v := by
by_cases hparent : (G.dfs).parent v = some u
· exact Or.inl ⟨hadj, hparent⟩
by_cases hback : IsDFSAncestor (G.dfs) v u
· exact Or.inr (Or.inl ⟨hadj, hback⟩)
by_cases hforward : IsDFSAncestor (G.dfs) u v
· have hne : u ≠ v := by
intro h
subst v
exact hback (IsDFSAncestor.refl (G.dfs) u)
exact Or.inr (Or.inr (Or.inl ⟨hadj, hne, hforward, hparent⟩))
· exact Or.inr (Or.inr (Or.inr ⟨hadj, hforward, hback⟩))Every graph edge has exactly one DFS edge kind.
theorem dfs_edge_classification_unique {u v : V} (hadj : G.Adj u v) :
∃! kind, G.HasDFSEdgeKind kind u v := by
rcases dfs_edge_classification G hadj with htree | hback | hforward | hcross
· refine ⟨.tree, htree, ?_⟩
intro kind hkind
cases kind with
| tree => rfl
| back => exact (dfs_tree_edge_not_back G htree hkind).elim
| forward => exact (dfs_tree_edge_not_forward G htree hkind).elim
| cross => exact (dfs_tree_edge_not_cross G htree hkind).elim
· refine ⟨.back, hback, ?_⟩
intro kind hkind
cases kind with
| tree => exact (dfs_tree_edge_not_back G hkind hback).elim
| back => rfl
| forward => exact (dfs_forward_edge_not_back G hkind hback).elim
| cross => exact (dfs_back_edge_not_cross G hback hkind).elim
· refine ⟨.forward, hforward, ?_⟩
intro kind hkind
cases kind with
| tree => exact (dfs_tree_edge_not_forward G hkind hforward).elim
| back => exact (dfs_forward_edge_not_back G hforward hkind).elim
| forward => rfl
| cross => exact (dfs_forward_edge_not_cross G hforward hkind).elim
· refine ⟨.cross, hcross, ?_⟩
intro kind hkind
cases kind with
| tree => exact (dfs_tree_edge_not_cross G hkind hcross).elim
| back => exact (dfs_back_edge_not_cross G hkind hcross).elim
| forward => exact (dfs_forward_edge_not_cross G hkind hcross).elim
| cross => rflIf an edge target is discovered after its source, the target is discovered during the source's DFS visit and its interval is strictly nested inside the source's interval.
theorem dfs_edge_discovery_lt_implies_intervalNestedInside {u v : V}
(hadj : G.Adj u v)
(hdiscovery : discoveryTime (G.dfs) u < discoveryTime (G.dfs) v) :
intervalNestedInside (G.dfs) u v := by
have hu : u ∈ G.vertices := G.adj_mem_left hadj
rcases exists_discovery_state G u hu with
⟨s, fuel, huwhite, hu_black, hdisc, hnonwhite, hbf, _hgray,
hfinish_pres, hfuel, _hlater⟩
have hvwhite : s.color v = Color.white := by
by_contra hv
have hv_early := hnonwhite v hv
omega
have hwhite_path : WhiteReachable G s u v :=
Relation.ReflTransGen.single ⟨hadj, hvwhite⟩
have hv_black : (dfsVisit G fuel u s).color v = Color.black := by
apply dfsVisit_white_path_black G huwhite hu hfuel
exact WhiteReachable.mem_set G hu hwhite_path
have hfuel_pos : 0 < fuel := by omega
have hvu : v ≠ u := by
intro h
subst v
omega
have hfinish_local :
finishTime (dfsVisit G fuel u s) v < finishTime (dfsVisit G fuel u s) u :=
dfsVisit_finish_lt_source_finish G hfuel_pos huwhite hbf hvwhite hv_black hvu
have hfinish : finishTime (G.dfs) v < finishTime (G.dfs) u := by
rw [hfinish_pres v hv_black, hfinish_pres u hu_black]
exact hfinish_local
exact ⟨hdiscovery, hfinish⟩A graph edge cannot go from a vertex that finishes before its target is discovered.
theorem dfs_edge_not_finishesBeforeDiscovered {u v : V} (hadj : G.Adj u v) :
¬finishesBeforeDiscovered (G.dfs) u v := by
intro hbefore
have hu : u ∈ G.vertices := G.adj_mem_left hadj
have hv : v ∈ G.vertices := G.adj_mem_right hadj
have hduf := G.dfs_discovery_lt_finish hu
have hdvf := G.dfs_discovery_lt_finish hv
have hdiscovery : discoveryTime (G.dfs) u < discoveryTime (G.dfs) v := by
unfold finishesBeforeDiscovered at hbefore
omega
have hnested := dfs_edge_discovery_lt_implies_intervalNestedInside G hadj hdiscovery
unfold finishesBeforeDiscovered at hbefore
unfold intervalNestedInside at hnested
omegaFor a fixed graph edge, tree or forward classification is equivalent to the target interval being nested inside the source interval.
theorem dfs_tree_or_forward_edge_iff_intervalNestedInside {u v : V}
(hadj : G.Adj u v) :
G.IsDFSTreeEdge u v ∨ G.IsDFSForwardEdge u v ↔
intervalNestedInside (G.dfs) u v := by
constructor
· rintro (htree | hforward)
· have hne : u ≠ v := dfs_parent_ne G htree.2
exact IsDFSAncestor.intervalNestedInside_dfs G (G.adj_mem_left hadj) hne
(IsDFSAncestor.single htree.2)
· exact IsDFSAncestor.intervalNestedInside_dfs G (G.adj_mem_left hadj)
hforward.2.1 hforward.2.2.1
· intro hnested
have hne : u ≠ v := by
intro h
subst v
unfold intervalNestedInside at hnested
omega
have hancestor : IsDFSAncestor (G.dfs) u v :=
intervalNestedInside_dfs_implies_ancestor G
(G.adj_mem_left hadj) (G.adj_mem_right hadj) hnested
by_cases hparent : (G.dfs).parent v = some u
· exact Or.inl ⟨hadj, hparent⟩
· exact Or.inr ⟨hadj, hne, hancestor, hparent⟩A forward edge is exactly a nested non-tree graph edge.
theorem dfs_forward_edge_iff_intervalNestedInside_and_not_parent {u v : V}
(hadj : G.Adj u v) :
G.IsDFSForwardEdge u v ↔
intervalNestedInside (G.dfs) u v ∧ (G.dfs).parent v ≠ some u := by
constructor
· intro hforward
exact ⟨IsDFSAncestor.intervalNestedInside_dfs G (G.adj_mem_left hadj)
hforward.2.1 hforward.2.2.1, hforward.2.2.2⟩
· rintro ⟨hnested, hparent⟩
have hne : u ≠ v := by
intro h
subst v
unfold intervalNestedInside at hnested
omega
exact ⟨hadj, hne,
intervalNestedInside_dfs_implies_ancestor G
(G.adj_mem_left hadj) (G.adj_mem_right hadj) hnested,
hparent⟩A graph edge is a back edge exactly when it is a self-loop or its source interval is nested inside its target interval.
theorem dfs_back_edge_iff_eq_or_intervalNestedInside {u v : V}
(hadj : G.Adj u v) :
G.IsDFSBackEdge u v ↔
u = v ∨ intervalNestedInside (G.dfs) v u := by
constructor
· intro hback
rcases IsDFSAncestor.eq_or_discovery_lt G hback.2 with hvu | hvu_lt
· exact Or.inl hvu.symm
· have hvu : v ≠ u := by
intro h
subst v
omega
exact Or.inr (IsDFSAncestor.intervalNestedInside_dfs G
(G.adj_mem_right hadj) hvu hback.2)
· rintro (huv | hnested)
· subst v
exact ⟨hadj, IsDFSAncestor.refl (G.dfs) u⟩
· exact ⟨hadj, intervalNestedInside_dfs_implies_ancestor G
(G.adj_mem_right hadj) (G.adj_mem_left hadj) hnested⟩A graph edge is a cross edge exactly when its target finishes before its source is discovered.
theorem dfs_cross_edge_iff_finishesBeforeDiscovered {u v : V}
(hadj : G.Adj u v) :
G.IsDFSCrossEdge u v ↔ finishesBeforeDiscovered (G.dfs) v u := by
have hu : u ∈ G.vertices := G.adj_mem_left hadj
have hv : v ∈ G.vertices := G.adj_mem_right hadj
constructor
· intro hcross
have hne : u ≠ v := by
intro h
subst v
exact hcross.2.1 (IsDFSAncestor.refl (G.dfs) u)
rcases dfs_parenthesis G hu hv hne with h | h | h | h
· exact (dfs_edge_not_finishesBeforeDiscovered G hadj h).elim
· exact h
· exact (hcross.2.1 (intervalNestedInside_dfs_implies_ancestor G hu hv h)).elim
· exact (hcross.2.2 (intervalNestedInside_dfs_implies_ancestor G hv hu h)).elim
· intro hbefore
have hne : u ≠ v := by
intro h
subst v
have hdf := G.dfs_discovery_lt_finish hu
unfold finishesBeforeDiscovered at hbefore
omega
refine ⟨hadj, ?_, ?_⟩
· intro hancestor
have hnested := IsDFSAncestor.intervalNestedInside_dfs G hu hne hancestor
have hvdf := G.dfs_discovery_lt_finish hv
unfold finishesBeforeDiscovered at hbefore
unfold intervalNestedInside at hnested
omega
· intro hancestor
have hnested := IsDFSAncestor.intervalNestedInside_dfs G hv hne.symm hancestor
have hudf := G.dfs_discovery_lt_finish hu
unfold finishesBeforeDiscovered at hbefore
unfold intervalNestedInside at hnested
omegaCLRS timestamp characterization of tree and forward edges.
theorem dfs_tree_or_forward_edge_iff_timestamps {u v : V}
(hadj : G.Adj u v) :
G.IsDFSTreeEdge u v ∨ G.IsDFSForwardEdge u v ↔
discoveryTime (G.dfs) u < discoveryTime (G.dfs) v ∧
finishTime (G.dfs) v < finishTime (G.dfs) u := by
simpa [intervalNestedInside] using
(dfs_tree_or_forward_edge_iff_intervalNestedInside G hadj)CLRS timestamp characterization of back edges, including self-loops.
theorem dfs_back_edge_iff_timestamps {u v : V} (hadj : G.Adj u v) :
G.IsDFSBackEdge u v ↔
discoveryTime (G.dfs) v ≤ discoveryTime (G.dfs) u ∧
finishTime (G.dfs) u ≤ finishTime (G.dfs) v := by
have hu : u ∈ G.vertices := G.adj_mem_left hadj
have hv : v ∈ G.vertices := G.adj_mem_right hadj
constructor
· intro hback
rcases (dfs_back_edge_iff_eq_or_intervalNestedInside G hadj).1 hback with huv | hnested
· subst v
exact ⟨le_rfl, le_rfl⟩
· unfold intervalNestedInside at hnested
exact ⟨Nat.le_of_lt hnested.1, Nat.le_of_lt hnested.2⟩
· intro htimes
by_cases huv : u = v
· exact (dfs_back_edge_iff_eq_or_intervalNestedInside G hadj).2 (Or.inl huv)
rcases dfs_parenthesis G hu hv huv with h | h | h | h
· have hudf := G.dfs_discovery_lt_finish hu
unfold finishesBeforeDiscovered at h
omega
· have hudf := G.dfs_discovery_lt_finish hu
unfold finishesBeforeDiscovered at h
omega
· unfold intervalNestedInside at h
omega
· exact (dfs_back_edge_iff_eq_or_intervalNestedInside G hadj).2 (Or.inr h)CLRS timestamp characterization of cross edges.
theorem dfs_cross_edge_iff_timestamps {u v : V} (hadj : G.Adj u v) :
G.IsDFSCrossEdge u v ↔
discoveryTime (G.dfs) v < finishTime (G.dfs) v ∧
finishTime (G.dfs) v < discoveryTime (G.dfs) u ∧
discoveryTime (G.dfs) u < finishTime (G.dfs) u := by
have hu : u ∈ G.vertices := G.adj_mem_left hadj
have hv : v ∈ G.vertices := G.adj_mem_right hadj
constructor
· intro hcross
have hbefore := (dfs_cross_edge_iff_finishesBeforeDiscovered G hadj).1 hcross
exact ⟨G.dfs_discovery_lt_finish hv, hbefore, G.dfs_discovery_lt_finish hu⟩
· rintro ⟨_hvdf, hbefore, _hudf⟩
exact (dfs_cross_edge_iff_finishesBeforeDiscovered G hadj).2 hbeforeAn undirected graph has no cross edges.
theorem dfs_undirected_edge_not_cross {u v : V} (hundirected : G.Undirected)
(hadj : G.Adj u v) : ¬G.IsDFSCrossEdge u v := by
intro hcross
have hadj_rev : G.Adj v u := (hundirected u v).mp hadj
have hcross_rev : G.IsDFSCrossEdge v u :=
⟨hadj_rev, hcross.2.2, hcross.2.1⟩
have huv_times := (dfs_cross_edge_iff_timestamps G hadj).1 hcross
have hvu_times := (dfs_cross_edge_iff_timestamps G hadj_rev).1 hcross_rev
omegaCLRS undirected-edge theorem. Every edge in an undirected graph is a tree edge or a back edge when the edge is viewed without orientation.
theorem dfs_undirected_edge_tree_or_back {u v : V} (hundirected : G.Undirected)
(hadj : G.Adj u v) :
G.IsDFSUndirectedTreeEdge u v ∨ G.IsDFSUndirectedBackEdge u v := by
rcases dfs_edge_classification G hadj with htree | hback | hforward | hcross
· exact Or.inl (Or.inl htree)
· exact Or.inr (Or.inl hback)
· have hadj_rev : G.Adj v u := (hundirected u v).mp hadj
exact Or.inr (Or.inr ⟨hadj_rev, hforward.2.2.1⟩)
· exact (dfs_undirected_edge_not_cross G hundirected hadj hcross).elimend Graphend Chapter22end CLRSImports
import Mathlib
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S5_EdgeClassification20.4. Topological Sort
This section gives two algorithms for topological sorting on the finite graph model from Section 20.1 and proves that each returns a valid topological order whenever the input graph is a DAG: Kahn's source-removal algorithm and the CLRS algorithm that sorts vertices by decreasing DFS finish time.
The main declarations are:
-
Graph.IsDAG: a directed graph has no directed cycle. -
Graph.indegree: the number of incoming edges of a vertex. -
Graph.IsTopologicalOrder: a list of all vertices where every edge goes from an earlier vertex to a later one. -
Graph.kahnAux: the fuelled recursive core of Kahn's algorithm. -
Graph.topologicalSort: the entry point. -
Graph.topologicalSort_isTopologicalOrder: correctness for DAGs. -
Graph.dfsTopologicalSort: vertices sorted by decreasing DFS finish time. -
Graph.dfsTopologicalSort_isTopologicalOrder: correctness of the CLRS DFS algorithm for DAGs.
The proof follows the standard invariant for Kahn's algorithm: the accumulator contains an initial segment of the final order, it is disjoint from the remaining vertices, the current indegree of each remaining vertex counts only incoming edges from remaining vertices, and every edge between two accumulator vertices is already ordered.
The key fact is that a nonempty subset of a finite DAG always contains a source vertex (a vertex with no incoming edge from the subset). This is obtained from well-foundedness of the adjacency relation on any finite subset of a DAG.
For the DFS algorithm, edge classification shows that a DAG has no back edge
and that every edge u → v satisfies f[v] < f[u]. Sorting by
decreasing finish time therefore places every edge source before its target.
Cost boundary
The finish order is obtained with List.mergeSort, not accumulated online
at DFS exit. The proved BFS/DFS controller count does not include this sorting
phase, its comparison evaluations, or the representation cost of obtaining
finish timestamps. No end-to-end O(V + E) execution bound for this
finish-sorted algorithm follows from the standalone DFS counter.
The results here establish the returned order/partition semantics. A counted sort or an online reverse-finish list, together with its execution refinement, is required for a stronger total-runtime claim.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V]A directed acyclic graph: no vertex can reach itself by a non-trivial path.
Adjacency is decidable because each vertex has a finite adjacency set.
instance adjDecidableRel (G : Graph V) : DecidableRel G.Adj :=
fun u v => decidable_of_iff (v ∈ G.adj u) (by unfold Adj; exact Iff.rfl)
Number of incoming edges of v from vertices of the graph.
A topological order of G is a permutation of the vertices in which
every directed edge goes forward.
def IsTopologicalOrder (G : Graph V) (order : List V) : Prop :=
order.Nodup ∧
(∀ v, v ∈ order ↔ v ∈ G.vertices) ∧
(∀ u ∈ G.vertices, ∀ v ∈ G.adj u, List.idxOf u order < List.idxOf v order)section Kahnopen ClassicalOne step of Kahn's algorithm. The function is fuelled by a natural number.
If a vertex of current indegree zero exists in remaining, one such vertex
is chosen classically, removed from remaining, the
indegrees of its remaining out-neighbors are decremented, and it is appended to
the accumulator. Otherwise the accumulator is returned.
noncomputable def kahnAux (G : Graph V) (fuel : Nat) (remaining : Finset V) (indeg : V → Nat) (acc : List V) : List V :=
match fuel with
| 0 => acc
| fuel + 1 =>
if _h : remaining.Nonempty then
if hex : ∃ v, v ∈ remaining ∧ indeg v = 0 then
let v := Classical.choose hex
let remaining' := remaining.erase v
let indeg' (w : V) : Nat := if w ∈ remaining' ∧ G.Adj v w then indeg w - 1 else indeg w
kahnAux G fuel remaining' indeg' (acc ++ [v])
else
acc
else
accEntry point for Kahn's algorithm. The fuel is one more than the number of vertices, which is enough to remove every vertex.
noncomputable def topologicalSort (G : Graph V) : List V :=
kahnAux G (G.vertices.card + 1) G.vertices G.indegree []
Invariant for Graph.kahnAux.
-
nodup: the accumulator has no duplicate vertices. -
remaining_subset: all remaining vertices are graph vertices. -
acc_mem: every accumulator vertex is a graph vertex. -
cover: every graph vertex is either in the accumulator or remaining. -
disjoint: the accumulator and the remaining set are disjoint. -
preds_placed: every predecessor of an accumulator vertex is already in the accumulator. -
indeg_eq: for each remaining vertex, its current indegree equals the number of incoming edges from remaining vertices. -
edge_ordered: every edge between two accumulator vertices is ordered correctly in the accumulator.
structure KahnInvariant (G : Graph V) (remaining : Finset V) (indeg : V → Nat) (acc : List V) : Prop where
nodup : acc.Nodup
remaining_subset : remaining ⊆ G.vertices
acc_mem : ∀ v, v ∈ acc → v ∈ G.vertices
cover : ∀ v, v ∈ G.vertices → v ∈ acc ∨ v ∈ remaining
disjoint : ∀ v, v ∈ acc → ¬v ∈ remaining
preds_placed : ∀ y ∈ acc, ∀ u ∈ G.vertices, G.Adj u y → u ∈ acc
indeg_eq : ∀ v ∈ remaining, indeg v = (remaining.filter (fun u => G.Adj u v)).card
edge_ordered : ∀ u ∈ acc, ∀ v ∈ G.adj u, v ∈ acc → List.idxOf u acc < List.idxOf v acc
In a finite DAG, the adjacency relation is well-founded on any finset
S. The proof first shows well-foundedness of the transitive closure
Relation.TransGen G.Adj using the no-descending-sequence characterisation;
an infinite descending sequence inside S must repeat (pigeonhole), and a
repeat gives a non-trivial cycle. Well-foundedness of G.Adj follows
because G.Adj is a subrelation of its transitive closure.
-- The adjacency relation is well-founded on any finite subset of a DAG.
lemma finite_DAG_wellFoundedOn (G : Graph V) (S : Finset V) (hDAG : G.IsDAG) : (S : Set V).WellFoundedOn G.Adj := by
have hwf : (S : Set V).WellFoundedOn (Relation.TransGen G.Adj) := by
letI : IsStrictOrder V (Relation.TransGen G.Adj) := {
toIrrefl := ⟨fun a h => hDAG a h⟩
toIsTrans := ⟨fun _ _ _ h1 h2 => Relation.TransGen.trans h1 h2⟩
}
rw [Set.wellFoundedOn_iff_no_descending_seq]
intro f hf
-- The descending sequence takes values in the finite set S, so it repeats.
have hrep : ∃ (i j : ℕ), i < j ∧ f i = f j := by
by_contra h
push Not at h
have hinj : Function.Injective f := by
intro i j heq
by_contra hne
cases lt_or_gt_of_ne hne with
| inl hij => exact h i j hij heq
| inr hji => exact h j i hji heq.symm
have hcard : (Finset.image f (Finset.range (S.card + 1))).card = S.card + 1 := by
rw [Finset.card_image_of_injective _ hinj, Finset.card_range]
have hsub : Finset.image f (Finset.range (S.card + 1)) ⊆ S := by
intro x hx
simp at hx
rcases hx with ⟨n, -, rfl⟩
exact hf n
have hcard_le : (Finset.image f (Finset.range (S.card + 1))).card ≤ S.card :=
Finset.card_le_card hsub
linarith
rcases hrep with ⟨i, j, hij, heq⟩
have htrans : Relation.TransGen G.Adj (f j) (f i) :=
f.map_rel_iff'.mpr (show j > i by exact hij)
rw [← heq] at htrans
exact hDAG (f i) htrans
exact hwf.mono' (fun _ _ _ _ h => Relation.TransGen.single h)In a DAG with the Kahn invariant, any nonempty remaining set contains a vertex of current indegree zero.
lemma exists_zero_indegree (G : Graph V) {remaining : Finset V} {indeg : V → Nat} {acc : List V}
(hinv : G.KahnInvariant remaining indeg acc) (hDAG : G.IsDAG)
(hnonempty : remaining.Nonempty) :
∃ v, v ∈ remaining ∧ indeg v = 0 := by
have hwf : WellFounded (fun (a b : V) => G.Adj a b ∧ a ∈ remaining ∧ b ∈ remaining) := by
convert G.finite_DAG_wellFoundedOn remaining hDAG
simp [Set.wellFoundedOn_iff]
have hne : (remaining : Set V).Nonempty := by simpa using hnonempty
let v := WellFounded.min hwf (remaining : Set V) hne
have hv1 : v ∈ remaining := WellFounded.min_mem hwf (remaining : Set V) hne
have hv2 : ∀ u ∈ remaining, ¬G.Adj u v := by
intro u hu huv
have h := WellFounded.not_lt_min hwf (remaining : Set V) (x := u) hu
exact h ⟨huv, hu, hv1⟩
use v, hv1
rw [hinv.indeg_eq v hv1]
apply Finset.card_eq_zero.mpr
ext u
simp
intro hu hadj
exact hv2 u hu hadjThe Kahn invariant holds for the initial call.
lemma kahnInvariant_init (G : Graph V) : G.KahnInvariant G.vertices G.indegree [] := by
constructor
· simp
· simp
· simp
· intro v hv
simp [hv]
· simp
· simp
· intro v hv
simp [indegree, Adj]
· intro y hy
simp at hyThe Kahn invariant is preserved by one recursive step.
lemma kahnInvariant_step (G : Graph V) {remaining : Finset V} {indeg : V → Nat} {acc : List V}
(hinv : G.KahnInvariant remaining indeg acc) (hDAG : G.IsDAG)
(hnonempty : remaining.Nonempty) :
let hex := G.exists_zero_indegree hinv hDAG hnonempty
let v := Classical.choose hex
let remaining' := remaining.erase v
let indeg' (w : V) : Nat := if w ∈ remaining' ∧ G.Adj v w then indeg w - 1 else indeg w
G.KahnInvariant remaining' indeg' (acc ++ [v]) := by
intro hex v remaining' indeg'
have hv : v ∈ remaining ∧ indeg v = 0 := Classical.choose_spec hex
have hv_not_acc : v ∉ acc := by
intro h
exact hinv.disjoint v h hv.1
constructor
· -- nodup
apply List.Nodup.append
· exact hinv.nodup
· simp
· intro a ha hb
have hav : a = v := by
rw [List.mem_singleton] at hb
exact hb
rw [hav] at ha
exact hv_not_acc ha
· -- remaining_subset
intro x hx
exact hinv.remaining_subset (Finset.mem_of_mem_erase hx)
· -- acc_mem
intro x hx
simp at hx
rcases hx with (hx | hx)
· exact hinv.acc_mem x hx
· rw [hx]
exact hinv.remaining_subset hv.1
· -- cover
intro x hx
by_cases hxv : x = v
· left
simp [hxv]
· rcases hinv.cover x hx with (hacc | hrem)
· left
simp [hacc]
· right
simp [remaining', hrem, hxv]
· -- disjoint
intro x hx
simp at hx
rcases hx with (hx | hx)
· intro h'
have : x ∈ remaining := Finset.mem_of_mem_erase h'
exact hinv.disjoint x hx this
· rw [hx]
intro h
rw [Finset.mem_erase] at h
exfalso
exact h.1 rfl
· -- preds_placed
intro y hy u hu hadj
simp at hy
rcases hy with (hy | hy)
· have h := hinv.preds_placed y hy u hu hadj
exact List.mem_append_left _ h
· rw [hy] at hadj
have hu_not_rem : u ∉ remaining := by
by_contra hu_rem
have : u ∈ remaining.filter (fun x => G.Adj x v) := by
simp [hu_rem, hadj]
have hcard : (remaining.filter (fun x => G.Adj x v)).card = 0 := by
rw [← hinv.indeg_eq v hv.1]
exact hv.2
rw [Finset.card_eq_zero] at hcard
simp [hcard] at this
have hu_acc : u ∈ acc := by
rcases hinv.cover u hu with (hacc | hrem)
· exact hacc
· contradiction
exact List.mem_append_left _ hu_acc
· -- indeg_eq
intro w hw
have hw_rem : w ∈ remaining := Finset.mem_of_mem_erase hw
by_cases hvw : G.Adj v w
· -- v → w contributes one to the old filter but not the new one.
rw [show indeg' w = indeg w - 1 by simp [indeg', hw, hvw]]
rw [hinv.indeg_eq w hw_rem]
have hfilter : remaining.filter (fun u => G.Adj u w) =
(remaining'.filter (fun u => G.Adj u w)) ∪ {v} := by
ext u
simp [remaining', Finset.mem_erase]
by_cases huv : u = v
· simp [huv, hv.1, hvw]
· simp [huv]
have hdisj : Disjoint (remaining'.filter (fun u => G.Adj u w)) {v} := by
rw [Finset.disjoint_singleton_right]
simp [remaining']
rw [hfilter, Finset.card_union_of_disjoint hdisj, Finset.card_singleton]
omega
· -- v does not point to w, so the filter is unchanged.
rw [show indeg' w = indeg w by simp [indeg', hw, hvw]]
rw [hinv.indeg_eq w hw_rem]
have hfilter : remaining.filter (fun u => G.Adj u w) =
remaining'.filter (fun u => G.Adj u w) := by
ext u
simp [remaining', Finset.mem_erase]
by_cases huv : u = v
· simp [huv, hvw]
· simp [huv]
rw [hfilter]
· -- edge_ordered
intro u hu y hy hyacc
simp at hu hyacc
rcases hu with (hu | rfl)
· rcases hyacc with (hyacc | rfl)
· -- u and y are both in the old accumulator.
have h1 : List.idxOf u (acc ++ [v]) = List.idxOf u acc := by
apply List.idxOf_append_of_mem
exact hu
have h2 : List.idxOf y (acc ++ [v]) = List.idxOf y acc := by
apply List.idxOf_append_of_mem
exact hyacc
rw [h1, h2]
exact hinv.edge_ordered u hu y hy hyacc
· -- y is the newly added vertex v.
have h1 : List.idxOf u (acc ++ [v]) = List.idxOf u acc := by
apply List.idxOf_append_of_mem
exact hu
have h2 : List.idxOf v (acc ++ [v]) = acc.length := by
have hv' : v ∉ acc := hv_not_acc
rw [List.idxOf_append_of_notMem hv']
rw [List.idxOf_cons_eq [] (rfl)]
simp
rw [h1, h2]
have h3 : List.idxOf u acc < acc.length := by
apply List.idxOf_lt_length_of_mem
exact hu
linarith
· -- u is the newly added vertex v; this is impossible.
rcases hyacc with (hyacc | rfl)
· -- y is in the accumulator, contradicting preds_placed.
exfalso
have hadj : G.Adj v y := hy
have h1 : v ∈ G.vertices := hinv.remaining_subset hv.1
have h2 : v ∈ acc := hinv.preds_placed y hyacc v h1 hadj
exact hinv.disjoint v h2 hv.1
· -- y = v gives a self-loop, contradicting the DAG assumption.
exfalso
have hadj : G.Adj v v := hy
exact hDAG v (Relation.TransGen.single hadj)
Soundness of Graph.kahnAux: if the invariant holds, the graph is a
DAG, and the fuel is at least the number of remaining vertices, then the result
is a topological order.
theorem kahnAux_sound (G : Graph V) {fuel : Nat} {remaining : Finset V} {indeg : V → Nat} {acc : List V}
(hinv : G.KahnInvariant remaining indeg acc) (hDAG : G.IsDAG)
(hfuel : remaining.card ≤ fuel) :
G.IsTopologicalOrder (G.kahnAux fuel remaining indeg acc) := by
induction fuel generalizing remaining indeg acc with
| zero =>
have rem_empty : remaining = ∅ := by
apply Finset.card_eq_zero.mp
linarith [hfuel]
simp [kahnAux]
constructor
· exact hinv.nodup
constructor
· intro v
constructor
· intro hv
exact hinv.acc_mem v hv
· intro hv
have : v ∈ acc ∨ v ∈ remaining := hinv.cover v hv
simp [rem_empty] at this
exact this
· intro u hu y hy
have hu_acc : u ∈ acc := by
have : u ∈ acc ∨ u ∈ remaining := hinv.cover u hu
simp [rem_empty] at this
exact this
have hy_acc : y ∈ acc := by
have hy_vert : y ∈ G.vertices := G.adj_sub u hu hy
have : y ∈ acc ∨ y ∈ remaining := hinv.cover y hy_vert
simp [rem_empty] at this
exact this
exact hinv.edge_ordered u hu_acc y hy hy_acc
| succ n ih =>
by_cases hrem : remaining.Nonempty
· -- There is a zero-indegree vertex; take one step.
have hex := G.exists_zero_indegree hinv hDAG hrem
let v := Classical.choose hex
have hv : v ∈ remaining ∧ indeg v = 0 := Classical.choose_spec hex
let remaining' := remaining.erase v
let indeg' (w : V) : Nat := if w ∈ remaining' ∧ G.Adj v w then indeg w - 1 else indeg w
have hinv' : G.KahnInvariant remaining' indeg' (acc ++ [v]) :=
G.kahnInvariant_step hinv hDAG hrem
have hfuel' : remaining'.card ≤ n := by
have hcard : remaining.card = remaining'.card + 1 := by
rw [Finset.card_erase_add_one hv.1]
linarith [hfuel, hcard]
have heq : G.kahnAux (n + 1) remaining indeg acc =
G.kahnAux n remaining' indeg' (acc ++ [v]) := by
simp [kahnAux, hrem, dif_pos hex, v, remaining', indeg']
rw [heq]
exact ih hinv' hfuel'
· -- remaining is empty; the accumulator already contains every vertex.
have rem_empty : remaining = ∅ := by
rw [Finset.nonempty_iff_ne_empty] at hrem
simpa using hrem
simp [kahnAux, rem_empty]
constructor
· exact hinv.nodup
constructor
· intro v
constructor
· intro hv
exact hinv.acc_mem v hv
· intro hv
have : v ∈ acc ∨ v ∈ remaining := hinv.cover v hv
simp [rem_empty] at this
exact this
· intro u hu y hy
have hu_acc : u ∈ acc := by
have : u ∈ acc ∨ u ∈ remaining := hinv.cover u hu
simp [rem_empty] at this
exact this
have hy_acc : y ∈ acc := by
have hy_vert : y ∈ G.vertices := G.adj_sub u hu hy
have : y ∈ acc ∨ y ∈ remaining := hinv.cover y hy_vert
simp [rem_empty] at this
exact this
exact hinv.edge_ordered u hu_acc y hy hy_accKahn's algorithm returns a topological order for every DAG.
theorem topologicalSort_isTopologicalOrder (G : Graph V) (hDAG : G.IsDAG) :
G.IsTopologicalOrder G.topologicalSort := by
have hinv := G.kahnInvariant_init
have hfuel : G.vertices.card ≤ G.vertices.card + 1 := by linarith
exact G.kahnAux_sound hinv hDAG hfuelend Kahnsection DFSFinishTimeCLRS DFS finish-time algorithm
A DAG has no back edge relative to its final DFS forest.
theorem isDAG_no_dfs_back_edge (G : Graph V) (hDAG : G.IsDAG) {u v : V} :
¬G.IsDFSBackEdge u v := by
intro hback
exact hDAG u (Relation.TransGen.head' hback.1
(IsDFSAncestor_reachable G hback.2))On every edge of a DAG, DFS finish time strictly decreases from source to target. This is the key theorem behind the CLRS topological-sort algorithm.
theorem dfs_finish_time_decreases_on_dag_edge (G : Graph V) (hDAG : G.IsDAG)
{u v : V} (hadj : G.Adj u v) :
finishTime (G.dfs) v < finishTime (G.dfs) u := by
rcases dfs_edge_classification G hadj with htree | hback | hforward | hcross
· exact ((dfs_tree_or_forward_edge_iff_timestamps G hadj).1
(Or.inl htree)).2
· exact (isDAG_no_dfs_back_edge G hDAG hback).elim
· exact ((dfs_tree_or_forward_edge_iff_timestamps G hadj).1
(Or.inr hforward)).2
· have htimes := (dfs_cross_edge_iff_timestamps G hadj).1 hcross
omegaComparison for sorting vertices by decreasing final DFS finish time.
@[irreducible]
noncomputable def dfsFinishLe (G : Graph V) (u v : V) : Bool :=
decide (finishTime (G.dfs) v ≤ finishTime (G.dfs) u)theorem dfsFinishLe_iff_le {G : Graph V} {u v : V} :
dfsFinishLe G u v ↔ finishTime (G.dfs) v ≤ finishTime (G.dfs) u := by
simp [dfsFinishLe]Finish-time topological order obtained by merge sorting. This semantic entry point has no attached end-to-end execution counter; DFS's controller bound excludes the extra sort and timestamp-comparison work.
noncomputable def dfsTopologicalSort (G : Graph V) : List V :=
G.vertices.toList.mergeSort (dfsFinishLe G)DFS finish-time sorting only reorders the graph's vertices.
theorem dfsTopologicalSort_perm (G : Graph V) :
G.dfsTopologicalSort.Perm G.vertices.toList := by
exact List.mergeSort_perm _ _DFS finish-time sorting contains each graph vertex exactly once.
theorem dfsTopologicalSort_nodup (G : Graph V) :
G.dfsTopologicalSort.Nodup := by
exact (dfsTopologicalSort_perm G).nodup_iff.mpr G.vertices.nodup_toListMembership in the DFS finish-time order is exactly graph membership.
theorem mem_dfsTopologicalSort_iff (G : Graph V) (v : V) :
v ∈ G.dfsTopologicalSort ↔ v ∈ G.vertices := by
rw [(dfsTopologicalSort_perm G).mem_iff]
exact Finset.mem_toListThe DFS finish-time order is non-increasing in finish time.
theorem dfsTopologicalSort_pairwise_finish_le (G : Graph V) :
G.dfsTopologicalSort.Pairwise
(fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a) := by
have hpair : G.dfsTopologicalSort.Pairwise
(fun a b => dfsFinishLe G a b = true) := by
unfold dfsTopologicalSort
apply List.pairwise_mergeSort
· intro a b c hab hbc
simp [dfsFinishLe] at hab hbc ⊢
omega
· intro a b
simp [dfsFinishLe]
exact Nat.le_total (finishTime (G.dfs) b) (finishTime (G.dfs) a)
exact hpair.imp (by
intro a b hab
simpa [dfsFinishLe] using hab)In a list sorted by non-increasing values, a strict value decrease forces the larger-valued element to occur first.
private theorem idxOf_lt_idxOf_of_pairwise_ge
{l : List V} {f : V → Nat} {u v : V}
(hpair : l.Pairwise (fun a b => f b ≤ f a))
(hu : u ∈ l) (hv : v ∈ l) (hvalue : f v < f u) :
List.idxOf u l < List.idxOf v l := by
have huv : u ≠ v := by
intro h
subst v
omega
have hidx : List.idxOf u l ≠ List.idxOf v l := by
intro h
exact huv ((List.idxOf_inj hu).mp h)
rcases Nat.lt_or_gt_of_ne hidx with hlt | hgt
· exact hlt
· have hrel := hpair.rel_get_of_lt
(a := ⟨List.idxOf v l, List.idxOf_lt_length_iff.mpr hv⟩)
(b := ⟨List.idxOf u l, List.idxOf_lt_length_iff.mpr hu⟩) hgt
have : f u ≤ f v := by
simpa only [List.idxOf_get] using hrel
omegaSorting a DAG's vertices by decreasing DFS finish time returns a valid topological order, as in CLRS.
theorem dfsTopologicalSort_isTopologicalOrder (G : Graph V) (hDAG : G.IsDAG) :
G.IsTopologicalOrder G.dfsTopologicalSort := by
refine ⟨dfsTopologicalSort_nodup G, mem_dfsTopologicalSort_iff G, ?_⟩
intro u hu v hv
apply idxOf_lt_idxOf_of_pairwise_ge
(dfsTopologicalSort_pairwise_finish_le G)
· exact (mem_dfsTopologicalSort_iff G u).2 hu
· exact (mem_dfsTopologicalSort_iff G v).2 (G.adj_sub u hu hv)
· exact dfs_finish_time_decreases_on_dag_edge G hDAG hvend DFSFinishTimeend Graphend Chapter22end CLRSImports
import Mathlib
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S4_SCC20.5. Strongly Connected Components
This section gives Kosaraju's two-pass depth-first-search algorithm for computing the strongly connected components of a directed graph on the finite graph model from Section 20.1.
The algorithm:
-
Run DFS on
Gand record finish times. -
Sort vertices by decreasing finish time.
-
Run DFS on the transpose graph
Gᵀin that order, collecting each DFS tree as one component.
The main declarations are:
-
CLRS.Chapter22.Graph.transpose, -
CLRS.Chapter22.Graph.StronglyConnected, -
CLRS.Chapter22.Graph.IsSCC, -
CLRS.Chapter22.Graph.IsSCCPartition, -
CLRS.Chapter22.Graph.dfsFromListCollect, -
CLRS.Chapter22.Graph.kosarajuComponents, -
CLRS.Chapter22.Graph.kosarajuComponents_isSCCPartition.
This file covers the algorithm, structural properties, and the core
finish-time-ordering lemmas (scc_finish_time_order
and scc_finish_order), as well as the final SCC correctness
theorems.
Implementation details
The supporting merge-sort congruence proof remains available outside the main sidebar:
Current status:
-
The finish-time-ordering proof (
Graph.scc_finish_time_order) is complete. -
The second-pass invariant proof culminates in
Graph.kosarajuComponent_scc_core, so the finalGraph.kosarajuComponents_isSCCPartitiontheorem is fully proved.
Cost boundary
The finish order is obtained with List.mergeSort, not accumulated online
at DFS exit. The proved BFS/DFS controller count does not include this sorting
phase, its comparison evaluations, or the representation cost of obtaining
finish timestamps. No end-to-end O(V + E) execution bound for this
finish-sorted algorithm follows from the standalone DFS counter.
The results here establish the returned order/partition semantics. A counted sort or an online reverse-finish list, together with its execution refinement, is required for a stronger total-runtime claim.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type} [DecidableEq V]variable (G : Graph V)Transpose graph and strong connectivity
The transpose (reverse) of a finite directed graph.
def transpose (G : Graph V) : Graph V where
vertices := G.vertices
adj := fun v => G.vertices.filter (fun u => v ∈ G.adj u)
adj_sub := by
intro v hv
exact Finset.filter_subset _ G.vertices
adj_outside := by
intro v hv
ext u
simp
intro hu hadj
exact hv (G.adj_mem_right hadj)@[simp]
theorem transpose_vertices (G : Graph V) : G.transpose.vertices = G.vertices :=
rfl@[simp]
theorem transpose_Adj (G : Graph V) (u v : V) :
G.transpose.Adj u v ↔ G.Adj v u := by
simp [Adj, transpose]
intro h
exact G.adj_mem_left hTwo vertices are strongly connected when they are reachable from each other.
theorem StronglyConnected.reachable {u v : V} (h : G.StronglyConnected u v) :
G.Reachable u v :=
h.1theorem StronglyConnected.reverse_reachable {u v : V} (h : G.StronglyConnected u v) :
G.Reachable v u :=
h.2theorem stronglyConnected_refl (u : V) : G.StronglyConnected u u :=
⟨G.reachable_refl u, G.reachable_refl u⟩theorem stronglyConnected_symm {u v : V}
(h : G.StronglyConnected u v) : G.StronglyConnected v u :=
⟨StronglyConnected.reverse_reachable G h, StronglyConnected.reachable G h⟩theorem stronglyConnected_trans {u v w : V}
(huv : G.StronglyConnected u v) (hvw : G.StronglyConnected v w) :
G.StronglyConnected u w :=
⟨G.reachable_trans (StronglyConnected.reachable G huv) (StronglyConnected.reachable G hvw),
G.reachable_trans (StronglyConnected.reverse_reachable G hvw)
(StronglyConnected.reverse_reachable G huv)⟩A strongly connected component is a nonempty maximal subset of vertices in which every pair of vertices is strongly connected.
def IsSCC (G : Graph V) (C : Set V) : Prop :=
C.Nonempty ∧ C ⊆ G.vertices ∧
(∀ u ∈ C, ∀ v ∈ C, G.StronglyConnected u v) ∧
(∀ w ∈ G.vertices, (∀ u ∈ C, G.StronglyConnected u w) → w ∈ C)theorem IsSCC.nonempty {C : Set V} (hC : G.IsSCC C) : C.Nonempty :=
hC.1theorem IsSCC.subset_vertices {C : Set V} (hC : G.IsSCC C) : C ⊆ G.vertices :=
hC.2.1theorem IsSCC.stronglyConnected {C : Set V} (hC : G.IsSCC C) :
∀ u ∈ C, ∀ v ∈ C, G.StronglyConnected u v :=
hC.2.2.1theorem IsSCC.maximal {C : Set V} (hC : G.IsSCC C) :
∀ w ∈ G.vertices, (∀ u ∈ C, G.StronglyConnected u w) → w ∈ C :=
hC.2.2.2
theorem IsSCC_eq_of_nonempty_inter {C D : Set V}
(hC : G.IsSCC C) (hD : G.IsSCC D) (h : ∃ x, x ∈ C ∧ x ∈ D) : C = D := by
rcases h with ⟨x, hxC, hxD⟩
apply Set.Subset.antisymm
· intro c hc
have hsc : ∀ d ∈ D, G.StronglyConnected c d := by
intro d hd
have hcx := IsSCC.stronglyConnected G hC c hc x hxC
have hxd := IsSCC.stronglyConnected G hD x hxD d hd
exact ⟨G.reachable_trans (StronglyConnected.reachable G hcx)
(StronglyConnected.reachable G hxd),
G.reachable_trans (StronglyConnected.reverse_reachable G hxd)
(StronglyConnected.reverse_reachable G hcx)⟩
have hsc' : ∀ u ∈ D, G.StronglyConnected u c := by
intro u hu
exact G.stronglyConnected_symm (hsc u hu)
exact IsSCC.maximal G hD c (IsSCC.subset_vertices G hC hc) hsc'
· intro d hd
have hsc : ∀ c ∈ C, G.StronglyConnected d c := by
intro c hc
have hdx := IsSCC.stronglyConnected G hD d hd x hxD
have hxc := IsSCC.stronglyConnected G hC x hxC c hc
exact ⟨G.reachable_trans (StronglyConnected.reachable G hdx)
(StronglyConnected.reachable G hxc),
G.reachable_trans (StronglyConnected.reverse_reachable G hxc)
(StronglyConnected.reverse_reachable G hdx)⟩
have hsc' : ∀ u ∈ C, G.StronglyConnected u d := by
intro u hu
exact G.stronglyConnected_symm (hsc u hu)
exact IsSCC.maximal G hC d (IsSCC.subset_vertices G hD hd) hsc'
theorem IsSCC_eq_or_disjoint {C D : Set V}
(hC : G.IsSCC C) (hD : G.IsSCC D) : C = D ∨ Disjoint C D := by
by_cases h : ∃ x, x ∈ C ∧ x ∈ D
· left
exact G.IsSCC_eq_of_nonempty_inter hC hD h
· right
rw [Set.disjoint_iff]
intro x hx
exact h ⟨x, hx.1, hx.2⟩
A list of finsets is an SCC partition of G if each element is an SCC of
G and the elements partition the vertex set.
def IsSCCPartition (G : Graph V) (ccs : List (Finset V)) : Prop :=
(∀ C ∈ ccs, (C : Set V) ⊆ G.vertices) ∧
(∀ C ∈ ccs, C.Nonempty) ∧
(∀ C ∈ ccs, ∀ u ∈ C, ∀ v ∈ C, G.StronglyConnected u v) ∧
(∀ C ∈ ccs, ∀ w ∈ G.vertices \ C, ¬ (∀ u ∈ C, G.StronglyConnected u w)) ∧
(∀ v ∈ G.vertices, ∃! C ∈ ccs, v ∈ C)Collecting DFS and Kosaraju's algorithm
open ClassicalRun DFS from a list of starting vertices and collect, for each white start vertex, the finset of vertices that turn black during that visit. Components are accumulated in reverse order.
noncomputable def dfsFromListCollect (G : Graph V) (fuel : Nat) :
List V → DFSState V → List (Finset V) → List (Finset V) × DFSState V
| [], s, acc => (acc, s)
| u :: us, s, acc =>
if s.color u = Color.white then
let s' := dfsVisit G fuel u s
let comp := G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black)
dfsFromListCollect G fuel us s' (comp :: acc)
else
dfsFromListCollect G fuel us s accFinish-time comparison used to sort vertices in decreasing order.
@[irreducible]
def finishLe (s : DFSState V) (u v : V) : Bool :=
decide (finishTime s v ≤ finishTime s u)theorem finishLe_iff_le {s : DFSState V} {u v : V} :
finishLe s u v ↔ finishTime s v ≤ finishTime s u := by
simp [finishLe]
Kosaraju's algorithm: DFS on G for finish times, then DFS on
Gᵀ in decreasing finish-time order, collecting each DFS tree. The
intermediate merge-sort work is not included in the standalone DFS counter.
noncomputable def kosarajuComponents (G : Graph V) : List (Finset V) :=
let s1 := G.dfs
let order := G.vertices.toList.mergeSort (finishLe s1)
(dfsFromListCollect G.transpose (G.vertices.card + 1) order dfsInit []).1Basic structural facts about collecting DFS
Invariant maintained by Graph.dfsFromListCollect:
-
accumulated components are pairwise disjoint subsets of vertices;
-
every component is nonempty;
-
every vertex placed in a component is black in the current state;
-
every black vertex of
Galready belongs to some accumulated component; -
the current state has no gray vertices.
structure CollectInvariant (G : Graph V) (s : DFSState V) (acc : List (Finset V)) : Prop where
pairwise : acc.Pairwise (fun C D => Disjoint C D)
subset : ∀ C ∈ acc, (C : Set V) ⊆ G.vertices
nonempty : ∀ C ∈ acc, C.Nonempty
black : ∀ C ∈ acc, ∀ v ∈ C, s.color v = Color.black
cover : ∀ v ∈ G.vertices, s.color v = Color.black → ∃ C ∈ acc, v ∈ C
no_gray : ∀ v, s.color v = Color.white ∨ s.color v = Color.blackThe collecting invariant holds for the empty accumulator and the initial DFS state.
theorem collectInvariant_init (G : Graph V) :
CollectInvariant G dfsInit ([] : List (Finset V)) := by
constructor
· simp
· simp
· simp
· simp
· simp [dfsInit]
· simp [dfsInit]
One step of Graph.dfsFromListCollect preserves the collecting
invariant.
theorem collectInvariant_step (G : Graph V) {fuel : Nat}
(hfuel : 0 < fuel) {u : V} (hu : u ∈ G.vertices) (_us : List V)
{s : DFSState V} {acc : List (Finset V)} (hwhite : s.color u = Color.white)
(hinv : CollectInvariant G s acc) :
let s' := dfsVisit G fuel u s
let comp := G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black)
CollectInvariant G s' (comp :: acc) := by
intro s' comp
have hng : ∀ v, s'.color v = Color.white ∨ s'.color v = Color.black := by
apply dfsVisit_output_no_gray
intro v
cases hinv.no_gray v <;> simp [*]
constructor
· -- pairwise disjoint: the new component is white in `s`, old components are black in `s`.
apply List.Pairwise.cons
· intro C hC
apply Finset.disjoint_left.mpr
intro v hvComp hvC
have hvComp' : v ∈ comp := by simpa using hvComp
rw [show comp = G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black) by rfl] at hvComp'
simp [Finset.mem_filter] at hvComp'
rcases hvComp' with ⟨_, hwhite, _⟩
have hblack : s.color v = Color.black := hinv.black C hC v hvC
simp [hwhite] at hblack
· exact hinv.pairwise
· -- subset of vertices
intro C hC
by_cases hC' : C = comp
· subst hC'
intro v hv
have hv' : v ∈ comp := by simpa using hv
rw [show comp = G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black) by rfl] at hv'
simp [Finset.mem_filter] at hv'
exact hv'.1
· have hCacc : C ∈ acc := by
simpa [hC'] using hC
exact hinv.subset C hCacc
· -- nonempty
intro C hC
by_cases hC' : C = comp
· subst hC'
use u
have : u ∈ comp := by
rw [show comp = G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black) by rfl]
simp [Finset.mem_filter]
exact ⟨hu, hwhite, dfsVisit_blackens_u_pos G hfuel hwhite⟩
simpa using this
· have hCacc : C ∈ acc := by
simpa [hC'] using hC
exact hinv.nonempty C hCacc
· -- black in s'
intro C hC v hv
by_cases hC' : C = comp
· subst hC'
have hv' : v ∈ comp := by simpa using hv
rw [show comp = G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black) by rfl] at hv'
simp [Finset.mem_filter] at hv'
exact hv'.2.2
· have hCacc : C ∈ acc := by
simpa [hC'] using hC
apply dfsVisit_preserves_black
exact hinv.black C hCacc v hv
· -- cover of black vertices in s'
intro v hv hblack
by_cases hwhite : s.color v = Color.white
· use comp
constructor
· simp
· rw [Finset.mem_filter]
exact ⟨hv, hwhite, hblack⟩
· have hblack_old : s.color v = Color.black := by
cases hinv.no_gray v with
| inl hw => contradiction
| inr hb => exact hb
rcases hinv.cover v hv hblack_old with ⟨C, hC, hvC⟩
exact ⟨C, List.mem_cons_of_mem comp hC, hvC⟩
· exact hngThe collecting invariant is preserved through an entire vertex list.
theorem dfsFromListCollect_invariant (G : Graph V) {fuel : Nat}
(hfuel : 0 < fuel) {vs : List V} (hvs : ∀ v ∈ vs, v ∈ G.vertices)
(s0 : DFSState V) (acc : List (Finset V))
(hinv : CollectInvariant G s0 acc) :
CollectInvariant G (dfsFromListCollect G fuel vs s0 acc).2
(dfsFromListCollect G fuel vs s0 acc).1 := by
induction vs generalizing s0 acc with
| nil => simpa [dfsFromListCollect]
| cons u us ih =>
simp [dfsFromListCollect]
split_ifs with hwhite
· exact ih (fun v hv => hvs v (by simp [hv])) _ _
(collectInvariant_step G hfuel (hvs u (by simp)) us hwhite hinv)
· exact ih (fun v hv => hvs v (by simp [hv])) _ _ hinv
The final state of Graph.dfsFromListCollect is exactly the state of
the underlying DFS, independent of the accumulator.
theorem dfsFromListCollect_state_eq {G : Graph V} {fuel : Nat}
(vs : List V) (s0 : DFSState V) (acc : List (Finset V)) :
(dfsFromListCollect G fuel vs s0 acc).2 = dfsFromList G fuel vs s0 := by
induction vs generalizing s0 acc with
| nil => simp [dfsFromListCollect, dfsFromList]
| cons u us ih =>
simp [dfsFromListCollect, dfsFromList]
split_ifs with hwhite
· rw [ih]
· rw [ih]
After Graph.dfsFromListCollect processes a list containing every
vertex (with positive fuel), every vertex is black.
theorem dfsFromListCollect_all_black {G : Graph V} {fuel : Nat}
{vs : List V} {s0 : DFSState V} {acc : List (Finset V)}
(h0 : ∀ v, s0.color v = Color.white ∨ s0.color v = Color.black)
(hfuel : 0 < fuel) (hvs : ∀ v ∈ G.vertices, v ∈ vs) :
∀ v ∈ G.vertices, (dfsFromListCollect G fuel vs s0 acc).2.color v = Color.black := by
intro v hv
rw [dfsFromListCollect_state_eq]
have h := (dfsFromList_all_black G s0 h0 hfuel vs).1
exact h v (hvs v hv)
The strongly connected component of r in G.
def sccOf (G : Graph V) (r : V) : Set V := {v | G.StronglyConnected r v}theorem reachable_target_mem_vertices {u v : V} (hu : u ∈ G.vertices) (hr : G.Reachable u v) :
v ∈ G.vertices := by
induction hr with
| refl => exact hu
| tail _ hadj _ => exact G.adj_mem_right hadj
theorem transpose_reachable {u v : V} : G.transpose.Reachable u v ↔ G.Reachable v u := by
constructor
· intro hr
induction hr with
| refl => exact Relation.ReflTransGen.refl
| @tail x y _ hadj ih =>
have hGadj : G.Adj y x := by simpa using hadj
exact Relation.ReflTransGen.trans (Relation.ReflTransGen.single hGadj) ih
· intro hr
induction hr with
| refl => exact Relation.ReflTransGen.refl
| @tail x y _ hadj ih =>
have hGadj : G.transpose.Adj y x := by simpa using hadj
exact Relation.ReflTransGen.trans (Relation.ReflTransGen.single hGadj) ih
theorem transpose_sccOf_eq (r : V) : G.transpose.sccOf r = G.sccOf r := by
ext v
simp [sccOf, StronglyConnected, transpose_reachable G]
rw [and_comm]theorem isSCC_sccOf {r : V} (hr : r ∈ G.vertices) : G.IsSCC (G.sccOf r) := by
refine ⟨?_, ?_, ?_, ?_⟩
· use r
exact stronglyConnected_refl G r
· intro v hv
exact reachable_target_mem_vertices G hr (StronglyConnected.reachable G hv)
· intro u hu v hv
exact ⟨G.reachable_trans (StronglyConnected.reverse_reachable G hu)
(StronglyConnected.reachable G hv),
G.reachable_trans (StronglyConnected.reverse_reachable G hv)
(StronglyConnected.reachable G hu)⟩
· intro w hw hsc
exact hsc r (stronglyConnected_refl G r)theorem WhiteReachable.of_reachable_through_set {s : DFSState V} {u v : V} {S : Set V}
(hS : ∀ w, G.Reachable u w → G.Reachable w v → w ∈ S)
(hwhite : ∀ w ∈ S, s.color w = Color.white)
(huv : G.Reachable u v) :
WhiteReachable G s u v := by
induction huv with
| refl => exact whiteReachable_refl G s u
| @tail x y hux hadj ih =>
have hyS : y ∈ S := hS y (G.reachable_trans hux (G.reachable_adj hadj)) (G.reachable_refl y)
have ih' : WhiteReachable G s u x := ih (fun w h1 h2 => hS w h1 (G.reachable_trans h2 (G.reachable_adj hadj)))
exact whiteReachable_step G ih' hadj (hwhite y hyS)theorem maxFinish_sccOf_eq {s : DFSState V} {r : V} (hr : r ∈ G.vertices)
(hmax : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) r)
(hwhite : ∀ v ∈ G.sccOf r, s.color v = Color.white) :
maxFinish G (G.dfs) (G.sccOf r) = finishTime (G.dfs) r := by
have hsub : (G.sccOf r : Set V) ⊆ G.vertices :=
IsSCC.subset_vertices G (isSCC_sccOf G hr)
exact maxFinish_eq_of_forall_finish_le G (s := G.dfs) hsub
(stronglyConnected_refl G r) (fun v hv => hmax v (hwhite v hv))
A DFS state is SCC-monochrome when every SCC of G is either entirely
white or entirely black in that state. This is the main invariant of the
second pass of Kosaraju's algorithm.
def SCCMonochrome (G : Graph V) (s : DFSState V) : Prop :=
∀ K, G.IsSCC K → (∀ v ∈ K, s.color v = Color.white) ∨
(∀ v ∈ K, s.color v = Color.black)
If SCCs are monochromatic and r is white, then every vertex in
r's SCC is white.
theorem sccOf_white_of_monochrome {s : DFSState V} {r : V}
(hr : r ∈ G.vertices) (hwhite : s.color r = Color.white)
(hmono : G.SCCMonochrome s) :
∀ v ∈ G.sccOf r, s.color v = Color.white := by
have hC : G.IsSCC (G.sccOf r) := isSCC_sccOf G hr
rcases hmono (G.sccOf r) hC with (hw | hb)
· exact hw
· have hblack : s.color r = Color.black := hb r (stronglyConnected_refl G r)
rw [hblack] at hwhite
contradictionThe SCC-specific invariant used while proving correctness of Kosaraju's second DFS pass. It tracks the proof obligations that are not already part of the collecting-DFS invariant.
structure KosarajuSCCInvariant (G : Graph V) (vs : List V) (s : DFSState V)
(acc : List (Finset V)) : Prop where
acc_scc : ∀ C ∈ acc, G.IsSCC (C : Set V)
white_in_vs : ∀ v, v ∈ G.vertices → s.color v = Color.white → v ∈ vs
scc_monochrome : G.SCCMonochrome s
no_gray : ∀ v, s.color v = Color.white ∨ s.color v = Color.blackGraph-theoretic lemmas for SCC finish-time ordering
Distinct SCCs with an edge from C to D have no path from
D back to C. If such a path existed, C and D
would be a single SCC.
theorem no_reachable_scc_reverse {C D : Set V} (hC : G.IsSCC C) (hD : G.IsSCC D)
(hne : C ≠ D) (hedge : ∃ u ∈ C, ∃ v ∈ D, G.Adj u v) (x y : V)
(hx : x ∈ D) (hy : y ∈ C) : ¬ G.Reachable x y := by
intro hreach
apply hne
apply IsSCC_eq_of_nonempty_inter G hC hD
-- Find a vertex in the intersection: we'll show that y ∈ C ∩ D
-- Since C and D must be equal
rcases hC with ⟨⟨rC, hrC⟩, hCsub, hCsc, hCmax⟩
rcases hD with ⟨⟨rD, hrD⟩, hDsub, hDsc, hDmax⟩
rcases hedge with ⟨u, hu, v, hv, hadj⟩
-- We show that y ∈ D (so y is in C ∩ D, giving the intersection)
have hyV : y ∈ G.vertices := hCsub hy
have h_forall : ∀ u ∈ D, G.StronglyConnected u y := by
intro d hd
-- d →* x (within D) → y (via x→*y) gives one direction
-- y →* u (within C) → v (edge) →* d (within D) gives the other
have hdx : G.Reachable d x := StronglyConnected.reachable G (hDsc d hd x hx)
have hxy : G.Reachable x y := hreach
have hyu : G.Reachable y u := StronglyConnected.reachable G (hCsc y hy u hu)
have hvd : G.Reachable v d := StronglyConnected.reachable G (hDsc v hv d hd)
have hdy : G.Reachable d y := G.reachable_trans hdx hxy
have hyd : G.Reachable y d :=
G.reachable_trans hyu (G.reachable_trans (G.reachable_adj hadj) hvd)
exact ⟨hdy, hyd⟩
have hyD : y ∈ D := hDmax y hyV h_forall
exact ⟨y, hy, hyD⟩
If u, v ∈ C (same SCC) and w lies on a path from u to
v, then w ∈ C. This is the SCC-path-closure property: SCCs are closed under
intermediate vertices on reachability paths.
theorem IsSCC.path_mem {C : Set V} (hC : G.IsSCC C) {u v w : V}
(hu : u ∈ C) (hv : v ∈ C) (h1 : G.Reachable u w) (h2 : G.Reachable w v) :
w ∈ C := by
have hwV : w ∈ G.vertices := reachable_target_mem_vertices G (IsSCC.subset_vertices G hC hu) h1
apply IsSCC.maximal G hC w hwV
intro x hx
have hsc_xu : G.StronglyConnected x u := IsSCC.stronglyConnected G hC x hx u hu
have hsc_uv : G.StronglyConnected u v := IsSCC.stronglyConnected G hC u hu v hv
have hsc_uw : G.StronglyConnected u w :=
⟨h1, G.reachable_trans h2 (StronglyConnected.reverse_reachable G hsc_uv)⟩
exact ⟨G.reachable_trans (StronglyConnected.reachable G hsc_xu)
(StronglyConnected.reachable G hsc_uw),
G.reachable_trans (StronglyConnected.reverse_reachable G hsc_uw)
(StronglyConnected.reverse_reachable G hsc_xu)⟩Inside an all-white SCC, reachability between two component vertices is white-reachability.
theorem WhiteReachable.of_isSCC {s : DFSState V} {C : Set V} {u v : V}
(hC : G.IsSCC C) (hu : u ∈ C) (hv : v ∈ C)
(hwhite : ∀ w ∈ C, s.color w = Color.white) :
WhiteReachable G s u v := by
have hreach : G.Reachable u v :=
StronglyConnected.reachable G (IsSCC.stronglyConnected G hC u hu v hv)
exact WhiteReachable.of_reachable_through_set G (S := C)
(fun w h1 h2 => IsSCC.path_mem G hC hu hv h1 h2) hwhite hreach
If all vertices of SCCs C and D are white and there is an edge
from C to D, then white-reachability crosses from any vertex of
C to any vertex of D.
theorem WhiteReachable.across_scc_edge {s : DFSState V} {C D : Set V} {r d : V}
(hC : G.IsSCC C) (hD : G.IsSCC D) (hr : r ∈ C) (hd : d ∈ D)
(hwhite_C : ∀ w ∈ C, s.color w = Color.white)
(hwhite_D : ∀ w ∈ D, s.color w = Color.white)
(hedge : ∃ u ∈ C, ∃ v ∈ D, G.Adj u v) :
WhiteReachable G s r d := by
rcases hedge with ⟨u, hu, v, hv, hadj⟩
have h_wr_r_u : WhiteReachable G s r u :=
WhiteReachable.of_isSCC G hC hr hu hwhite_C
have h_wr_r_v : WhiteReachable G s r v :=
whiteReachable_step G h_wr_r_u hadj (hwhite_D v hv)
have h_wr_v_d : WhiteReachable G s v d :=
WhiteReachable.of_isSCC G hD hv hd hwhite_D
exact whiteReachable_trans G h_wr_r_v h_wr_v_dWhite-reachability forgets to ordinary reachability, so a non-reachable target is not white-reachable.
theorem not_whiteReachable_of_not_reachable {s : DFSState V} {u v : V}
(hno : ¬ G.Reachable u v) : ¬ WhiteReachable G s u v := by
intro hwr
exact hno (hwr.mono (fun _ _ h => h.1))
At the discovery state of r, any vertex whose final discovery time is
not earlier than r's is still white.
theorem white_at_discovery_state_of_discovery_ge {s : DFSState V} {r v : V}
(hdisc_eq : discoveryTime (G.dfs) r = s.time)
(h_nonwhite : ∀ w, s.color w ≠ Color.white → discoveryTime (G.dfs) w < s.time)
(hge : discoveryTime (G.dfs) r ≤ discoveryTime (G.dfs) v) :
s.color v = Color.white := by
by_cases hw : s.color v = Color.white
· exact hw
· have hlt := h_nonwhite v hw
rw [← hdisc_eq] at hlt
omega
Set version of Graph.white_at_discovery_state_of_discovery_ge.
theorem set_white_at_discovery_state_of_min_discovery {s : DFSState V} {C : Set V} {r : V}
(hdisc_eq : discoveryTime (G.dfs) r = s.time)
(h_nonwhite : ∀ w, s.color w ≠ Color.white → discoveryTime (G.dfs) w < s.time)
(hmin : ∀ v ∈ C, discoveryTime (G.dfs) r ≤ discoveryTime (G.dfs) v) :
∀ v ∈ C, s.color v = Color.white := by
intro v hv
exact white_at_discovery_state_of_discovery_ge G hdisc_eq h_nonwhite (hmin v hv)
If rC is discovered before rD, and each is first-discovered in
its set, then both sets are white at rC's discovery state.
theorem sets_white_at_earlier_discovery_state {s : DFSState V} {C D : Set V} {rC rD : V}
(hdisc_eq : discoveryTime (G.dfs) rC = s.time)
(h_nonwhite : ∀ w, s.color w ≠ Color.white → discoveryTime (G.dfs) w < s.time)
(hmin_C : ∀ v ∈ C, discoveryTime (G.dfs) rC ≤ discoveryTime (G.dfs) v)
(hmin_D : ∀ v ∈ D, discoveryTime (G.dfs) rD ≤ discoveryTime (G.dfs) v)
(hlt : discoveryTime (G.dfs) rC < discoveryTime (G.dfs) rD) :
(∀ v ∈ C, s.color v = Color.white) ∧ (∀ v ∈ D, s.color v = Color.white) := by
constructor
· exact set_white_at_discovery_state_of_min_discovery G hdisc_eq h_nonwhite hmin_C
· apply set_white_at_discovery_state_of_min_discovery G hdisc_eq h_nonwhite
intro v hv
have hle := hmin_D v hv
omegaA white vertex that is not white-reachable from a white DFS root remains white after that root's visit.
theorem dfsVisit_preserves_white_of_not_whiteReachable {fuel : Nat} {s : DFSState V}
{u v : V} (hu_white : s.color u = Color.white) (hfuel : 0 < fuel)
(hv_white : s.color v = Color.white) (hno : ¬ WhiteReachable G s u v) :
(dfsVisit G fuel u s).color v = Color.white := by
by_cases hb : (dfsVisit G fuel u s).color v = Color.black
· have hwr : WhiteReachable G s u v :=
dfsVisit_blackens_implies_whiteReachable G hu_white hfuel hv_white hb
exact absurd hwr hno
· have hno_gray : (dfsVisit G fuel u s).color v ≠ Color.gray := by
intro hg
have h_input_gray : s.color v = Color.gray := dfsVisit_no_new_gray G v hg
rw [hv_white] at h_input_gray
contradiction
cases hcolor : (dfsVisit G fuel u s).color v with
| white => rfl
| gray => exact (hno_gray hcolor).elim
| black => exact (hb hcolor).elimIf a local visit finishes its source, leaves another vertex white, and the full DFS later discovers that vertex, then the source finishes before that vertex is discovered in the full DFS.
theorem finish_before_discovery_of_visit_output_white {fuel : Nat} {s : DFSState V}
{u v : V} (hu_white : s.color u = Color.white) (hfuel : 0 < fuel)
(hfinish_pres :
finishTime (G.dfs) u = finishTime (dfsVisit G fuel u s) u)
(hv_white_out : (dfsVisit G fuel u s).color v = Color.white)
(hlater : ∀ w, (dfsVisit G fuel u s).color w = Color.white →
(G.dfs).color w ≠ Color.white →
(dfsVisit G fuel u s).time ≤ discoveryTime (G.dfs) w)
(hv_final_nonwhite : (G.dfs).color v ≠ Color.white) :
finishTime (G.dfs) u < discoveryTime (G.dfs) v := by
have hfinish_visit :
finishTime (dfsVisit G fuel u s) u = (dfsVisit G fuel u s).time - 1 :=
dfsVisit_finishTime_source_eq_pred_time G hfuel hu_white
have htime_gt_finish :
(dfsVisit G fuel u s).time > finishTime (dfsVisit G fuel u s) u := by
have htime_gt_s : (dfsVisit G fuel u s).time > s.time :=
dfsVisit_time_gt_of_white G hfuel hu_white
omega
rw [hfinish_pres]
by_contra hnot
have hdisc_lt_time :
discoveryTime (G.dfs) v < (dfsVisit G fuel u s).time := by
omega
have hdisc_ge_time :
(dfsVisit G fuel u s).time ≤ discoveryTime (G.dfs) v :=
hlater v hv_white_out hv_final_nonwhite
omegaIf a white vertex is not white-reachable from a white DFS root, but is later non-white in the full DFS, then the root finishes before that vertex is discovered in the full DFS.
theorem finish_before_discovery_of_not_whiteReachable_visit {fuel : Nat} {s : DFSState V}
{u v : V} (hu_white : s.color u = Color.white) (hfuel : 0 < fuel)
(hv_white : s.color v = Color.white) (hno : ¬ WhiteReachable G s u v)
(hfinish_pres :
finishTime (G.dfs) u = finishTime (dfsVisit G fuel u s) u)
(hlater : ∀ w, (dfsVisit G fuel u s).color w = Color.white →
(G.dfs).color w ≠ Color.white →
(dfsVisit G fuel u s).time ≤ discoveryTime (G.dfs) w)
(hv_final_nonwhite : (G.dfs).color v ≠ Color.white) :
finishTime (G.dfs) u < discoveryTime (G.dfs) v := by
have hv_white_out : (dfsVisit G fuel u s).color v = Color.white :=
dfsVisit_preserves_white_of_not_whiteReachable G hu_white hfuel hv_white hno
exact finish_before_discovery_of_visit_output_white G hu_white hfuel
hfinish_pres hv_white_out hlater hv_final_nonwhiteIf a white-reachable vertex is blackened during a local visit, then its full DFS finish time is strictly before the source's full DFS finish time.
theorem finish_lt_source_in_full_dfs_of_whiteReachable_visit {fuel : Nat} {s : DFSState V}
{u v : V} (hu_vert : u ∈ G.vertices) (hu_white : s.color u = Color.white)
(hbf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hfuel : fuel ≥ (whiteReachableSet G s u).card + 1)
(hv_white : s.color v = Color.white) (hwr : WhiteReachable G s u v)
(hne : v ≠ u)
(hpres : ∀ w, (dfsVisit G fuel u s).color w = Color.black →
finishTime (G.dfs) w = finishTime (dfsVisit G fuel u s) w) :
finishTime (G.dfs) v < finishTime (G.dfs) u := by
have hfuel_pos : 0 < fuel := by omega
have hblack_v : (dfsVisit G fuel u s).color v = Color.black := by
apply dfsVisit_white_path_black G hu_white hu_vert hfuel
exact WhiteReachable.mem_set G hu_vert hwr
have hfinish_lt :
finishTime (dfsVisit G fuel u s) v < finishTime (dfsVisit G fuel u s) u := by
apply dfsVisit_finish_lt_source_finish G hfuel_pos hu_white hbf hv_white hblack_v hne
have hblack_u : (dfsVisit G fuel u s).color u = Color.black :=
dfsVisit_blackens_u_pos G hfuel_pos hu_white
have h_f_v := hpres v hblack_v
have h_f_u := hpres u hblack_u
simpa [h_f_v, h_f_u] using hfinish_ltIf an SCC is white in a discovery state, and a local DFS visit from a vertex in that SCC has finish times preserved into the full DFS, then that source attains the SCC's maximum full-DFS finish time.
theorem maxFinish_eq_of_white_scc_visit_source {fuel : Nat} {s : DFSState V}
{C : Set V} {r : V} (hC : G.IsSCC C) (hr : r ∈ C)
(hwhite_C : ∀ v ∈ C, s.color v = Color.white)
(hr_white : s.color r = Color.white)
(hbf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hfuel : fuel ≥ (whiteReachableSet G s r).card + 1)
(hpres : ∀ w, (dfsVisit G fuel r s).color w = Color.black →
finishTime (G.dfs) w = finishTime (dfsVisit G fuel r s) w) :
maxFinish G (G.dfs) C = finishTime (G.dfs) r := by
have hCsub : C ⊆ G.vertices := IsSCC.subset_vertices G hC
apply maxFinish_eq_of_forall_finish_le G (s := G.dfs) hCsub hr
intro v hv
by_cases hvr : v = r
· subst v
rfl
· have hv_white : s.color v = Color.white := hwhite_C v hv
have hwr : WhiteReachable G s r v :=
WhiteReachable.of_isSCC G hC hr hv hwhite_C
exact le_of_lt (finish_lt_source_in_full_dfs_of_whiteReachable_visit G
(hCsub hr) hr_white hbf hfuel hv_white hwr hvr hpres)If two distinct SCCs are white in a discovery state and there is an edge from the first to the second, then a local DFS visit from the first SCC finishes each target SCC vertex before the source.
theorem finish_lt_source_of_white_scc_edge_visit {fuel : Nat} {s : DFSState V}
{C D : Set V} {r d : V} (hC : G.IsSCC C) (hD : G.IsSCC D)
(hne : C ≠ D) (hedge : ∃ u ∈ C, ∃ v ∈ D, G.Adj u v)
(hr : r ∈ C) (hd : d ∈ D)
(hwhite_C : ∀ v ∈ C, s.color v = Color.white)
(hwhite_D : ∀ v ∈ D, s.color v = Color.white)
(hbf : ∀ w, s.color w = Color.black → finishTime s w < s.time)
(hfuel : fuel ≥ (whiteReachableSet G s r).card + 1)
(hpres : ∀ w, (dfsVisit G fuel r s).color w = Color.black →
finishTime (G.dfs) w = finishTime (dfsVisit G fuel r s) w) :
finishTime (G.dfs) d < finishTime (G.dfs) r := by
have hCsub : C ⊆ G.vertices := IsSCC.subset_vertices G hC
have hr_white : s.color r = Color.white := hwhite_C r hr
have hd_white : s.color d = Color.white := hwhite_D d hd
have hne_dr : d ≠ r := by
intro heq
subst d
apply hne
exact IsSCC_eq_of_nonempty_inter G hC hD ⟨r, hr, hd⟩
have hwr : WhiteReachable G s r d :=
WhiteReachable.across_scc_edge G hC hD hr hd hwhite_C hwhite_D hedge
exact finish_lt_source_in_full_dfs_of_whiteReachable_visit G (hCsub hr)
hr_white hbf hfuel hd_white hwr hne_dr hpresCore finish-time ordering of distinct SCCs (CLRS Lemma 20.14).
If C and D are distinct strongly connected components of G
and there is an edge from C to D, then the maximum finish time in
C (after the first DFS) is strictly larger than the maximum finish time in
D.
open Classical in
theorem scc_finish_time_order {C D : Set V}
(hC : G.IsSCC C) (hD : G.IsSCC D) (hne : C ≠ D)
(hedge : ∃ u ∈ C, ∃ v ∈ D, G.Adj u v) :
maxFinish G (G.dfs) D < maxFinish G (G.dfs) C := by
have hC_nonempty : C.Nonempty := IsSCC.nonempty G hC
have hCsub : C ⊆ G.vertices := IsSCC.subset_vertices G hC
have hD_nonempty : D.Nonempty := IsSCC.nonempty G hD
have hDsub : D ⊆ G.vertices := IsSCC.subset_vertices G hD
let rC := firstDiscoveredVertex G (s := G.dfs) (C := C) hC_nonempty hCsub
let rD := firstDiscoveredVertex G (s := G.dfs) (C := D) hD_nonempty hDsub
rcases (by
simpa [rC] using firstDiscoveredVertex_mem_min G (s := G.dfs) (C := C)
hC_nonempty hCsub) with ⟨hrC_mem, hdisc_min_C⟩
rcases (by
simpa [rD] using firstDiscoveredVertex_mem_min G (s := G.dfs) (C := D)
hD_nonempty hDsub) with ⟨hrD_mem, hdisc_min_D⟩
-- Obtain max-finish witnesses
rcases maxFinish_exists G (s := G.dfs) (C := C) hC_nonempty hCsub with ⟨c, _hcC, hc_max⟩
rcases maxFinish_exists G (s := G.dfs) (C := D) hD_nonempty hDsub with ⟨d, hdD, hd_max⟩
rw [hc_max, hd_max]
-- Compare discovery times of rC and rD
by_cases hd_lt : discoveryTime (G.dfs) rC < discoveryTime (G.dfs) rD
· -- Case 1: rC discovered first. Use exists_discovery_state.
have h_rC_vert : rC ∈ G.vertices := hCsub hrC_mem
rcases exists_discovery_state G rC h_rC_vert with
⟨s, f, hs_white, _hs_black, hdisc_eq, h_nonwhite, h_bf_s, _h_gray_s,
h_f_pres, h_fuel, _h_later⟩
-- hdisc_eq: d[rC] = s.time. h_nonwhite: non-white w in s → d[w] < s.time = d[rC].
-- h_bf_s: black-finish invariant for s.
-- h_f_pres: f-preservation for dfsVisit output.
-- h_fuel: f ≥ |whiteReachableSet s rC| + 1
-- All of C ∪ D is white in s (otherwise d[v] < d[rC], contradicting firstDiscoveredVertex_min)
have hsets_white :=
sets_white_at_earlier_discovery_state G hdisc_eq h_nonwhite hdisc_min_C hdisc_min_D hd_lt
have hwhite_C : ∀ v ∈ C, s.color v = Color.white := hsets_white.1
have hwhite_D : ∀ v ∈ D, s.color v = Color.white := hsets_white.2
calc
finishTime (G.dfs) d < finishTime (G.dfs) rC :=
finish_lt_source_of_white_scc_edge_visit G hC hD hne hedge hrC_mem hdD
hwhite_C hwhite_D h_bf_s h_fuel h_f_pres
_ ≤ finishTime (G.dfs) c :=
finish_le_maxFinish_witness G hCsub hrC_mem hc_max
· -- Case 2: rD discovered first (or same time), i.e., d[rD] ≤ d[rC].
-- Since D cannot reach C, rC is not in rD's DFS tree, so rD finishes before
-- rC is discovered: f[rD] < d[rC].
have h_no_rev : ¬ G.Reachable rD rC :=
no_reachable_scc_reverse G hC hD hne hedge rD rC hrD_mem hrC_mem
have hd_le : discoveryTime (G.dfs) rD ≤ discoveryTime (G.dfs) rC := by omega
-- Use exists_discovery_state for rD
have h_rD_vert : rD ∈ G.vertices := hDsub hrD_mem
rcases exists_discovery_state G rD h_rD_vert with
⟨s, f, hs_white, hs_black, hdisc_eq, h_nonwhite, h_bf_s, _h_gray_s,
h_f_pres, h_fuel, h_later⟩
-- All of D is white in s
have hwhite_D : ∀ v ∈ D, s.color v = Color.white :=
set_white_at_discovery_state_of_min_discovery G hdisc_eq h_nonwhite hdisc_min_D
-- rC also white in s (d[rC] ≥ d[rD] = s.time)
have hwhite_rC : s.color rC = Color.white :=
white_at_discovery_state_of_discovery_ge G hdisc_eq h_nonwhite hd_le
-- rC NOT white-reachable from rD (D cannot reach C)
have h_no_wr : ¬ WhiteReachable G s rD rC :=
not_whiteReachable_of_not_reachable G h_no_rev
-- Since rC stays white after rD's local visit but is black in the full DFS,
-- the discovery-state bridge forces rD to finish before rC is discovered.
have h_finish_lt_disc : finishTime (G.dfs) rD < discoveryTime (G.dfs) rC := by
have h_f_G_rD : finishTime (G.dfs) rD = finishTime (dfsVisit G f rD s) rD := h_f_pres rD hs_black
have h_nonwhite_final : (G.dfs).color rC ≠ Color.white := by
rw [G.dfs_all_black (hCsub hrC_mem)]; decide
exact finish_before_discovery_of_not_whiteReachable_visit G hs_white (by omega)
hwhite_rC h_no_wr h_f_G_rD h_later h_nonwhite_final
-- maxFinish(D) = f[rD]
have h_maxFinish_D_eq : maxFinish G (G.dfs) D = finishTime (G.dfs) rD :=
maxFinish_eq_of_white_scc_visit_source G hD hrD_mem hwhite_D hs_white h_bf_s h_fuel
h_f_pres
rw [← hd_max, h_maxFinish_D_eq]
have h_disc_lt_fin : discoveryTime (G.dfs) rC < finishTime (G.dfs) rC :=
dfs_discovery_lt_finish G (hCsub hrC_mem)
calc
finishTime (G.dfs) rD < discoveryTime (G.dfs) rC := h_finish_lt_disc
_ < finishTime (G.dfs) rC := h_disc_lt_fin
_ ≤ finishTime (G.dfs) c := finish_le_maxFinish_witness G hCsub hrC_mem hc_max
If r is maximal among the currently white vertices and SCCs are
monochrome, then a white predecessor of a vertex in r's SCC is also in
r's SCC. This is the local contradiction step used when traversing the
transpose graph in Kosaraju's second pass.
theorem white_predecessor_mem_sccOf_of_max_finish {s : DFSState V} {r v w : V}
(hr : r ∈ G.vertices) (hwhite_r : s.color r = Color.white)
(hmax : ∀ x, s.color x = Color.white → finishTime (G.dfs) x ≤ finishTime (G.dfs) r)
(hrespects : G.SCCMonochrome s)
(hw_scc : w ∈ G.sccOf r) (hGadj : G.Adj v w)
(hwhite_v : s.color v = Color.white) :
v ∈ G.sccOf r := by
have hC : G.IsSCC (G.sccOf r) := isSCC_sccOf G hr
have hC_white : ∀ x ∈ G.sccOf r, s.color x = Color.white :=
sccOf_white_of_monochrome G hr hwhite_r hrespects
have hCmax : maxFinish G (G.dfs) (G.sccOf r) = finishTime (G.dfs) r :=
maxFinish_sccOf_eq G hr hmax hC_white
by_contra hne
have hvV : v ∈ G.vertices := G.adj_mem_left hGadj
let D := G.sccOf v
have hD : G.IsSCC D := isSCC_sccOf G hvV
have hDneC : D ≠ G.sccOf r := by
intro heq
have hvinD : v ∈ D := stronglyConnected_refl G v
rw [heq] at hvinD
exact hne hvinD
have hedge : ∃ u ∈ D, ∃ v ∈ G.sccOf r, G.Adj u v :=
⟨v, stronglyConnected_refl G v, w, hw_scc, hGadj⟩
have hord := scc_finish_time_order G hD hC hDneC hedge
have hD_white : ∀ x ∈ D, s.color x = Color.white := by
rcases hrespects D hD with (hw' | hb')
· exact hw'
· have hblack : s.color v = Color.black := hb' v (stronglyConnected_refl G v)
rw [hblack] at hwhite_v
contradiction
have hDmax : maxFinish G (G.dfs) D ≤ finishTime (G.dfs) r :=
maxFinish_le_of_forall_finish_le G (fun x hx => hmax x (hD_white x hx))
linarith [hord, hCmax, hDmax]
theorem whiteReachableSet_subset_scc {s : DFSState V} {r : V}
(hr : r ∈ G.transpose.vertices) (hwhite : s.color r = Color.white)
(hmax : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) r)
(hrespects : G.SCCMonochrome s) :
(whiteReachableSet G.transpose s r : Set V) ⊆ G.sccOf r := by
have hrG : r ∈ G.vertices := by simpa using hr
have hstable := whiteReachableIter_stable G.transpose s r hr
intro v hv
rw [hstable] at hv
have h : ∀ n, ∀ v ∈ whiteReachableIter G.transpose s r n, v ∈ G.sccOf r := by
intro n
induction n with
| zero =>
intro v hv
simp [whiteReachableIter] at hv
rw [hv]
exact stronglyConnected_refl G r
| succ n ih =>
intro v hv
simp [whiteReachableIter, whiteReachableSucc, Finset.mem_filter, Finset.mem_biUnion] at hv
rcases hv with (h | ⟨⟨w, hw, hadj⟩, hwhite_v⟩)
· exact ih v h
· have hw_scc : w ∈ G.sccOf r := ih w hw
have htadj : G.transpose.Adj w v := by
simp [Adj] at hadj ⊢
exact hadj
have hGadj : G.Adj v w := by
have h := htadj
simp [transpose_Adj] at h ⊢
exact h
exact white_predecessor_mem_sccOf_of_max_finish G hrG hwhite hmax hrespects
hw_scc hGadj hwhite_v
exact h (G.transpose.vertices.card + 1) v hvA transpose DFS visit from a white root blackens every vertex in that root's original SCC, provided that SCC is still white.
theorem dfsVisit_transpose_blackens_sccOf {s : DFSState V} {r v : V}
(hr : r ∈ G.transpose.vertices) (hwhite_r : s.color r = Color.white)
(hfuel : fuel ≥ G.transpose.vertices.card + 1)
(h_scc_white : ∀ w ∈ G.sccOf r, s.color w = Color.white)
(hv : v ∈ G.sccOf r) :
(dfsVisit G.transpose fuel r s).color v = Color.black := by
have h_sccT : G.transpose.IsSCC (G.transpose.sccOf r) :=
isSCC_sccOf G.transpose hr
have hr_sccT : r ∈ G.transpose.sccOf r := stronglyConnected_refl G.transpose r
have hv_sccT : v ∈ G.transpose.sccOf r := by
rw [transpose_sccOf_eq G r]
exact hv
have hwhite_sccT : ∀ w ∈ G.transpose.sccOf r, s.color w = Color.white := by
intro w hw
rw [transpose_sccOf_eq G r] at hw
exact h_scc_white w hw
have h_wr : WhiteReachable G.transpose s r v :=
WhiteReachable.of_isSCC G.transpose h_sccT hr_sccT hv_sccT hwhite_sccT
have hcard : (whiteReachableSet G.transpose s r).card ≤ G.transpose.vertices.card := by
apply Finset.card_le_card
exact whiteReachableSet_subset_vertices G.transpose s r hr
have hfuel_wr : fuel ≥ (whiteReachableSet G.transpose s r).card + 1 := by omega
exact dfsVisit_white_path_black G.transpose hwhite_r hr hfuel_wr
(WhiteReachable.mem_set G.transpose hr h_wr)A vertex that is white before a transpose DFS visit and black afterwards belongs to the source's original SCC when the source has maximal white finish time.
theorem transpose_visit_blackened_white_mem_sccOf {fuel : Nat} {s : DFSState V}
{r v : V} (hr : r ∈ G.transpose.vertices) (hwhite_r : s.color r = Color.white)
(hfuel : 0 < fuel)
(hmax : ∀ x, s.color x = Color.white → finishTime (G.dfs) x ≤ finishTime (G.dfs) r)
(hrespects : G.SCCMonochrome s)
(hv_white : s.color v = Color.white)
(hv_black : (dfsVisit G.transpose fuel r s).color v = Color.black) :
v ∈ G.sccOf r := by
have hwr : WhiteReachable G.transpose s r v :=
dfsVisit_blackens_implies_whiteReachable G.transpose hwhite_r hfuel hv_white hv_black
have hv_wr_set : v ∈ whiteReachableSet G.transpose s r :=
WhiteReachable.mem_set G.transpose hr hwr
exact whiteReachableSet_subset_scc G hr hwhite_r hmax hrespects hv_wr_setCore DFS finish-time lemma.
Consider a DFS state s of G and a white vertex r whose finish time is
maximal among all white vertices. Then the DFS tree of G.transpose rooted
at r visits exactly the SCC of r in G.
The extra respects assumption guarantees that every SCC of G is
either completely white or completely black in s; this holds during
Kosaraju's second pass.
theorem scc_finish_order {G : Graph V} {s : DFSState V} {r : V}
(hr : r ∈ G.transpose.vertices) (hwhite : s.color r = Color.white)
(hmax : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) r)
(hfuel : fuel ≥ G.transpose.vertices.card + 1)
(hrespects : G.SCCMonochrome s) :
let s' := dfsVisit G.transpose fuel r s
let C := G.transpose.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black)
G.IsSCC (C : Set V) := by
intro s' C
have hrG : r ∈ G.vertices := by simpa using hr
have hCr : G.IsSCC (G.sccOf r) := isSCC_sccOf G hrG
have hCr_white : ∀ v ∈ G.sccOf r, s.color v = Color.white :=
sccOf_white_of_monochrome G hrG hwhite hrespects
have hsubset : (C : Set V) ⊆ G.sccOf r := by
intro v hv
simp [C] at hv
rcases hv with ⟨_, hwhite_v, hblack_v⟩
exact transpose_visit_blackened_white_mem_sccOf G hr hwhite (by omega)
hmax hrespects hwhite_v hblack_v
have hsupset : G.sccOf r ⊆ (C : Set V) := by
intro v hv
have hwhite_v : s.color v = Color.white := hCr_white v hv
have hvV : v ∈ G.transpose.vertices := by
simpa using reachable_target_mem_vertices G hrG (StronglyConnected.reachable G hv)
have hblack_v : s'.color v = Color.black := by
exact dfsVisit_transpose_blackens_sccOf G hr hwhite hfuel hCr_white hv
simp [C]
exact ⟨hvV, hwhite_v, hblack_v⟩
rw [Set.Subset.antisymm hsubset hsupset]
exact hCrKosaraju produces a partition of the vertex set
theorem kosaraju_order_subset_vertices (G : Graph V) :
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
∀ v ∈ order, v ∈ G.transpose.vertices := by
intro order v hv
have hperm : order.Perm G.vertices.toList := List.mergeSort_perm _ _
have : v ∈ G.vertices.toList := hperm.mem_iff.mp hv
simpa [transpose_vertices]
Every vertex of G appears in the order used by Kosaraju's second DFS.
theorem kosaraju_order_contains_vertices (G : Graph V) :
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
∀ v ∈ G.vertices, v ∈ order := by
intro order v hv
have hperm : order.Perm G.vertices.toList := List.mergeSort_perm _ _
exact hperm.mem_iff.mpr (Finset.mem_toList.mpr hv)The order used by Kosaraju's second DFS is non-increasing by first-pass finish time.
theorem kosaraju_order_pairwise_finish_le (G : Graph V) :
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
order.Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a) := by
intro order
have hpair : order.Pairwise (fun a b => finishLe (G.dfs) a b = true) := by
dsimp [order]
apply List.pairwise_mergeSort
· intro a b c hab hbc
simp [finishLe] at hab hbc ⊢
omega
· intro a b
simp [finishLe]
exact Nat.le_total (finishTime (G.dfs) b) (finishTime (G.dfs) a)
exact hpair.imp (by
intro a b hab
simpa [finishLe] using hab)The initial state for Kosaraju's second pass satisfies the SCC-specific induction invariant.
lemma kosaraju_initial_scc_invariant (G : Graph V) :
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
G.KosarajuSCCInvariant order dfsInit ([] : List (Finset V)) := by
intro order
refine { acc_scc := ?_, white_in_vs := ?_, scc_monochrome := ?_, no_gray := ?_ }
· intro C h; simp at h
· intro v hvV _
simpa [order] using kosaraju_order_contains_vertices G v hvV
· intro K _; left; intro v _; rfl
· intro v; left; rfl
theorem kosarajuComponents_subset (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) : (C : Set V) ⊆ G.vertices := by
simp only [kosarajuComponents] at hC
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
have hinv := collectInvariant_init G.transpose
have hfuel : 0 < G.transpose.vertices.card + 1 := by omega
have hinv' := dfsFromListCollect_invariant G.transpose hfuel
(kosaraju_order_subset_vertices G) dfsInit [] hinv
exact hinv'.subset C hC
theorem kosarajuComponents_pairwise_disjoint (G : Graph V) :
G.kosarajuComponents.Pairwise (fun C D => Disjoint C D) := by
simp only [kosarajuComponents]
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
have hinv := collectInvariant_init G.transpose
have hfuel : 0 < G.transpose.vertices.card + 1 := by omega
have hinv' := dfsFromListCollect_invariant G.transpose hfuel
(kosaraju_order_subset_vertices G) dfsInit [] hinv
exact hinv'.pairwise
theorem kosarajuComponents_cover (G : Graph V) :
∀ v ∈ G.vertices, ∃ C ∈ G.kosarajuComponents, v ∈ C := by
intro v hv
simp [kosarajuComponents]
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
have hmem : ∀ x ∈ G.transpose.vertices, x ∈ order := by
intro x hx
have hx' : x ∈ G.vertices := by simpa using hx
exact kosaraju_order_contains_vertices G x hx'
have hinv := collectInvariant_init G.transpose
have hfuel : 0 < G.transpose.vertices.card + 1 := by omega
have hinv' := dfsFromListCollect_invariant G.transpose hfuel
(kosaraju_order_subset_vertices G) dfsInit [] hinv
have hinit : ∀ (v : V), dfsInit.color v = Color.white ∨ dfsInit.color v = Color.black := by
intro v; apply Or.inl; rfl
have hblack := dfsFromListCollect_all_black (G := G.transpose) (acc := []) hinit hfuel hmem
have hcover := hinv'.cover v (by simpa using hv) (hblack v (by simpa using hv))
rcases hcover with ⟨C, hC, hvC⟩
use C
exact ⟨hC, hvC⟩
Every component returned by Graph.kosarajuComponents is nonempty.
theorem kosarajuComponents_nonempty (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) : C.Nonempty := by
simp only [kosarajuComponents] at hC
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
have hinv := collectInvariant_init G.transpose
have hfuel : 0 < G.transpose.vertices.card + 1 := by omega
have hinv' := dfsFromListCollect_invariant G.transpose hfuel
(kosaraju_order_subset_vertices G) dfsInit [] hinv
exact hinv'.nonempty C hCSCC correctness
The remaining section proves that each component collected by the second DFS pass is exactly one strongly connected component, then packages those facts as the final SCC-partition theorem.
In a pairwise-disjoint list of finsets, two distinct members cannot share a vertex.
omit [DecidableEq V] in
theorem unique_mem_of_pairwise_disjoint_cover {ccs : List (Finset V)}
(hdisj : ccs.Pairwise (fun C D => Disjoint C D))
{C D : Finset V}
(hC : C ∈ ccs) (hD : D ∈ ccs) (hv : ∃ v, v ∈ C ∧ v ∈ D) : C = D := by
induction ccs generalizing C D with
| nil => simp at hC
| cons E es ih =>
rcases List.pairwise_cons.mp hdisj with ⟨hE, hdisj'⟩
rcases hv with ⟨v, hvC, hvD⟩
cases hC with
| head =>
cases hD with
| head => rfl
| tail _ hD =>
have hdisjED : Disjoint E D := hE D hD
have hnot : v ∉ D := Finset.disjoint_left.mp hdisjED (by simpa using hvC)
exact False.elim (hnot (by simpa using hvD))
| tail _ hC =>
cases hD with
| head =>
have hdisjEC : Disjoint E C := hE C hC
have hnot : v ∉ C := Finset.disjoint_left.mp hdisjEC (by simpa using hvD)
exact False.elim (hnot (by simpa using hvC))
| tail _ hD =>
exact ih hdisj' hC hD ⟨v, hvC, hvD⟩SCC correctness — helper lemmas
In a list u :: us with Pairwise (finishLe (G.dfs)), every
element of us has finish time at most that of u. This is the key
property that lets us satisfy the hmax precondition of
scc_finish_order at each step of the
second DFS pass.
lemma pairwise_head_max_finishTime (u : V) (us : List V)
(hp : (u :: us).Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a))
(v : V) (hv : v ∈ us) :
finishTime (G.dfs) v ≤ finishTime (G.dfs) u := by
induction us generalizing u with
| nil => simp at hv
| cons w ws ih =>
rcases List.pairwise_cons.mp hp with ⟨h_uw, hp'⟩
have hle_w_u : finishTime (G.dfs) w ≤ finishTime (G.dfs) u := h_uw w (by simp)
rcases List.mem_cons.mp hv with (rfl | hv')
· exact hle_w_u
· have hle : finishTime (G.dfs) v ≤ finishTime (G.dfs) w :=
ih w hp' hv'
omegaSCC correctness — infrastructure lemmas
A dfsVisit from a source u ∈ G.vertices does not change the
f field of any vertex v ∉ G.vertices. All f-changing
operations (setFinish) are on sources or recursively visited neighbours,
all of which are in G.vertices.
lemma dfsVisit_preserves_f_of_not_mem_vertices {fuel : Nat} {u v : V} {s : DFSState V}
(hu : u ∈ G.vertices) (hv : v ∉ G.vertices) :
(dfsVisit G fuel u s).f v = s.f v := by
induction fuel generalizing u s with
| zero => simp [dfsVisit]
| succ n ih =>
by_cases hwhite : s.color u = Color.white
· let s1 := s.setColor u Color.gray |>.setDiscovery u
let step := fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s'
let s2 := List.foldl step s1 (G.adj u).toList
let s3 := s2.setColor u Color.black |>.setFinish u
have h_eq : dfsVisit G (n+1) u s = s3 := by
simp [dfsVisit, hwhite, s1, step, s2, s3]
rw [h_eq]
have h_s1 : s1.f v = s.f v := by simp [s1]
have hne : v ≠ u := by intro heq; subst v; exact hv hu
-- The fold over G.adj u preserves f v because every recursive call
-- has source w ∈ G.adj u ⊆ G.vertices, hence v ≠ w, and the IH applies.
-- General lemma: the fold preserves f v for any list whose elements are in G.vertices
have h_fold_preserves : ∀ (l : List V) (s0 : DFSState V),
(∀ w ∈ l, w ∈ G.vertices) →
(List.foldl (fun (s' : DFSState V) (w : V) =>
if s'.color w = Color.white then dfsVisit G n w (s'.setParent w u) else s')
s0 l).f v = s0.f v := by
intro l
induction l with
| nil => intro s0 _; rfl
| cons w ws ih_ws =>
intro s0 h_all
have hw_vert : w ∈ G.vertices := h_all w (by simp)
have h_ws : ∀ w' ∈ ws, w' ∈ G.vertices := by
intro w' hw'; apply h_all w'; simp [hw']
simp
by_cases hw_white : s0.color w = Color.white
· simp [hw_white]
have h_rest := ih_ws (dfsVisit G n w (s0.setParent w u)) h_ws
rw [h_rest]
have h_rec : (dfsVisit G n w (s0.setParent w u)).f v =
(s0.setParent w u).f v :=
ih (u := w) (s := s0.setParent w u) hw_vert
rw [h_rec]; simp
· simp [hw_white]
exact ih_ws s0 h_ws
have h_all_adj : ∀ w ∈ (G.adj u).toList, w ∈ G.vertices := by
intro w hw
have hw_adj : w ∈ G.adj u := by simpa [Finset.mem_toList] using hw
exact G.adj_sub u hu hw_adj
have h_s2 : s2.f v = s1.f v :=
h_fold_preserves (G.adj u).toList s1 h_all_adj
have h_s3 : s3.f v = s2.f v := by
simp [s3, hne]
rw [h_s3, h_s2, h_s1]
· simp [dfsVisit, hwhite]
dfsFromList preserves the f field of any vertex outside
G.vertices, provided all sources in the list are in G.vertices.
lemma dfsFromList_preserves_f_of_not_mem_vertices (fuel : Nat) (vs : List V) (s : DFSState V)
(v : V) (hv : v ∉ G.vertices) (hvs : ∀ x ∈ vs, x ∈ G.vertices) :
(dfsFromList G fuel vs s).f v = s.f v := by
induction vs generalizing s with
| nil => simp [dfsFromList]
| cons u us ih =>
have hu : u ∈ G.vertices := hvs u (by simp)
have h_us : ∀ x ∈ us, x ∈ G.vertices := by
intro x hx; apply hvs x; simp [hx]
simp [dfsFromList]
by_cases hwhite : s.color u = Color.white
· simp [hwhite]
rw [ih (dfsVisit G fuel u s) h_us,
dfsVisit_preserves_f_of_not_mem_vertices G hu (v := v) hv]
· simp [hwhite]
exact ih s h_us
For a vertex v ∉ G.vertices, the first DFS never sets its finish
time, so finishTime (G.dfs) v = 0.
lemma finishTime_zero_of_not_mem_vertices {v : V} (hv : v ∉ G.vertices) :
finishTime (G.dfs) v = 0 := by
have h_f_none : (G.dfs).f v = none := by
have h_init : (dfsInit (V := V)).f v = none := rfl
have h_preserve : (dfsFromList G (G.vertices.card + 1) G.vertices.toList dfsInit).f v =
(dfsInit (V := V)).f v :=
dfsFromList_preserves_f_of_not_mem_vertices G (G.vertices.card + 1)
G.vertices.toList dfsInit v hv (by
intro x hx
simpa [Finset.mem_toList] using hx)
simpa [dfs, h_init] using h_preserve
simp [finishTime, h_f_none]
If the current white vertices still appear in a finish-time-sorted list
headed by u, then u has maximum first-pass finish time among all
white vertices.
lemma white_finish_le_head_of_pairwise_order {s : DFSState V} {u : V} {us : List V}
(hp : (u :: us).Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a))
(hwhite_in : ∀ v, v ∈ G.vertices → s.color v = Color.white → v ∈ u :: us) :
∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) u := by
intro v hv_white
by_cases hvV : v ∈ G.vertices
· have hv_in_vs : v ∈ u :: us := hwhite_in v hvV hv_white
rcases List.mem_cons.mp hv_in_vs with (rfl | hv_us)
· rfl
· exact pairwise_head_max_finishTime G u us hp v hv_us
· rw [finishTime_zero_of_not_mem_vertices G hvV]
omega
After a DFS visit from u turns u black, every vertex that is
white in the output and was covered by u :: us beforehand must lie in
the tail us.
lemma white_vertices_in_tail_after_visit (H : Graph V) {fuel : Nat} {u : V}
{s s' : DFSState V} {us : List V}
(hs' : s' = dfsVisit H fuel u s)
(hu_black : s'.color u = Color.black)
(hng : ∀ v, s.color v = Color.white ∨ s.color v = Color.black)
(hwhite_in : ∀ v, v ∈ G.vertices → s.color v = Color.white → v ∈ u :: us) :
∀ v, v ∈ G.vertices → s'.color v = Color.white → v ∈ us := by
intro x hxV hx_white_s'
by_cases hx_in_us : x ∈ us
· exact hx_in_us
· have hx_white_s : s.color x = Color.white := by
by_contra hnot
have hblack_s : s.color x = Color.black := by
cases hng x with
| inl hw => exact absurd hw hnot
| inr hb => exact hb
have hblack_s' : s'.color x = Color.black := by
rw [hs']
exact dfsVisit_preserves_black H hblack_s
rw [hblack_s'] at hx_white_s'
simp at hx_white_s'
have hx_in_vs : x ∈ u :: us := hwhite_in x hxV hx_white_s
rcases List.mem_cons.mp hx_in_vs with (rfl | h)
· rw [hu_black] at hx_white_s'
simp at hx_white_s'
· exact absurd h hx_in_us
If the head of u :: us is not white, then every white vertex covered
by the list must already lie in the tail us.
lemma white_vertices_in_tail_of_head_not_white {s : DFSState V} {u : V} {us : List V}
(hu_not_white : s.color u ≠ Color.white)
(hwhite_in : ∀ v, v ∈ G.vertices → s.color v = Color.white → v ∈ u :: us) :
∀ v, v ∈ G.vertices → s.color v = Color.white → v ∈ us := by
intro x hxV hx
have hx_in_vs : x ∈ u :: us := hwhite_in x hxV hx
rcases List.mem_cons.mp hx_in_vs with (rfl | hx_us)
· exact absurd hx hu_not_white
· exact hx_usIn Kosaraju's second pass, a white SCC disjoint from the SCC being visited stays white.
lemma kosaraju_visit_preserves_disjoint_white_scc {s : DFSState V} {u : V} {K : Set V}
(hu : u ∈ G.transpose.vertices) (hu_white : s.color u = Color.white)
(hK : G.IsSCC K) (hK_white : ∀ v ∈ K, s.color v = Color.white)
(hK_ne : K ≠ G.sccOf u)
(hmax : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) u)
(hrespects : G.SCCMonochrome s) :
∀ v ∈ K, (dfsVisit G.transpose (G.vertices.card + 1) u s).color v = Color.white := by
intro v hvK
have h_disjoint : Disjoint K (G.sccOf u) :=
(IsSCC_eq_or_disjoint G hK (isSCC_sccOf G (by simpa using hu))).resolve_left hK_ne
have hv_not_scc : v ∉ G.sccOf u :=
(Set.disjoint_left.mp h_disjoint) hvK
have hv_not_wr : v ∉ whiteReachableSet G.transpose s u := by
intro hwr; apply hv_not_scc
exact whiteReachableSet_subset_scc G hu hu_white hmax hrespects hwr
have hno_wr : ¬ WhiteReachable G.transpose s u v := by
intro hwr
exact hv_not_wr (WhiteReachable.mem_set G.transpose hu hwr)
exact dfsVisit_preserves_white_of_not_whiteReachable G.transpose hu_white (by omega)
(hK_white v hvK) hno_wrA white-started visit in Kosaraju's second pass preserves the invariant that each SCC is monochromatic in the current DFS state.
lemma kosaraju_visit_preserves_scc_monochrome {s : DFSState V} {u : V}
(hu : u ∈ G.transpose.vertices) (hu_white : s.color u = Color.white)
(hmax : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) u)
(hrespects : G.SCCMonochrome s) :
G.SCCMonochrome (dfsVisit G.transpose (G.vertices.card + 1) u s) := by
have h_sccOf_u_white : ∀ v ∈ G.sccOf u, s.color v = Color.white := by
exact sccOf_white_of_monochrome G (by simpa using hu) hu_white hrespects
intro K hK
rcases hrespects K hK with (hw | hb)
· by_cases hK_eq : K = G.sccOf u
· right
intro v hv
have hfuel : G.vertices.card + 1 ≥ G.transpose.vertices.card + 1 := by simp
exact dfsVisit_transpose_blackens_sccOf G hu hu_white hfuel h_sccOf_u_white
(by simpa [hK_eq] using hv)
· left
exact kosaraju_visit_preserves_disjoint_white_scc G hu hu_white hK hw hK_eq hmax hrespects
· right; intro v hv; exact dfsVisit_preserves_black G.transpose (hb v hv)A white head in Kosaraju's second-pass order advances the SCC induction invariant after collecting the component discovered by that visit.
lemma kosaraju_scc_invariant_after_white_head {fuel : Nat} (hfuel_eq : fuel = G.vertices.card + 1)
(hfuel : fuel ≥ G.transpose.vertices.card + 1) (hfuel_pos : 0 < fuel)
{u : V} {us : List V} {s : DFSState V} {acc : List (Finset V)}
(hp_vs : (u :: us).Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a))
(hu_vert : u ∈ G.transpose.vertices) (hu_white : s.color u = Color.white)
(hinv : G.KosarajuSCCInvariant (u :: us) s acc) :
let s' := dfsVisit G.transpose fuel u s
let comp := G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black)
G.KosarajuSCCInvariant us s' (comp :: acc) := by
intro s' comp
have hmax_u : ∀ v, s.color v = Color.white → finishTime (G.dfs) v ≤ finishTime (G.dfs) u :=
white_finish_le_head_of_pairwise_order G hp_vs hinv.white_in_vs
have h_comp_scc : G.IsSCC (comp : Set V) :=
scc_finish_order hu_vert hu_white hmax_u hfuel hinv.scc_monochrome
have hu_black_s' : s'.color u = Color.black := by
simpa [s'] using dfsVisit_blackens_u_pos G.transpose hfuel_pos hu_white
have h_white_in_us : ∀ v, v ∈ G.vertices → s'.color v = Color.white → v ∈ us :=
white_vertices_in_tail_after_visit G G.transpose rfl hu_black_s'
hinv.no_gray hinv.white_in_vs
have h_respects' : G.SCCMonochrome s' := by
simpa [s', hfuel_eq] using
kosaraju_visit_preserves_scc_monochrome G hu_vert hu_white hmax_u hinv.scc_monochrome
have h_ng' : ∀ v, s'.color v = Color.white ∨ s'.color v = Color.black :=
dfsVisit_output_no_gray G.transpose hinv.no_gray
have h_mem : ∀ C' ∈ (comp :: acc), G.IsSCC (C' : Set V) := by
intro C' hC'
rcases List.mem_cons.mp hC' with (rfl | hC'_acc)
· exact h_comp_scc
· exact hinv.acc_scc C' hC'_acc
exact {
acc_scc := h_mem
white_in_vs := h_white_in_us
scc_monochrome := h_respects'
no_gray := h_ng'
}A non-white head in Kosaraju's second-pass order can be skipped while preserving the SCC induction invariant on the tail.
lemma kosaraju_scc_invariant_after_nonwhite_head {u : V} {us : List V}
{s : DFSState V} {acc : List (Finset V)}
(hu_not_white : s.color u ≠ Color.white)
(hinv : G.KosarajuSCCInvariant (u :: us) s acc) :
G.KosarajuSCCInvariant us s acc := by
exact {
acc_scc := hinv.acc_scc
white_in_vs := white_vertices_in_tail_of_head_not_white G hu_not_white hinv.white_in_vs
scc_monochrome := hinv.scc_monochrome
no_gray := hinv.no_gray
}The SCC-specific induction for Kosaraju's second pass.
If the remaining roots are in non-increasing first-pass finish-time order and
the SCC invariant holds for the current state, then every component collected
from this suffix is an SCC of G.
lemma dfsFromListCollect_kosaraju_sccs {fuel : Nat} (hfuel_eq : fuel = G.vertices.card + 1)
(vs : List V) (s : DFSState V) (acc : List (Finset V))
(hp_vs : vs.Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a))
(hvs_verts : ∀ v ∈ vs, v ∈ G.transpose.vertices)
(hinv : G.KosarajuSCCInvariant vs s acc) :
let (acc', _) := dfsFromListCollect G.transpose fuel vs s acc
∀ C ∈ acc', G.IsSCC (C : Set V) := by
have hfuel : fuel ≥ G.transpose.vertices.card + 1 := by
rw [hfuel_eq]
simp
have hfuel_pos : 0 < fuel := by
rw [hfuel_eq]
omega
induction vs generalizing s acc with
| nil => simp [dfsFromListCollect]; exact hinv.acc_scc
| cons u us ih =>
simp [dfsFromListCollect]
rcases List.pairwise_cons.mp hp_vs with ⟨h_u_head, hp_us⟩
have hu_vert : u ∈ G.transpose.vertices := hvs_verts u (by simp)
have h_us_verts : ∀ v ∈ us, v ∈ G.transpose.vertices := by
intro v hv; apply hvs_verts v; simp [hv]
by_cases hu_white : s.color u = Color.white
· let s' := dfsVisit G.transpose fuel u s
let comp := G.vertices.filter (fun v => s.color v = Color.white ∧ s'.color v = Color.black)
have hinv' : G.KosarajuSCCInvariant us s' (comp :: acc) := by
simpa [s', comp] using
kosaraju_scc_invariant_after_white_head G hfuel_eq hfuel hfuel_pos hp_vs
hu_vert hu_white hinv
have h_ih := ih s' (comp :: acc) hp_us h_us_verts hinv'
simpa [s', comp, dfsFromListCollect, hu_white] using h_ih
· have hinv' : G.KosarajuSCCInvariant us s acc :=
kosaraju_scc_invariant_after_nonwhite_head G hu_white hinv
have h_ih := ih s acc hp_us h_us_verts hinv'
simpa [dfsFromListCollect, hu_white] using h_ihSCC correctness core
Core DFS-theoretic lemma: every component returned by
Graph.kosarajuComponents is an SCC of G.
The proof applies Graph.scc_finish_order at each step of the second DFS
pass. The first white vertex in decreasing finish-time order is maximal among
the currently white vertices, so its transpose DFS tree is exactly its SCC.
theorem kosarajuComponent_scc_core (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) :
G.IsSCC (C : Set V) := by
-- 1. Setup
simp [kosarajuComponents] at hC
let order := G.vertices.toList.mergeSort (finishLe (G.dfs))
let fuel := G.vertices.card + 1
have h_order_verts : ∀ v, v ∈ order → v ∈ G.transpose.vertices := by
exact kosaraju_order_subset_vertices G
have h_pairwise_le : order.Pairwise (fun a b => finishTime (G.dfs) b ≤ finishTime (G.dfs) a) := by
simpa [order] using kosaraju_order_pairwise_finish_le G
-- Apply the second-pass induction to the initial state.
have h_init_invariant : G.KosarajuSCCInvariant order dfsInit ([] : List (Finset V)) := by
simpa [order] using kosaraju_initial_scc_invariant G
have h_all_sccs := dfsFromListCollect_kosaraju_sccs G (fuel := fuel) (by rfl) order dfsInit []
h_pairwise_le h_order_verts h_init_invariant
exact h_all_sccs C (by simpa [fuel] using hC)
The components returned by Graph.kosarajuComponents are exactly the
strongly connected components of G.
The DFS finish-time argument needed for SCC-ness is isolated in
Graph.kosarajuComponent_scc_core.
theorem kosarajuComponents_eq_sccs (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) :
G.IsSCC (C : Set V) :=
kosarajuComponent_scc_core G C hCVertices in the same component returned by Kosaraju's algorithm are strongly connected.
theorem kosarajuComponents_stronglyConnected (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) :
∀ u ∈ C, ∀ v ∈ C, G.StronglyConnected u v :=
(kosarajuComponents_eq_sccs G C hC).stronglyConnectedA component returned by Kosaraju's algorithm cannot be enlarged by any outside vertex while preserving strong connectivity with the component.
theorem kosarajuComponents_not_stronglyConnected_outside (G : Graph V) (C : Finset V)
(hC : C ∈ G.kosarajuComponents) :
∀ w ∈ G.vertices \ C, ¬ (∀ u ∈ C, G.StronglyConnected u w) := by
intro w hw hsc
simp at hw
exact hw.2 (IsSCC.maximal G (kosarajuComponents_eq_sccs G C hC) w hw.1
(fun u hu => hsc u hu))
Every vertex of G belongs to a unique component returned by
Kosaraju's algorithm.
theorem kosarajuComponents_exists_unique (G : Graph V) :
∀ v ∈ G.vertices, ∃! C ∈ G.kosarajuComponents, v ∈ C := by
intro v hv
have ⟨C, hC, hvC⟩ := kosarajuComponents_cover G v hv
use C
constructor
· exact ⟨hC, hvC⟩
· intro D hD
exact unique_mem_of_pairwise_disjoint_cover
(kosarajuComponents_pairwise_disjoint G)
hD.1 hC ⟨v, hD.2, hvC⟩
Graph.kosarajuComponents is a valid SCC partition of G.
theorem kosarajuComponents_isSCCPartition (G : Graph V) :
G.IsSCCPartition G.kosarajuComponents := by
exact ⟨kosarajuComponents_subset G, kosarajuComponents_nonempty G,
kosarajuComponents_stronglyConnected G, kosarajuComponents_not_stronglyConnected_outside G,
kosarajuComponents_exists_unique G⟩end Graphend Chapter22end CLRSDefinitions and proofs
CLRSLean.FourthEdition.Chapter_20.Section_20_5_Strongly_Connected_Components.MergeSortCongr
MergeSort congruence lemma: if two comparisons agree on all pairs from a list, mergeSort produces the same output with either.
The main lemma is mergeSort_congr.
namespace CLRSnamespace Chapter22namespace Graphvariable {V : Type}private lemma splitInTwo_fst_subset {α : Type} {n : Nat} (l : {l : List α // l.length = n}) :
((List.MergeSort.Internal.splitInTwo l).1 : List α) ⊆ (l : List α) := by
intro x hx
simp [List.MergeSort.Internal.splitInTwo, List.splitAt_eq] at hx ⊢
exact List.mem_of_mem_take hxprivate lemma splitInTwo_snd_subset {α : Type} {n : Nat} (l : {l : List α // l.length = n}) :
((List.MergeSort.Internal.splitInTwo l).2 : List α) ⊆ (l : List α) := by
intro x hx
simp [List.MergeSort.Internal.splitInTwo, List.splitAt_eq] at hx ⊢
exact List.mem_of_mem_drop hx
If two comparisons agree on all elements of l₁ cross l₂,
then merge l₁ l₂ produces the same result with either comparison.
lemma merge_congr (le₁ le₂ : V → V → Bool) (l₁ l₂ : List V)
(h : ∀ a ∈ l₁, ∀ b ∈ l₂, le₁ a b = le₂ a b) :
List.merge l₁ l₂ le₁ = List.merge l₁ l₂ le₂ := by
induction l₁ generalizing l₂ with
| nil => simp
| cons a as ih =>
induction l₂ with
| nil => simp
| cons b bs ih' =>
simp [List.merge]
rw [h a (by simp) b (by simp)]
split
· rw [ih (b :: bs) (fun x hx y hy =>
h x (List.mem_cons_of_mem a hx) y hy)]
· rw [ih' (fun x hx y hy =>
h x hx y (List.mem_cons_of_mem b hy))]
If two comparison functions le₁ and le₂ agree on all pairs of
elements in a list l, then l.mergeSort le₁ = l.mergeSort le₂.
lemma mergeSort_congr (le₁ le₂ : V → V → Bool) (l : List V)
(h : ∀ a ∈ l, ∀ b ∈ l, le₁ a b = le₂ a b) :
l.mergeSort le₁ = l.mergeSort le₂ := by
rw [List.mergeSort.eq_def, List.mergeSort.eq_def]
match l with
| [] => rfl
| [_] => rfl
| a :: b :: xs =>
let l' : {l : List V // l.length = (a :: b :: xs).length} := ⟨a :: b :: xs, rfl⟩
let lr := List.MergeSort.Internal.splitInTwo l'
have hleft :
((lr.1 : List V).mergeSort le₁) = ((lr.1 : List V).mergeSort le₂) := by
apply mergeSort_congr
intro x hx y hy
exact h x (splitInTwo_fst_subset l' hx) y (splitInTwo_fst_subset l' hy)
have hright :
((lr.2 : List V).mergeSort le₁) = ((lr.2 : List V).mergeSort le₂) := by
apply mergeSort_congr
intro x hx y hy
exact h x (splitInTwo_snd_subset l' hx) y (splitInTwo_snd_subset l' hy)
have hcross : ∀ x ∈ (lr.1 : List V).mergeSort le₂,
∀ y ∈ (lr.2 : List V).mergeSort le₂, le₁ x y = le₂ x y := by
intro x hx y hy
have hx' : x ∈ (lr.1 : List V) := (List.mergeSort_perm (lr.1 : List V) le₂).mem_iff.mp hx
have hy' : y ∈ (lr.2 : List V) := (List.mergeSort_perm (lr.2 : List V) le₂).mem_iff.mp hy
exact h x (splitInTwo_fst_subset l' hx') y (splitInTwo_snd_subset l' hy')
change
((lr.1 : List V).mergeSort le₁).merge ((lr.2 : List V).mergeSort le₁) le₁ =
((lr.1 : List V).mergeSort le₂).merge ((lr.2 : List V).mergeSort le₂) le₂
rw [hleft, hright]
exact merge_congr le₁ le₂ ((lr.1 : List V).mergeSort le₂)
((lr.2 : List V).mergeSort le₂) hcross
termination_by l.length
decreasing_by
simp_wf
all_goals
try simp [List.MergeSort.Internal.splitInTwo, List.splitAt_eq]
omegaend Graphend Chapter22end CLRSCLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS
One DFS tree visit from a white source vertex u.
noncomputable def dfsVisit (fuel : Nat) (u : V) (s : DFSState V) : DFSState V :=
match fuel with
| 0 => s
| fuel + 1 =>
if s.color u = Color.white then
let s := s.setColor u Color.gray |>.setDiscovery u
let s := (G.adj u).toList.foldl (fun s' v =>
if s'.color v = Color.white then dfsVisit fuel v (s'.setParent v u) else s') s
s.setColor u Color.black |>.setFinish u
else
sRecursive DFS over a list of starting vertices.
noncomputable def dfsFromList (fuel : Nat) : List V → DFSState V → DFSState V
| [], s => s
| u :: us, s =>
let s' := if s.color u = Color.white then dfsVisit G fuel u s else s
dfsFromList fuel us s'Scope and implementation notes
Imports
import CLRSLean.Chapter_22
import CLRSLean.FourthEdition.Chapter_20.Section_20_1_Representing_Graphs
import CLRSLean.FourthEdition.Chapter_20.Section_20_2_BFS
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.Cost
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S1_WhitePath
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S2_Intervals
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S3_Bridge
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S4_SCC
import CLRSLean.FourthEdition.Chapter_20.Section_20_3_DFS.S5_EdgeClassification
import CLRSLean.FourthEdition.Chapter_20.Section_20_4_Topological_Sort
import CLRSLean.FourthEdition.Chapter_20.Section_20_5_Strongly_Connected_Components
import CLRSLean.FourthEdition.Chapter_20.Section_20_5_Strongly_Connected_Components.MergeSortCongrCurrent source
Sections 20.1--20.5 are native fourth-edition sections (representing
graphs, breadth-first search, depth-first search with its nested
white-path/intervals/bridge/SCC/edge-classification developments,
topological sort, and strongly connected components), imported directly
from
Section 20.1,
Section 20.2,
Section 20.3,
Section 20.4,
and
Section 20.5.
Declarations retain the legacy CLRS.Chapter22 namespace during the
compatibility period; the third-edition-numbered imports
CLRSLean.Chapter_22 and CLRSLean.Chapter_22.Section_22_* forward
to these sources.
Implementation details
The supporting implementation pages remain available outside the main sidebar:
Coverage boundary
The native sections supply all represented fourth-edition elementary-graph
sections. The namespace migration CLRS.Chapter22 → CLRS.Chapter20 is
tracked chapter by chapter.
BFS and DFS have counters attached to their represented traversal executions.
Topological sorting and SCC instead prove order/partition correctness and use
List.mergeSort on finish times. Its additional comparisons and ordering
work are not included in the DFS V + E controller count. No complete
linear-time execution theorem for these merge-sorted entry points is claimed.
See docs/clrs-fourth-edition-map.csv for the section-level mapping and
docs/migrations/clrs4.md for compatibility and deprecation policy.
CLRS, fourth edition · Chapter 20 of 35