Imports
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 CLRS