From 9c8dfb90fab481657d777c71c7440fdb66814d1b Mon Sep 17 00:00:00 2001 From: lyphyser <98273206+lyphyser@users.noreply.github.com> Date: Sat, 14 Sep 2024 18:54:01 +0200 Subject: [PATCH 01/54] Change qsort to use proven in-bounds accesses --- src/Init/Data/Array/QSort.lean | 134 +++++++++++++++++++++++++++------ 1 file changed, 112 insertions(+), 22 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 1f71a07bb492..5248cdf835b0 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -7,41 +7,131 @@ prelude import Init.Data.Array.Basic namespace Array --- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget def qpartition (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × Array α := - if h : as.size = 0 then (0, as) else have : Inhabited α := ⟨as[0]'(by revert h; cases as.size <;> simp)⟩ -- TODO: remove + let s := as.size + have hs: as.size = s := rfl + + let hi := if hi < s then hi else s - 1 + + if hlh: lo ≥ hi then (lo, as) else + have hlh: lo < hi := Nat.gt_of_not_le hlh + + have h0s: s ≠ 0 := by + dsimp only [hi] at hlh + split at hlh + case isTrue h => + exact Nat.not_eq_zero_of_lt h + case isFalse h => + apply Nat.ne_of_gt + apply Nat.zero_lt_of_lt + exact Nat.add_lt_of_lt_sub hlh + + have hhs: hi < s := by + dsimp only [hi] + split + · assumption + · apply Nat.sub_one_lt + exact h0s + + -- we need this since otherwise loop doesn't capture hi, but rather what it unfolds to + have ⟨hi, hlh, hhs⟩: (hi: Nat) ×' (lo < hi) ×' (hi < s) := ⟨hi, hlh, hhs⟩ + + have hls: lo < s := Nat.lt_trans hlh hhs + let mid := (lo + hi) / 2 - let as := if lt (as.get! mid) (as.get! lo) then as.swap! lo mid else as - let as := if lt (as.get! hi) (as.get! lo) then as.swap! lo hi else as - let as := if lt (as.get! mid) (as.get! hi) then as.swap! mid hi else as - let pivot := as.get! hi - let rec loop (as : Array α) (i j : Nat) := - if h : j < hi then - if lt (as.get! j) pivot then - let as := as.swap! i j - loop as (i+1) (j+1) + + have hms: mid < s := by + apply Nat.div_lt_of_lt_mul + rw [Nat.two_mul] + exact Nat.add_lt_add hls hhs + + let b := lt as[mid] as[lo] + let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + + -- we need let b since otherwise the split tactic fails + let b := lt as[hi] as[lo] + let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨hi, hs ▸ hhs⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + + let b := lt as[mid] as[hi] + let as := if b then as.swap ⟨mid, hs ▸ hms⟩ ⟨hi, hs ▸ hhs⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + + let pivot := as[hi] + + let rec loop (as : Array α) (i j : Nat) (hij: i ≤ j) (hjh: j ≤ hi) (hhs: hi < as.size):= + let s := as.size + have hs: as.size = s := rfl + + have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) + + if hjh : j < hi then + have hjs: j < s := Nat.lt_trans hjh hhs + + if lt as[j] pivot then + let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ + have hs: as.size = s := by simp_all only [as, Array.size_swap] + + have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 + + loop as (i+1) (j+1) hij hjh (hs ▸ hhs) else - loop as i (j+1) + have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij + + loop as i (j+1) hij hjh (hs ▸ hhs) else - let as := as.swap! i hi + let as := as.swap ⟨i, hs ▸ his⟩ ⟨hi, hs ▸ hhs⟩ (i, as) - termination_by hi - j - decreasing_by all_goals simp_wf; decreasing_trivial_pre_omega - loop as lo lo -@[inline] partial def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := + have hlh: lo ≤ hi := Nat.le_of_succ_le hlh + have hll: lo ≤ lo := Nat.le_refl lo + + loop as lo lo hll hlh (hs ▸ hhs) + +theorem i_le_qpartition_loop_fst (lt: α → α → Bool) {hi: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} + (hij: i ≤ j) (hjh: j ≤ hi) (hhs: hi < as.size): + i ≤ (qpartition.loop lt hi pivot as i j hij hjh hhs).1 := by + unfold qpartition.loop + -- the split tactic fails + by_cases hjh: j < hi + all_goals simp only [hjh, ↓reduceDIte] + · split + · apply Nat.le_of_succ_le + apply i_le_qpartition_loop_fst + · apply i_le_qpartition_loop_fst + · apply Nat.le_refl + +theorem lo_le_qpartition_fst (as: Array α) (lt: α → α → Bool) (lo hi: Nat): + lo ≤ (qpartition as lt lo hi).1 := by + unfold qpartition + -- the split tactic fails + by_cases hlh: lo ≥ (if hi < as.size then hi else as.size - 1) + all_goals simp only [hlh, ↓reduceDIte] + · apply Nat.le_refl + · apply i_le_qpartition_loop_fst + +@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) := - if low < high then - let p := qpartition as lt low high; - -- TODO: fix `partial` support in the equation compiler, it breaks if we use `let (mid, as) := partition as lt low high` + if hlh: low < high then + let p := qpartition as lt low high let mid := p.1 let as := p.2 - if mid >= high then as + if hmh: mid >= high then as else let as := sort as low mid sort as (mid+1) high else as - sort as low high + termination_by high - low + decreasing_by + · apply Nat.sub_lt_sub_right + · apply lo_le_qpartition_fst + · exact Nat.gt_of_not_le hmh + · apply Nat.sub_lt_sub_left + · exact hlh + · apply Nat.lt_succ_of_le + apply lo_le_qpartition_fst + sort as low high end Array From 5e5aff7efb5838eeb40d86e73a7304d4b7ba02e2 Mon Sep 17 00:00:00 2001 From: lyphyser <98273206+lyphyser@users.noreply.github.com> Date: Sat, 14 Sep 2024 18:56:45 +0200 Subject: [PATCH 02/54] fix whitespace --- src/Init/Data/Array/QSort.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 5248cdf835b0..50f8cf48448e 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -52,7 +52,7 @@ def qpartition (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × -- we need let b since otherwise the split tactic fails let b := lt as[hi] as[lo] - let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨hi, hs ▸ hhs⟩ else as + let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨hi, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] let b := lt as[mid] as[hi] From aaa369d7e0f57ebfb1fa776eccbfb0870a75086c Mon Sep 17 00:00:00 2001 From: lyphyser <98273206+lyphyser@users.noreply.github.com> Date: Sat, 14 Sep 2024 20:40:02 +0200 Subject: [PATCH 03/54] replace by_cases with dsimp only + split --- src/Init/Data/Array/QSort.lean | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 50f8cf48448e..07cebb32456b 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -94,9 +94,8 @@ theorem i_le_qpartition_loop_fst (lt: α → α → Bool) {hi: Nat} (pivot: α) (hij: i ≤ j) (hjh: j ≤ hi) (hhs: hi < as.size): i ≤ (qpartition.loop lt hi pivot as i j hij hjh hhs).1 := by unfold qpartition.loop - -- the split tactic fails - by_cases hjh: j < hi - all_goals simp only [hjh, ↓reduceDIte] + dsimp only + split · split · apply Nat.le_of_succ_le apply i_le_qpartition_loop_fst @@ -106,11 +105,12 @@ theorem i_le_qpartition_loop_fst (lt: α → α → Bool) {hi: Nat} (pivot: α) theorem lo_le_qpartition_fst (as: Array α) (lt: α → α → Bool) (lo hi: Nat): lo ≤ (qpartition as lt lo hi).1 := by unfold qpartition - -- the split tactic fails - by_cases hlh: lo ≥ (if hi < as.size then hi else as.size - 1) - all_goals simp only [hlh, ↓reduceDIte] - · apply Nat.le_refl - · apply i_le_qpartition_loop_fst + dsimp only + split + all_goals + split + · apply Nat.le_refl + · apply i_le_qpartition_loop_fst @[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) := From 9b91779fa95f0ebe0633b51cfaa2ec7fc681ee0e Mon Sep 17 00:00:00 2001 From: lyphyser <98273206+lyphyser@users.noreply.github.com> Date: Sat, 14 Sep 2024 20:48:27 +0200 Subject: [PATCH 04/54] import tactics --- src/Init/Data/Array/QSort.lean | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 07cebb32456b..a92bc4146e2e 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -5,6 +5,7 @@ Authors: Leonardo de Moura -/ prelude import Init.Data.Array.Basic +import Init.Tactics namespace Array From 3c06e7fed8040370bc227ea20aa5556244d79c50 Mon Sep 17 00:00:00 2001 From: lyphyser <98273206+lyphyser@users.noreply.github.com> Date: Sat, 14 Sep 2024 22:38:16 +0200 Subject: [PATCH 05/54] correct imports so that it builds in Init/ --- src/Init/Data/Array/QSort.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index a92bc4146e2e..94889783cd47 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -5,7 +5,7 @@ Authors: Leonardo de Moura -/ prelude import Init.Data.Array.Basic -import Init.Tactics +import Init.Data.Nat.Mod namespace Array From b518d33761b2ff5d7952675e3947b25869cc776c Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sat, 14 Sep 2024 22:31:05 +0000 Subject: [PATCH 06/54] minor change qsort API to provide bounds as hypotheses Only breaks users if they specify bounds explicitly and omega can't solve the goals automatically. --- src/Init/Data/Array/Basic.lean | 8 ++ src/Init/Data/Array/QSort.lean | 172 ++++++++++++++++++++------------- 2 files changed, 111 insertions(+), 69 deletions(-) diff --git a/src/Init/Data/Array/Basic.lean b/src/Init/Data/Array/Basic.lean index 5ed4c9ffd5d1..0b78d5f5962d 100644 --- a/src/Init/Data/Array/Basic.lean +++ b/src/Init/Data/Array/Basic.lean @@ -685,6 +685,14 @@ def indexOf? [BEq α] (a : Array α) (v : α) : Option (Fin a.size) := | ⟨[]⟩ => rfl | ⟨a::as⟩ => simp [pop, Nat.succ_sub_succ_eq_sub, size] +@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): (if P then a else b).size = (if P then a.size else b.size) := by + split + all_goals rfl + +@[simp] theorem size_dite (P: Prop) [Decidable P] (a: P → Array α) (b: ¬P → Array α): (if h: P then a h else b h).size = (if h: P then (a h).size else (b h).size) := by + split + all_goals rfl + theorem reverse.termination {i j : Nat} (h : i < j) : j - 1 - (i + 1) < j - i := by rw [Nat.sub_sub, Nat.add_comm] exact Nat.lt_of_le_of_lt (Nat.pred_le _) (Nat.sub_succ_lt_self _ _ h) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 94889783cd47..1f91e8596910 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -9,69 +9,41 @@ import Init.Data.Nat.Mod namespace Array -def qpartition (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × Array α := +@[specialize] def qpartition (as : Array α) (lt : α → α → Bool) (low high : Nat) + (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega): Nat × Array α := let s := as.size have hs: as.size = s := rfl - let hi := if hi < s then hi else s - 1 + have hls: low < s := Nat.lt_of_le_of_lt hlh hhs - if hlh: lo ≥ hi then (lo, as) else - have hlh: lo < hi := Nat.gt_of_not_le hlh - - have h0s: s ≠ 0 := by - dsimp only [hi] at hlh - split at hlh - case isTrue h => - exact Nat.not_eq_zero_of_lt h - case isFalse h => - apply Nat.ne_of_gt - apply Nat.zero_lt_of_lt - exact Nat.add_lt_of_lt_sub hlh - - have hhs: hi < s := by - dsimp only [hi] - split - · assumption - · apply Nat.sub_one_lt - exact h0s - - -- we need this since otherwise loop doesn't capture hi, but rather what it unfolds to - have ⟨hi, hlh, hhs⟩: (hi: Nat) ×' (lo < hi) ×' (hi < s) := ⟨hi, hlh, hhs⟩ - - have hls: lo < s := Nat.lt_trans hlh hhs - - let mid := (lo + hi) / 2 + let mid := (low + high) / 2 have hms: mid < s := by apply Nat.div_lt_of_lt_mul rw [Nat.two_mul] exact Nat.add_lt_add hls hhs - let b := lt as[mid] as[lo] - let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as + let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - -- we need let b since otherwise the split tactic fails - let b := lt as[hi] as[lo] - let as := if b then as.swap ⟨lo, hs ▸ hls⟩ ⟨hi, hs ▸ hhs⟩ else as + let as := if lt (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let b := lt as[mid] as[hi] - let as := if b then as.swap ⟨mid, hs ▸ hms⟩ ⟨hi, hs ▸ hhs⟩ else as + let as := if lt (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let pivot := as[hi] + let pivot := as[high]'(hs ▸ hhs) - let rec loop (as : Array α) (i j : Nat) (hij: i ≤ j) (hjh: j ≤ hi) (hhs: hi < as.size):= + let rec @[specialize] loop (as : Array α) (i j : Nat) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size):= let s := as.size have hs: as.size = s := rfl have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) - if hjh : j < hi then + if hjh : j < high then have hjs: j < s := Nat.lt_trans hjh hhs - if lt as[j] pivot then + if lt (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] @@ -83,56 +55,118 @@ def qpartition (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × loop as i (j+1) hij hjh (hs ▸ hhs) else - let as := as.swap ⟨i, hs ▸ his⟩ ⟨hi, hs ▸ hhs⟩ + let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ (i, as) - have hlh: lo ≤ hi := Nat.le_of_succ_le hlh - have hll: lo ≤ lo := Nat.le_refl lo + have hll: low ≤ low := Nat.le_refl low - loop as lo lo hll hlh (hs ▸ hhs) + loop as low low hll hlh (hs ▸ hhs) -theorem i_le_qpartition_loop_fst (lt: α → α → Bool) {hi: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} - (hij: i ≤ j) (hjh: j ≤ hi) (hhs: hi < as.size): - i ≤ (qpartition.loop lt hi pivot as i j hij hjh hhs).1 := by +theorem i_le_fst_qpartition_loop (lt: α → α → Bool) {high: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} + (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): + i ≤ (qpartition.loop lt high pivot as i j hij hjh hhs).1 := by unfold qpartition.loop dsimp only split · split · apply Nat.le_of_succ_le - apply i_le_qpartition_loop_fst - · apply i_le_qpartition_loop_fst + apply i_le_fst_qpartition_loop + · apply i_le_fst_qpartition_loop · apply Nat.le_refl -theorem lo_le_qpartition_fst (as: Array α) (lt: α → α → Bool) (lo hi: Nat): - lo ≤ (qpartition as lt lo hi).1 := by - unfold qpartition +theorem fst_qpartition_loop_le_high (lt: α → α → Bool) (high: Nat) (pivot: α) (as: Array α) (i: Nat) (j: Nat) + (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): + (qpartition.loop lt high pivot as i j hij hjh hhs).1 ≤ high := by + unfold qpartition.loop + dsimp only + split + · split + · apply fst_qpartition_loop_le_high + · apply fst_qpartition_loop_le_high + · exact Nat.le_trans hij hjh + +theorem size_snd_qpartition_loop (lt: α → α → Bool) {high: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} + (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): + (qpartition.loop lt high pivot as i j hij hjh hhs).2.size = as.size := by + unfold qpartition.loop dsimp only split - all_goals - split - · apply Nat.le_refl - · apply i_le_qpartition_loop_fst - -@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := - let rec @[specialize] sort (as : Array α) (low high : Nat) := - if hlh: low < high then - let p := qpartition as lt low high + · split + · rw [size_snd_qpartition_loop] + apply size_swap + · apply size_snd_qpartition_loop + · apply size_swap + +theorem low_le_fst_qpartition (as: Array α) (lt: α → α → Bool) (low high: Nat) + (hlh: low ≤ high) (hhs: high < as.size): + low ≤ (qpartition as lt low high hlh hhs).1 := by + apply i_le_fst_qpartition_loop + +theorem fst_qpartition_le_high (as: Array α) (lt: α → α → Bool) (low high: Nat) + (hlh: low ≤ high) (hhs: high < as.size): + (qpartition as lt low high hlh hhs).1 ≤ high := by + apply fst_qpartition_loop_le_high + +@[simp] theorem size_snd_qpartition (as: Array α) (lt: α → α → Bool) (low high: Nat) + (hlh: low ≤ high) (hhs: high < as.size): + (qpartition as lt low high hlh hhs).2.size = as.size := by + simp only [qpartition, size_snd_qpartition_loop, size_ite, size_swap, ite_self] + +@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) : Array α := + + let rec @[specialize] sort (as : Array α) (low high : Nat) + (hlh: low ≤ high) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := + let s := as.size + have hs: as.size = s := rfl + if hlh': low < high then + have hhs := hhs hlh' + + let p := qpartition as lt low high hlh (hs ▸ hhs) let mid := p.1 let as := p.2 - if hmh: mid >= high then as + have hs: as.size = s := by + simp only [as, p, size_snd_qpartition, hs] + + if hmh: mid >= high then ⟨as, hs⟩ else - let as := sort as low mid - sort as (mid+1) high - else as + have hms: mid < s := by + apply Nat.lt_of_le_of_lt ?_ hhs + apply fst_qpartition_le_high + + have hlm: low ≤ mid := by + apply low_le_fst_qpartition + + have hmh: mid + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh) + + let ⟨as, hs'⟩ := sort as low mid hlm (λ _ ↦ hs ▸ hms) + have hs: as.size = s := by rw [← hs, hs'] + + let ⟨as, hs'⟩ := sort as (mid+1) high hmh (λ _ ↦ hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] + + ⟨as, hs⟩ + else ⟨as, hs⟩ termination_by high - low decreasing_by · apply Nat.sub_lt_sub_right - · apply lo_le_qpartition_fst - · exact Nat.gt_of_not_le hmh + · apply low_le_fst_qpartition + · exact hmh · apply Nat.sub_lt_sub_left - · exact hlh + · exact hlh' · apply Nat.lt_succ_of_le - apply lo_le_qpartition_fst + apply low_le_fst_qpartition + + (sort as low high hlh hhs).1 + +@[simp] +theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): + (qsort as lt low high hlh hhs).size = as.size := by + unfold qsort + exact (qsort.sort lt as low high hlh hhs).2 + +def qsort_nats (as : Array Nat) := + qsort as (· < · ) - sort as low high end Array From 8702e68576d5e27283c1d71b4a9da7b2579afbac Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 00:02:30 +0000 Subject: [PATCH 07/54] make qpartition take a function and call it instead of returning a pair Returning a pair unfortunately result in a heap allocation, while a specialized function call doesn't. However, this unfortunately seems to result in code duplication, so the next commit will completely remove qpartition and inline it into qsort, which fixes that. --- src/Init/Data/Array/QSort.lean | 122 +++++++++------------------------ 1 file changed, 32 insertions(+), 90 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 1f91e8596910..1b6c3212f570 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -9,8 +9,8 @@ import Init.Data.Nat.Mod namespace Array -@[specialize] def qpartition (as : Array α) (lt : α → α → Bool) (low high : Nat) - (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega): Nat × Array α := +@[specialize] def qpartition' (as : Array α) (lt : α → α → Bool) (low high : Nat) + (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega) (f: (as': Array α) → as'.size = as.size → (p: Nat) → low ≤ p → p ≤ high → β): β := let s := as.size have hs: as.size = s := rfl @@ -34,83 +34,39 @@ namespace Array let pivot := as[high]'(hs ▸ hhs) - let rec @[specialize] loop (as : Array α) (i j : Nat) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size):= - let s := as.size - have hs: as.size = s := rfl - + let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < s) (hs: as.size = s):= have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) - if hjh : j < high then - have hjs: j < s := Nat.lt_trans hjh hhs + if hjh' : j < high then + have hjs: j < s := Nat.lt_trans hjh' hhs if lt (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 + have hli: low ≤ i + 1 := Nat.le_add_right_of_le hli - loop as (i+1) (j+1) hij hjh (hs ▸ hhs) + loop as (i+1) (j+1) hli hij hjh' (hs ▸ hhs) hs else have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij - loop as i (j+1) hij hjh (hs ▸ hhs) + loop as i (j+1) hli hij hjh' (hs ▸ hhs) hs else let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ - (i, as) + have hs: as.size = s := by simp_all only [as, Array.size_swap] + + have hih: i ≤ high := Nat.le_trans hij hjh + + f as hs i hli hih have hll: low ≤ low := Nat.le_refl low - loop as low low hll hlh (hs ▸ hhs) - -theorem i_le_fst_qpartition_loop (lt: α → α → Bool) {high: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} - (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): - i ≤ (qpartition.loop lt high pivot as i j hij hjh hhs).1 := by - unfold qpartition.loop - dsimp only - split - · split - · apply Nat.le_of_succ_le - apply i_le_fst_qpartition_loop - · apply i_le_fst_qpartition_loop - · apply Nat.le_refl - -theorem fst_qpartition_loop_le_high (lt: α → α → Bool) (high: Nat) (pivot: α) (as: Array α) (i: Nat) (j: Nat) - (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): - (qpartition.loop lt high pivot as i j hij hjh hhs).1 ≤ high := by - unfold qpartition.loop - dsimp only - split - · split - · apply fst_qpartition_loop_le_high - · apply fst_qpartition_loop_le_high - · exact Nat.le_trans hij hjh - -theorem size_snd_qpartition_loop (lt: α → α → Bool) {high: Nat} (pivot: α) {as: Array α} {i: Nat} {j: Nat} - (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): - (qpartition.loop lt high pivot as i j hij hjh hhs).2.size = as.size := by - unfold qpartition.loop - dsimp only - split - · split - · rw [size_snd_qpartition_loop] - apply size_swap - · apply size_snd_qpartition_loop - · apply size_swap - -theorem low_le_fst_qpartition (as: Array α) (lt: α → α → Bool) (low high: Nat) - (hlh: low ≤ high) (hhs: high < as.size): - low ≤ (qpartition as lt low high hlh hhs).1 := by - apply i_le_fst_qpartition_loop - -theorem fst_qpartition_le_high (as: Array α) (lt: α → α → Bool) (low high: Nat) - (hlh: low ≤ high) (hhs: high < as.size): - (qpartition as lt low high hlh hhs).1 ≤ high := by - apply fst_qpartition_loop_le_high - -@[simp] theorem size_snd_qpartition (as: Array α) (lt: α → α → Bool) (low high: Nat) - (hlh: low ≤ high) (hhs: high < as.size): - (qpartition as lt low high hlh hhs).2.size = as.size := by - simp only [qpartition, size_snd_qpartition_loop, size_ite, size_swap, ite_self] + loop as low low hll hll hlh hhs hs + +def qpartition (as : Array α) (lt : α → α → Bool) (low high : Nat) + (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega): Nat × Array α := + qpartition' as lt low high hlh hhs (λ as _ p _ _ ↦ (p, as)) @[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) : Array α := @@ -122,40 +78,26 @@ theorem fst_qpartition_le_high (as: Array α) (lt: α → α → Bool) (low high if hlh': low < high then have hhs := hhs hlh' - let p := qpartition as lt low high hlh (hs ▸ hhs) - let mid := p.1 - let as := p.2 - have hs: as.size = s := by - simp only [as, p, size_snd_qpartition, hs] - - if hmh: mid >= high then ⟨as, hs⟩ - else - have hms: mid < s := by - apply Nat.lt_of_le_of_lt ?_ hhs - apply fst_qpartition_le_high + qpartition' as lt low high hlh (hs ▸ hhs) λ as hs' mid hlm hmh ↦ + have hs: as.size = s := hs' - have hlm: low ≤ mid := by - apply low_le_fst_qpartition + if hmh': mid >= high then + ⟨as, hs⟩ + else + have hms: mid < s := by + apply Nat.lt_of_le_of_lt ?_ hhs + apply hmh - have hmh: mid + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh) + have hmh: mid + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh') - let ⟨as, hs'⟩ := sort as low mid hlm (λ _ ↦ hs ▸ hms) - have hs: as.size = s := by rw [← hs, hs'] + let ⟨as, hs'⟩ := sort as low mid hlm (λ _ ↦ hs ▸ hms) + have hs: as.size = s := by rw [← hs, hs'] - let ⟨as, hs'⟩ := sort as (mid+1) high hmh (λ _ ↦ hs ▸ hhs) - have hs: as.size = s := by rw [← hs, hs'] + let ⟨as, hs'⟩ := sort as (mid+1) high hmh (λ _ ↦ hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - ⟨as, hs⟩ + ⟨as, hs⟩ else ⟨as, hs⟩ - termination_by high - low - decreasing_by - · apply Nat.sub_lt_sub_right - · apply low_le_fst_qpartition - · exact hmh - · apply Nat.sub_lt_sub_left - · exact hlh' - · apply Nat.lt_succ_of_le - apply low_le_fst_qpartition (sort as low high hlh hhs).1 From 3ebba57903ce86b98f8ba91188c93362c0a1d2d0 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 00:28:58 +0000 Subject: [PATCH 08/54] inline qpartition into qsort This seems to produce the best C code, since it avoids both temporary allocations and code duplication of specialized functions --- src/Init/Data/Array/QSort.lean | 136 ++++++++++++++++----------------- 1 file changed, 68 insertions(+), 68 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 1b6c3212f570..5c446323db16 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -9,106 +9,106 @@ import Init.Data.Nat.Mod namespace Array -@[specialize] def qpartition' (as : Array α) (lt : α → α → Bool) (low high : Nat) - (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega) (f: (as': Array α) → as'.size = as.size → (p: Nat) → low ≤ p → p ≤ high → β): β := - let s := as.size - have hs: as.size = s := rfl +@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) : Array α := - have hls: low < s := Nat.lt_of_le_of_lt hlh hhs + let rec @[specialize] sort (as : Array α) (low high : Nat) + (hlh: low ≤ high) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := + let s := as.size + have hs: as.size = s := rfl + if hlh': low >= high then + ⟨as, hs⟩ + else + have hlh': low < high := Nat.gt_of_not_le hlh' + have hhs := hhs hlh' - let mid := (low + high) / 2 + let s := as.size + have hs: as.size = s := rfl - have hms: mid < s := by - apply Nat.div_lt_of_lt_mul - rw [Nat.two_mul] - exact Nat.add_lt_add hls hhs + have hls: low < s := Nat.lt_of_le_of_lt hlh hhs - let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as - have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + let i := (low + high) / 2 - let as := if lt (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as - have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + have hms: i < s := by + apply Nat.div_lt_of_lt_mul + rw [Nat.two_mul] + exact Nat.add_lt_add hls hhs - let as := if lt (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as - have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] + let as := if lt (as[i]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨i, hs ▸ hms⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let pivot := as[high]'(hs ▸ hhs) + let as := if lt (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < s) (hs: as.size = s):= - have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) + let as := if lt (as[i]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨i, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as + have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - if hjh' : j < high then - have hjs: j < s := Nat.lt_trans hjh' hhs + let pivot := as[high]'(hs ▸ hhs) - if lt (as[j]'(hs ▸ hjs)) pivot then - let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ - have hs: as.size = s := by simp_all only [as, Array.size_swap] + let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): {as': Array α // as'.size = as.size}:= + let s := as.size + have hs: as.size = s := rfl + have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) - have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 - have hli: low ≤ i + 1 := Nat.le_add_right_of_le hli + if hjh' : j < high then + have hjs: j < s := Nat.lt_trans hjh' hhs - loop as (i+1) (j+1) hli hij hjh' (hs ▸ hhs) hs - else - have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij + if lt (as[j]'(hs ▸ hjs)) pivot then + let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ + have hs: as.size = s := by simp_all only [as, Array.size_swap] - loop as i (j+1) hli hij hjh' (hs ▸ hhs) hs - else - let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ - have hs: as.size = s := by simp_all only [as, Array.size_swap] + have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 + have hli: low ≤ i + 1 := Nat.le_add_right_of_le hli - have hih: i ≤ high := Nat.le_trans hij hjh + let ⟨as, hs'⟩ := loop as (i+1) (j+1) hli hij hjh' (hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - f as hs i hli hih + ⟨as, hs⟩ + else + have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij - have hll: low ≤ low := Nat.le_refl low + let ⟨as, hs'⟩ := loop as i (j+1) hli hij hjh' (hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - loop as low low hll hll hlh hhs hs + ⟨as, hs⟩ + else + let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ + have hs: as.size = s := by simp_all only [as, Array.size_swap] -def qpartition (as : Array α) (lt : α → α → Bool) (low high : Nat) - (hlh: low ≤ high := by omega) (hhs: high < as.size := by omega): Nat × Array α := - qpartition' as lt low high hlh hhs (λ as _ p _ _ ↦ (p, as)) + have hih: i ≤ high := Nat.le_trans hij hjh -@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) : Array α := + if hmh': i >= high then + ⟨as, hs⟩ + else + have his: i < s := by + apply Nat.lt_of_le_of_lt ?_ hhs + apply hih - let rec @[specialize] sort (as : Array α) (low high : Nat) - (hlh: low ≤ high) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := - let s := as.size - have hs: as.size = s := rfl - if hlh': low < high then - have hhs := hhs hlh' + have hih: i + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh') - qpartition' as lt low high hlh (hs ▸ hhs) λ as hs' mid hlm hmh ↦ - have hs: as.size = s := hs' + let ⟨as, hs'⟩ := sort as low i hli (λ _ ↦ hs ▸ his) + have hs: as.size = s := by rw [← hs, hs'] - if hmh': mid >= high then - ⟨as, hs⟩ - else - have hms: mid < s := by - apply Nat.lt_of_le_of_lt ?_ hhs - apply hmh + let ⟨as, hs'⟩ := sort as (i+1) high hih (λ _ ↦ hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - have hmh: mid + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh') + ⟨as, hs⟩ + termination_by (high - low, 0, high - j) - let ⟨as, hs'⟩ := sort as low mid hlm (λ _ ↦ hs ▸ hms) - have hs: as.size = s := by rw [← hs, hs'] + have hll: low ≤ low := Nat.le_refl low - let ⟨as, hs'⟩ := sort as (mid+1) high hmh (λ _ ↦ hs ▸ hhs) - have hs: as.size = s := by rw [← hs, hs'] + let ⟨as, hs'⟩ := loop as low low hll hll hlh (hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - ⟨as, hs⟩ - else ⟨as, hs⟩ + ⟨as, hs⟩ + termination_by (high - low, 1, 0) (sort as low high hlh hhs).1 -@[simp] -theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) +@[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): (qsort as lt low high hlh hhs).size = as.size := by unfold qsort exact (qsort.sort lt as low high hlh hhs).2 -def qsort_nats (as : Array Nat) := - qsort as (· < · ) - end Array From ec4f4637ee1a103e0a7249408ae9b1065fd30cc9 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 01:11:52 +0000 Subject: [PATCH 09/54] add comment, simplify the code --- src/Init/Data/Array/QSort.lean | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 5c446323db16..52ea40430bcd 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -75,16 +75,17 @@ namespace Array let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] - have hih: i ≤ high := Nat.le_trans hij hjh - - if hmh': i >= high then + -- this can only happen if low == high assuming lt is antisymmetric + -- that's because i == j == high implies that all x in [low, high) are less than the pivot as[high] + -- in particular, this means that if mid != high, as[mid] is less than as[high], which is impossible, + -- because we swap them in that case, so that a[mid] >= a[high] + -- hence, mid = high, which implies (low + high) / 2 = high, which implies that low = high or + -- low = high + 1, the latter of which is impossible because low <= high; hence, low == high + if hih: i >= high then ⟨as, hs⟩ else - have his: i < s := by - apply Nat.lt_of_le_of_lt ?_ hhs - apply hih - - have hih: i + 1 ≤ high := Nat.succ_le_of_lt (Nat.gt_of_not_le hmh') + have hih: i < high := Nat.gt_of_not_le hih + have his: i < s := Nat.lt_trans hih hhs let ⟨as, hs'⟩ := sort as low i hli (λ _ ↦ hs ▸ his) have hs: as.size = s := by rw [← hs, hs'] From 8b554c733f3249d68655ca415fb253795724e987 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 01:37:00 +0000 Subject: [PATCH 10/54] move swap into else branch, since it's a no-op in the if because i == high --- src/Init/Data/Array/QSort.lean | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 52ea40430bcd..e2712925c0ab 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -71,19 +71,19 @@ namespace Array have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ - else - let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ - have hs: as.size = s := by simp_all only [as, Array.size_swap] - + else if hih: i >= high then -- this can only happen if low == high assuming lt is antisymmetric -- that's because i == j == high implies that all x in [low, high) are less than the pivot as[high] -- in particular, this means that if mid != high, as[mid] is less than as[high], which is impossible, -- because we swap them in that case, so that a[mid] >= a[high] -- hence, mid = high, which implies (low + high) / 2 = high, which implies that low = high or -- low = high + 1, the latter of which is impossible because low <= high; hence, low == high - if hih: i >= high then + ⟨as, hs⟩ else + let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ + have hs: as.size = s := by simp_all only [as, Array.size_swap] + have hih: i < high := Nat.gt_of_not_le hih have his: i < s := Nat.lt_trans hih hhs From bd990c59ee65dc2eb5bbfc8a95d3e44ae4e565ca Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 01:44:56 +0000 Subject: [PATCH 11/54] rename and rearrange code --- src/Init/Data/Array/QSort.lean | 40 +++++++++++++++++----------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index e2712925c0ab..1ccc23aa5f1c 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -27,31 +27,32 @@ namespace Array have hls: low < s := Nat.lt_of_le_of_lt hlh hhs - let i := (low + high) / 2 + let mid := (low + high) / 2 - have hms: i < s := by + have hms: mid < s := by apply Nat.div_lt_of_lt_mul rw [Nat.two_mul] exact Nat.add_lt_add hls hhs - let as := if lt (as[i]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨i, hs ▸ hms⟩ else as + let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] let as := if lt (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let as := if lt (as[i]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨i, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as + let as := if lt (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] let pivot := as[high]'(hs ▸ hhs) + -- invariant: lo ≤ x < i → lt as[i] pivot, i ≤ x < j -> ¬lt as[i] pivot let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): {as': Array α // as'.size = as.size}:= let s := as.size have hs: as.size = s := rfl have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) - if hjh' : j < high then - have hjs: j < s := Nat.lt_trans hjh' hhs + if hjh : j < high then + have hjs: j < s := Nat.lt_trans hjh hhs if lt (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ @@ -60,14 +61,14 @@ namespace Array have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 have hli: low ≤ i + 1 := Nat.le_add_right_of_le hli - let ⟨as, hs'⟩ := loop as (i+1) (j+1) hli hij hjh' (hs ▸ hhs) + let ⟨as, hs'⟩ := loop as (i+1) (j+1) hli hij hjh (hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ else have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij - let ⟨as, hs'⟩ := loop as i (j+1) hli hij hjh' (hs ▸ hhs) + let ⟨as, hs'⟩ := loop as i (j+1) hli hij hjh (hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ @@ -79,22 +80,21 @@ namespace Array -- hence, mid = high, which implies (low + high) / 2 = high, which implies that low = high or -- low = high + 1, the latter of which is impossible because low <= high; hence, low == high - ⟨as, hs⟩ - else - let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ - have hs: as.size = s := by simp_all only [as, Array.size_swap] + ⟨as, hs⟩ + else + have hih: i < high := Nat.gt_of_not_le hih - have hih: i < high := Nat.gt_of_not_le hih - have his: i < s := Nat.lt_trans hih hhs + let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ + have hs: as.size = s := by simp_all only [as, Array.size_swap] - let ⟨as, hs'⟩ := sort as low i hli (λ _ ↦ hs ▸ his) - have hs: as.size = s := by rw [← hs, hs'] + let ⟨as, hs'⟩ := sort as low i hli (λ _ ↦ hs ▸ his) + have hs: as.size = s := by rw [← hs, hs'] - let ⟨as, hs'⟩ := sort as (i+1) high hih (λ _ ↦ hs ▸ hhs) - have hs: as.size = s := by rw [← hs, hs'] + let ⟨as, hs'⟩ := sort as (i+1) high hih (λ _ ↦ hs ▸ hhs) + have hs: as.size = s := by rw [← hs, hs'] - ⟨as, hs⟩ - termination_by (high - low, 0, high - j) + ⟨as, hs⟩ + termination_by (high - low, 0, high - j) have hll: low ≤ low := Nat.le_refl low From 5319c454c62ed1f5a6c63de058ab8c80ba50c50d Mon Sep 17 00:00:00 2001 From: lyphyser Date: Sun, 15 Sep 2024 08:53:21 +0000 Subject: [PATCH 12/54] add initial proof that qsort sorts (both ordering and permutation properties) Complete, except for the fact that antisymmetry and transitivity should only be required for elements in the array range, not any value of the type. Also needs tidying and refactoring. --- src/Init/Data/Array/QSort.lean | 585 ++++++++++++++++++++++++++++++++- 1 file changed, 579 insertions(+), 6 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 1ccc23aa5f1c..379e8c989ec0 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -5,8 +5,31 @@ Authors: Leonardo de Moura -/ prelude import Init.Data.Array.Basic +import Init.Data.Array.Lemmas import Init.Data.Nat.Mod +@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): (if P then a else b).size = (if P then a.size else b.size) := by + split + all_goals rfl + +namespace Nat +theorem avg_lt_of_lt (h: a < b): (a + b) / 2 < b := by + apply (Nat.div_lt_iff_lt_mul Nat.zero_lt_two).mpr + rw [Nat.mul_two] + exact Nat.add_lt_add_right h b + +theorem le_avg_of_le (h: a ≤ b): a ≤ (a + b) / 2 := by + apply (Nat.le_div_iff_mul_le _).mpr + · rw [Nat.mul_two] + exact Nat.add_le_add_left h a + · exact Nat.zero_lt_two + +theorem avg_le_of_le (h: a ≤ b): (a + b) / 2 ≤ b:= by + apply Nat.div_le_of_le_mul + rw [Nat.two_mul] + exact Nat.add_le_add_right h b +end Nat + namespace Array @[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) @@ -29,10 +52,8 @@ namespace Array let mid := (low + high) / 2 - have hms: mid < s := by - apply Nat.div_lt_of_lt_mul - rw [Nat.two_mul] - exact Nat.add_lt_add hls hhs + have hmh: mid ≤ high := Nat.avg_le_of_le hlh + have hms: mid < s := Nat.lt_of_le_of_lt hmh hhs let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] @@ -45,7 +66,7 @@ namespace Array let pivot := as[high]'(hs ▸ hhs) - -- invariant: lo ≤ x < i → lt as[i] pivot, i ≤ x < j -> ¬lt as[i] pivot + -- invariant: lo ≤ k < i → lt as[i] pivot, i ≤ k < j -> ¬lt as[i] pivot let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): {as': Array α // as'.size = as.size}:= let s := as.size have hs: as.size = s := rfl @@ -74,7 +95,7 @@ namespace Array ⟨as, hs⟩ else if hih: i >= high then -- this can only happen if low == high assuming lt is antisymmetric - -- that's because i == j == high implies that all x in [low, high) are less than the pivot as[high] + -- that's because i == j == high implies that all k in [low, high) are less than the pivot as[high] -- in particular, this means that if mid != high, as[mid] is less than as[high], which is impossible, -- because we swap them in that case, so that a[mid] >= a[high] -- hence, mid = high, which implies (low + high) / 2 = high, which implies that low = high or @@ -106,10 +127,562 @@ namespace Array (sort as low high hlh hhs).1 +@[simp] theorem size_qsort.sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): + (qsort.sort lt as low high hlh hhs).1.size = as.size := by + exact (qsort.sort lt as low high hlh hhs).2 + @[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): (qsort as lt low high hlh hhs).size = as.size := by unfold qsort exact (qsort.sort lt as low high hlh hhs).2 +inductive IPerm {α} (low high: Nat): Array α → Array α → Prop where +| refl: IPerm low high as as +| swap (as: Array α) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as (as.swap ⟨i, his⟩ ⟨j, hjs⟩) +| trans {as as' as'': Array α}: IPerm low high as as' → IPerm low high as' as'' → IPerm low high as as'' + +namespace IPerm +theorem ite (p: Prop) [Decidable p] (low high: Nat) (as0 ast asf: Array α) + (hpt: IPerm low high as0 ast) (hpf: IPerm low high as0 asf): + IPerm low high as0 (if p then ast else asf) := by + split + case isTrue => exact hpt + case isFalse => exact hpf + +theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → Array α) (asf: ¬p → Array α) + (hpt: (h: p) → IPerm low high as0 (ast h)) (hpf: (h: ¬p) → IPerm low high as0 (asf h)): + IPerm low high as0 (if h: p then ast h else asf h) := by + split + case isTrue h => exact hpt h + case isFalse h => exact hpf h + +theorem trans_swap {as0 as: Array α} (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): + IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by + apply IPerm.trans hp + apply IPerm.swap as i his hli hih j hjs hlj hjh + +theorem expand {α} {low high: Nat} + {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} + (p: IPerm low high as as'): IPerm low' high' as as' := by + induction p with + | refl => exact refl + | trans _ _ ih ih' => exact trans ih ih' + | swap as i his hli hih j hjs hlj hjh => + exact swap as + i his (Nat.le_trans hll hli) (Nat.le_trans hih hhh) + j hjs (Nat.le_trans hll hlj) (Nat.le_trans hjh hhh) + +theorem size_eq {α} {as: Array α} {as': Array α} {low high: Nat} + (p: IPerm low high as as' ): as.size = as'.size := by + induction p with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap => simp only [size_swap] + +def getElem?_lower {α: Type u} {as: Array α} {as': Array α} {low high: Nat} (hkl: k < low) + (p: IPerm low high as as'): as[k]? = as'[k]? := by + induction p with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap _ _ _ hli _ _ _ hlj _ => + simp [swap_def] + rw [getElem?_set_ne] + rw [getElem?_set_ne] + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) + +def getElem?_higher {α: Type u} {as: Array α} {as': Array α} {low high: Nat} (hhk: high < k) + (p: IPerm low high as as'): as[k]? = as'[k]? := by + induction p with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap _ _ _ _ hih _ _ _ hjh => + simp [swap_def] + rw [getElem?_set_ne] + rw [getElem?_set_ne] + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) +end IPerm + +def IForAll (as: Array α) (P: α → Prop) (low high: Nat) := + ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) + +abbrev IForAllSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (P: α → Prop) (low high: Nat) := + IForAll (as.swap ⟨i, his⟩ ⟨j, hjs⟩) P low high + +namespace IForAll +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as P low high) (f: (a: α) → P a → Q a): + IForAll as Q low high := by + intro k hks hlk hkh + specialize ha k hks hlk hkh + exact f as[k] ha + +theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} + (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) + (ha: IForAll as P low i): + IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs P low (i + 1) := by + intro k hks hlk hki1 + rw [size_swap] at hks + simp only [swap_def] + by_cases hki: k < i + · rw [getElem_set_ne] + rw [getElem_set_ne] + exact ha k hks hlk hki + · exact Ne.symm (Nat.ne_of_lt hki) + · have hkj: k < j := Nat.lt_of_lt_of_le hki hij + exact Ne.symm (Nat.ne_of_lt hkj) + · have hki: k = i := Nat.eq_of_lt_succ_of_not_lt hki1 hki + subst k + by_cases hij: i = j + · subst i + simp only [get_eq_getElem, getElem_set_eq] + exact hjp + rw [getElem_set_ne] + rw [getElem_set_eq] + simp only [get_eq_getElem] + exact hjp + · rfl + · intro h + exact hij (Eq.symm h) + +theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hjs: j < as.size) + (hb: IForAll as P i j): + IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs P (i + 1) (j + 1) := by + intro k hks hi1x hkj1 + rw [size_swap] at hks + simp only [swap_def] + by_cases hkj: k < j + · rw [getElem_set_ne] + rw [getElem_set_ne] + have hik: i ≤ k := Nat.le_of_succ_le hi1x + exact hb k hks hik hkj + · exact Nat.ne_of_lt hi1x + · exact Ne.symm (Nat.ne_of_lt hkj) + · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj + subst k + simp only [get_eq_getElem, getElem_set_eq] + exact hb i (Nat.lt_trans hi1x hjs) (Nat.le_refl i) hi1x + +theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} + (h: IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs + P low high): IForAll as P low high := by + have his := Nat.lt_of_le_of_lt hij hjs + intro k hks hlk hkh + simp [IForAllSwap, IForAll, size_swap, swap_def] at h + by_cases hki: k = i + · subst k + have hlj: low ≤ j := Nat.le_trans hli hij + specialize h j hjs hlj hjh + rwa [getElem_set_eq] at h + · rfl + by_cases hkj: k = j + · subst k + have hih: i < high := Nat.lt_of_le_of_lt hij hjh + specialize h i his hli hih + rw [getElem_set_ne] at h + rwa [getElem_set_eq] at h + · rfl + · exact hki + specialize h k hks hlk hkh + rw [getElem_set_ne] at h + rwa [getElem_set_ne] at h + · exact Ne.symm hki + · exact Ne.symm hkj + +/-- can use IPerm.expand if the sizes don't match --/ +theorem transport_in {low high : Nat} {as as' : Array α} + (hp : IPerm low high as as') + (h : as.IForAll P low (high + 1)): + as'.IForAll P low (high + 1) := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as i his hli hih j hjs hlj hjh => + intro k hks hlk hkh + simp [swap_def] + rw [getElem_set] + rw [getElem_set] + split + · exact h i his hli (Nat.lt_add_one_of_le hih) + · split + · exact h j hjs hlj (Nat.lt_add_one_of_le hjh) + · simp [size_swap] at hks + exact h k hks hlk hkh + +/-- can use IPerm.expand if the endpoints don't match --/ +theorem transport_lower {low high : Nat} {as as' : Array α} + (hp : IPerm low high as as') + (h : as.IForAll P begin low): + as'.IForAll P begin low := by +induction hp with +| refl => exact h +| trans _ _ ih ih' => exact ih' (ih h) +| swap as i his hli _ j hjs hlj _ => + intro k hks hbk hkl + simp [swap_def] + rw [getElem_set_ne] + rw [getElem_set_ne] + · simp [size_swap] at hks + exact h k hks hbk hkl + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) + +/-- can use IPerm.expand if the endpoints don't match --/ +theorem transport_higher {low high : Nat} {as as' : Array α} + (hp : IPerm low high as as') + (h : as.IForAll P (high + 1) ends): + as'.IForAll P (high + 1) ends := by +induction hp with +| refl => exact h +| trans _ _ ih ih' => exact ih' (ih h) +| swap as i his _ hih j hjs _ hjh => + intro k hks hhk hke + simp [swap_def] + rw [getElem_set_ne] + rw [getElem_set_ne] + · simp [size_swap] at hks + exact h k hks hhk hke + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) + +end IForAll + +def IsAsymm {α} (r: α → α → Prop) := + {x: α} → {y: α} → r x y → r y x → False + +def IsTrans {α} (r: α → α → Prop) := + {x: α} → {y: α} → {z: α} → r x y → r y z → r x z + +def IOrdered (lt: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := + ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → + lt (as[j]'hjs) (as[i]'(Nat.lt_trans hij hjs)) = false + +namespace IOrdered +theorem mkSingle (lt : α → α → Bool) (k: Nat) (as: Array α): + IOrdered lt k k as := by + unfold IOrdered + intro i j hli hij hjl hjs + exfalso + have hkk: k < k := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjl) + exact (Nat.ne_of_lt hkk) rfl + +theorem restrict {low high: Nat} + {low' high': Nat} (hll: low ≤ low') (hhh: high' ≤ high) {as: Array α} + (p: IOrdered lt low high as): IOrdered lt low' high' as := by + unfold IOrdered + intro i j hli hij hjl hjs + exact p i j (Nat.le_trans hll hli) hij (Nat.le_trans hjl hhh) hjs + +/-- can use IPerm.expand if the endpoints don't match --/ +theorem transport_lower {low high : Nat} {as as' : Array α} + (hp : IPerm (low + 1) high as as') + (h : as.IOrdered lt begin low): + as'.IOrdered lt begin low := by +induction hp with +| refl => exact h +| trans _ _ ih ih' => exact ih' (ih h) +| swap as i his hli _ j hjs hlj _ => + intro a b hla hab hbl hbs + have hal := Nat.lt_of_lt_of_le hab hbl + simp [swap_def] + rw [getElem_set_ne] + rw [getElem_set_ne] + rw [getElem_set_ne] + rw [getElem_set_ne] + · simp [size_swap] at hbs + exact h a b hla hab hbl hbs + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hlj)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hlj)) + +theorem glue + {lt : α → α → Bool} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} + (ha : as.IForAll (fun x => lt pivot x = false) low (i + 1)) + (hb : as.IForAll (fun x => lt x pivot = false) (i + 1) (high + 1)) + (hlttr : IsTrans fun x x_1 => lt x x_1 = false) + (h1 : IOrdered lt low i as) + (h2 : IOrdered lt (i + 1) high as): + IOrdered lt low high as := by + unfold IOrdered + intro a b hla hab hbh hbs + have has := Nat.lt_trans hab hbs + + by_cases hbi: b ≤ i + · exact h1 a b hla hab hbi hbs + + have hib: i < b := Nat.succ_le_of_lt (Nat.gt_of_not_le hbi) + by_cases hia: i + 1 ≤ a + · exact h2 a b hia hab hbh hbs + + have hai: a < i + 1 := by exact Nat.gt_of_not_le hia + specialize ha a has hla hai + specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) + exact hlttr hb ha + +end IOrdered + +abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as.size) (hks: k < as.size): α := + (as.swap ⟨i, his⟩ ⟨j, hjs⟩)[k]'( + le_of_le_of_eq hks (Eq.symm (size_swap as ⟨i, his⟩ ⟨j, hjs⟩)) + ) + +theorem getElem_after_swap {as: Array α} {i j high: Nat} (hij: i ≤ j) (hjh: j < high) (hhs: high < as.size): + as.swap_getElem i j high (Nat.lt_of_le_of_lt hij (Nat.lt_trans hjh hhs)) (Nat.lt_trans hjh hhs) hhs + = (as[high]'hhs) := by + simp [swap_getElem, swap_def] + rw [getElem_set_ne] + rw [getElem_set_ne] + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hij hjh) + · exact Nat.ne_of_lt (hjh) + +structure ISortOf (lt: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where + perm: IPerm low high orig sorted + ord: IOrdered lt low high sorted + +namespace ISortOf +theorem mkSingle (lt : α → α → Bool) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): + ISortOf lt k k as0 as := ⟨hp, IOrdered.mkSingle lt k as⟩ + +theorem trans {lt: α → α → Bool} {low high: Nat} {as as' as'': Array α} + (hp: IPerm low high as as') (hs: ISortOf lt low high as' as''): + (ISortOf lt low high as as'') := by + constructor + case ord => + exact hs.ord + case perm => + apply IPerm.trans hp hs.perm +end ISortOf + +mutual + theorem qsort_sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + (hli : low ≤ i) (hih : i < high) (hhs : high < as.size) + (ha: IForAll as (lt pivot · = false) low (i + 1)) + (hb: IForAll as (lt · pivot = false) (i + 1) (high + 1)) + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + have ⟨as', hs'⟩ := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) + ISortOf lt low high as0 (qsort.sort lt as' (i + 1) high hih (λ _ ↦ hs' ▸ hhs)) := by + + have h1 := qsort_sort_sorts as lt low i hli (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr + let ahs' := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) + let as' := ahs'.1 + let hs' := ahs'.2 + have h2 := qsort_sort_sorts as' lt (i + 1) high hih (λ _ ↦ hs' ▸ hhs) hltas hlttr + constructor + case perm => + apply IPerm.trans hp + apply IPerm.trans + · apply IPerm.expand (Nat.le_refl _) (Nat.le_of_lt hih) h1.perm + · apply IPerm.expand (Nat.le_add_right_of_le hli) (Nat.le_refl _) h2.perm + + case ord => + apply IOrdered.glue + case hlttr => exact hlttr + case pivot => exact pivot + case i => exact i + case ha => exact (ha.transport_in h1.perm).transport_lower h2.perm + case hb => exact (hb.transport_higher h1.perm).transport_in h2.perm + case h1 => + apply IOrdered.transport_lower + case hp => exact h2.perm + case h => exact h1.ord + case h2 => exact h2.ord + termination_by (high - low, 0, 0) + + theorem qsort_sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + {pivot : α} (i j : Nat) + (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) + (ha: IForAll as (lt · pivot) low i) + (hb: IForAll as (lt · pivot = false) i j) + (hc: IForAll as (lt · pivot) low high → low = high) + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + ISortOf lt low high as0 (qsort.sort.loop lt low high pivot as i j hli hij hjh hhs) := by + unfold qsort.sort.loop + + have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs + have his: i < as.size := Nat.lt_of_le_of_lt hij hjs + have hih: i ≤ high := Nat.le_trans hij hjh + have hlj: low ≤ j := Nat.le_trans hli hij + have hlh: low ≤ high := Nat.le_trans hli hih + + by_cases hjh': j < high + all_goals simp only [hjh', ↓reduceDIte] + + case pos => + have hjs: j < as.size := Nat.lt_trans hjh' hhs + by_cases hjp: lt (as[j]'hjs) pivot = true + all_goals simp only [hjp, Bool.false_eq_true, ↓reduceIte] + + case pos => + apply qsort_sort_loop_sorts + case hph => simpa only [getElem_after_swap hij hjh' hhs] + case ha => exact ha.swap_left hij hjp + case hb => exact hb.swap_right hij hjs + case hc => intro h; apply hc; exact h.of_swap hli hij hjh' + case hltas => exact hltas + case hlttr => exact hlttr + case hp => exact .trans hp (.swap as i his hli hih j hjs hlj hjh) + + case neg => + apply qsort_sort_loop_sorts + case hph => exact hph + case ha => + exact ha + + case hb => + intro k hks hik hkj1 + by_cases hkj: k < j + · specialize hb k hks hik hkj + exact hb + · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj + subst k + exact eq_false_of_ne_true hjp + + case hc => + exact hc + + case hltas => exact hltas + case hlttr => exact hlttr + case hp => exact hp + + case neg => + have hjh: j = high := Nat.le_antisymm hjh (Nat.le_of_not_lt hjh') + subst j + by_cases hhi: i ≥ high + all_goals simp only [hhi, ↓reduceDIte] + + case pos => + have hih: i ≤ high := Nat.le_trans hij hjh + have hi: i = high := Nat.le_antisymm hih hhi + subst i + suffices h: low = high by + subst high + apply ISortOf.mkSingle + exact hp + + apply hc + exact ha + + case neg => + apply qsort_sort_sort_sorts + case hhs => simpa [size_swap] + case hp => + exact IPerm.trans_swap hp i his hli hih high hhs hlh (Nat.le_refl _) + case ha => + let ha := ha.map (λ x a ↦ eq_false_of_ne_true (hltas a)) + + have hhh: lt as[high] as[high] = false := by + exact eq_false_of_ne_true fun a => hltas a a + + exact (hph ▸ ha).swap_left hij hhh + case hb => exact (hph ▸ hb).swap_right hij hhs + case hltas => exact hltas + case hlttr => exact hlttr + termination_by (high - low, 1, high - j) + + theorem qsort_sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) + --(hltas: lt as[mid] as[high] = true → lt as[high] as[mid] = true → False) + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + + let as' := if lt (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as + have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] + + ISortOf lt low high as0 (qsort.sort.loop lt low high (as'[high]'(hs' ▸ hhs)) as' low low + (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by + have hms := Nat.lt_trans hmh hhs + have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) + + have hmh': mid ≠ high := Nat.ne_of_lt hmh + apply qsort_sort_loop_sorts + case hc => + intro h + simp only [IForAll, size_ite, size_swap, ite_self] at h + specialize h mid hms hlm hmh + simp [swap_def] at h + split at h + case isTrue h' => + rw [getElem_set_ne] at h + rw [getElem_set_eq] at h + rw [getElem_set_eq] at h + exfalso + exact hltas h' h + · rfl + · rfl + · exact Ne.symm hmh' + case isFalse h' => + exfalso + exact h' h + case hph => rfl + case hltas => exact hltas + case hlttr => exact hlttr + case hp => + split + case isTrue h => + exact .trans hp <| .swap as mid hms hlm (Nat.le_of_lt hmh) high hhs hlh (Nat.le_refl _) + case isFalse h => + exact hp + all_goals + intro k hks hlk hkl + have hll: low < low := Nat.lt_of_le_of_lt hlk hkl + exfalso + exact (Nat.ne_of_lt hll) rfl + termination_by (high - low, 2, 0) + + theorem qsort_sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) + -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother + --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + ISortOf lt low high as (qsort.sort lt as low high hlh hhs) := by + unfold qsort.sort + by_cases hlh': low ≥ high + case pos => + simp [hlh'] + constructor + case ord => + intro i j hli hij hjh hjs + have hlh := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjh) + exfalso + have hlh'': ¬(low ≥ high) := by + exact Nat.not_le_of_lt hlh + exact hlh'' hlh' + case perm => + exact IPerm.refl + case neg => + simp only [hlh'] + have hlh': low < high := Nat.gt_of_not_le hlh' + + apply qsort_sort_loop_pivot_swap_sorts + + case hlm => exact Nat.le_avg_of_le hlh + case hmh => exact Nat.avg_lt_of_lt hlh' + + case hltas => exact hltas + case hlttr => exact hlttr + + case hp => + repeat any_goals + first + | apply Nat.le_refl + | apply Nat.avg_le_of_le + | apply Nat.le_avg_of_le + | apply IPerm.refl + | apply IPerm.ite + | apply IPerm.trans_swap + | assumption + termination_by ((sizeOf high) - (sizeOf low), 3, 0) +end + +theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + ISortOf lt low high as (qsort as lt low high hlh hhs) := by + unfold qsort + apply qsort_sort_sorts + · exact hltas + · exact hlttr + end Array From 54b3f485d5925ca21741e48c7323018c316c63b4 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 10:56:08 +0000 Subject: [PATCH 13/54] add size_dite --- src/Init/Data/Array/QSort.lean | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 379e8c989ec0..6119b046ee38 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -8,7 +8,13 @@ import Init.Data.Array.Basic import Init.Data.Array.Lemmas import Init.Data.Nat.Mod -@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): (if P then a else b).size = (if P then a.size else b.size) := by +@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): + (if P then a else b).size = (if P then a.size else b.size) := by + split + all_goals rfl + +@[simp] theorem size_dite (P: Prop) [Decidable P] (a: P → Array α) (b: ¬P → Array α): + (if h: P then a h else b h).size = (if h: P then (a h).size else (b h).size) := by split all_goals rfl From 2e5b27b8641cc9da57e0fa90920f3bfdfa658cbc Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 10:57:53 +0000 Subject: [PATCH 14/54] State the nat lemmas as iffs with clean proofs --- src/Init/Data/Array/QSort.lean | 50 ++++++++++++++++++++++------------ 1 file changed, 32 insertions(+), 18 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 6119b046ee38..db061d333362 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -19,21 +19,35 @@ import Init.Data.Nat.Mod all_goals rfl namespace Nat -theorem avg_lt_of_lt (h: a < b): (a + b) / 2 < b := by - apply (Nat.div_lt_iff_lt_mul Nat.zero_lt_two).mpr - rw [Nat.mul_two] - exact Nat.add_lt_add_right h b - -theorem le_avg_of_le (h: a ≤ b): a ≤ (a + b) / 2 := by - apply (Nat.le_div_iff_mul_le _).mpr - · rw [Nat.mul_two] - exact Nat.add_le_add_left h a - · exact Nat.zero_lt_two - -theorem avg_le_of_le (h: a ≤ b): (a + b) / 2 ≤ b:= by - apply Nat.div_le_of_le_mul - rw [Nat.two_mul] - exact Nat.add_le_add_right h b +@[simp] theorem lt_avg_iff_succ_lt: n < (n + m) / 2 ↔ n + 1 < m := by + rw [← succ_le, + Nat.le_div_iff_mul_le Nat.zero_lt_two, + Nat.mul_two, succ_add, succ_le, + Nat.add_lt_add_iff_left] + +@[simp] theorem le_avg_iff_le: n ≤ (n + m) / 2 ↔ n ≤ m := by + rw [ + Nat.le_div_iff_mul_le Nat.zero_lt_two, + Nat.mul_two, + Nat.add_le_add_iff_left] + +@[simp] theorem avg_lt_iff_lt: (n + m) / 2 < m ↔ n < m:= by + rw [ + Nat.div_lt_iff_lt_mul Nat.zero_lt_two, + Nat.mul_two, + Nat.add_lt_add_iff_right] + +@[simp] theorem avg_le_iff_le_succ: (n + m) / 2 ≤ m ↔ n ≤ m + 1:= by + rw [← lt_succ, + Nat.div_lt_iff_lt_mul Nat.zero_lt_two, + Nat.mul_two, add_succ, lt_succ, + Nat.add_le_add_iff_right] + +theorem lt_of_avg_lt (h: n < (n + m) / 2): n < m := + lt_of_succ_lt (lt_avg_iff_succ_lt.mp h) + +theorem avg_le_of_le (h: n ≤ m): (n + m) / 2 ≤ m := + avg_le_iff_le_succ.mpr (le_add_right_of_le h) end Nat namespace Array @@ -663,8 +677,8 @@ mutual apply qsort_sort_loop_pivot_swap_sorts - case hlm => exact Nat.le_avg_of_le hlh - case hmh => exact Nat.avg_lt_of_lt hlh' + case hlm => exact Nat.le_avg_iff_le.mpr hlh + case hmh => exact Nat.avg_lt_iff_lt.mpr hlh' case hltas => exact hltas case hlttr => exact hlttr @@ -674,7 +688,7 @@ mutual first | apply Nat.le_refl | apply Nat.avg_le_of_le - | apply Nat.le_avg_of_le + | apply Nat.le_avg_iff_le.mpr | apply IPerm.refl | apply IPerm.ite | apply IPerm.trans_swap From 00dc08077c9b100cbbcafc9484497d724c741671 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 11:03:08 +0000 Subject: [PATCH 15/54] rename theorems --- src/Init/Data/Array/QSort.lean | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index db061d333362..e9082b2e2a3d 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -477,7 +477,7 @@ theorem trans {lt: α → α → Bool} {low high: Nat} {as as' as'': Array α} end ISortOf mutual - theorem qsort_sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) (hli : low ≤ i) (hih : i < high) (hhs : high < as.size) (ha: IForAll as (lt pivot · = false) low (i + 1)) (hb: IForAll as (lt · pivot = false) (i + 1) (high + 1)) @@ -485,11 +485,11 @@ mutual have ⟨as', hs'⟩ := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) ISortOf lt low high as0 (qsort.sort lt as' (i + 1) high hih (λ _ ↦ hs' ▸ hhs)) := by - have h1 := qsort_sort_sorts as lt low i hli (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr + have h1 := qsort.sort_sorts as lt low i hli (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr let ahs' := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) let as' := ahs'.1 let hs' := ahs'.2 - have h2 := qsort_sort_sorts as' lt (i + 1) high hih (λ _ ↦ hs' ▸ hhs) hltas hlttr + have h2 := qsort.sort_sorts as' lt (i + 1) high hih (λ _ ↦ hs' ▸ hhs) hltas hlttr constructor case perm => apply IPerm.trans hp @@ -511,7 +511,7 @@ mutual case h2 => exact h2.ord termination_by (high - low, 0, 0) - theorem qsort_sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) {pivot : α} (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) (ha: IForAll as (lt · pivot) low i) @@ -536,7 +536,7 @@ mutual all_goals simp only [hjp, Bool.false_eq_true, ↓reduceIte] case pos => - apply qsort_sort_loop_sorts + apply qsort.sort_loop_sorts case hph => simpa only [getElem_after_swap hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs @@ -546,7 +546,7 @@ mutual case hp => exact .trans hp (.swap as i his hli hih j hjs hlj hjh) case neg => - apply qsort_sort_loop_sorts + apply qsort.sort_loop_sorts case hph => exact hph case ha => exact ha @@ -586,7 +586,7 @@ mutual exact ha case neg => - apply qsort_sort_sort_sorts + apply qsort.sort_sort_sorts case hhs => simpa [size_swap] case hp => exact IPerm.trans_swap hp i his hli hih high hhs hlh (Nat.le_refl _) @@ -602,7 +602,7 @@ mutual case hlttr => exact hlttr termination_by (high - low, 1, high - j) - theorem qsort_sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) --(hltas: lt as[mid] as[high] = true → lt as[high] as[mid] = true → False) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): @@ -616,7 +616,7 @@ mutual have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) have hmh': mid ≠ high := Nat.ne_of_lt hmh - apply qsort_sort_loop_sorts + apply qsort.sort_loop_sorts case hc => intro h simp only [IForAll, size_ite, size_swap, ite_self] at h @@ -651,7 +651,7 @@ mutual exact (Nat.ne_of_lt hll) rfl termination_by (high - low, 2, 0) - theorem qsort_sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): @@ -675,7 +675,7 @@ mutual simp only [hlh'] have hlh': low < high := Nat.gt_of_not_le hlh' - apply qsort_sort_loop_pivot_swap_sorts + apply qsort.sort_loop_pivot_swap_sorts case hlm => exact Nat.le_avg_iff_le.mpr hlh case hmh => exact Nat.avg_lt_iff_lt.mpr hlh' @@ -701,7 +701,7 @@ theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): ISortOf lt low high as (qsort as lt low high hlh hhs) := by unfold qsort - apply qsort_sort_sorts + apply qsort.sort_sorts · exact hltas · exact hlttr From 52101f73e95bd9db10e971ada61df0393e9ac814 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 11:10:46 +0000 Subject: [PATCH 16/54] rename nat lemmas to follow mathlib naming convention --- src/Init/Data/Array/QSort.lean | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index e9082b2e2a3d..286eb8335fb6 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -19,35 +19,35 @@ import Init.Data.Nat.Mod all_goals rfl namespace Nat -@[simp] theorem lt_avg_iff_succ_lt: n < (n + m) / 2 ↔ n + 1 < m := by +@[simp] theorem left_lt_add_div_two: n < (n + m) / 2 ↔ n + 1 < m := by rw [← succ_le, Nat.le_div_iff_mul_le Nat.zero_lt_two, Nat.mul_two, succ_add, succ_le, Nat.add_lt_add_iff_left] -@[simp] theorem le_avg_iff_le: n ≤ (n + m) / 2 ↔ n ≤ m := by +@[simp] theorem left_le_add_div_two: n ≤ (n + m) / 2 ↔ n ≤ m := by rw [ Nat.le_div_iff_mul_le Nat.zero_lt_two, Nat.mul_two, Nat.add_le_add_iff_left] -@[simp] theorem avg_lt_iff_lt: (n + m) / 2 < m ↔ n < m:= by +@[simp] theorem add_div_two_lt_right: (n + m) / 2 < m ↔ n < m:= by rw [ Nat.div_lt_iff_lt_mul Nat.zero_lt_two, Nat.mul_two, Nat.add_lt_add_iff_right] -@[simp] theorem avg_le_iff_le_succ: (n + m) / 2 ≤ m ↔ n ≤ m + 1:= by +@[simp] theorem add_div_two_le_right: (n + m) / 2 ≤ m ↔ n ≤ m + 1:= by rw [← lt_succ, Nat.div_lt_iff_lt_mul Nat.zero_lt_two, Nat.mul_two, add_succ, lt_succ, Nat.add_le_add_iff_right] -theorem lt_of_avg_lt (h: n < (n + m) / 2): n < m := - lt_of_succ_lt (lt_avg_iff_succ_lt.mp h) +theorem lt_of_left_lt_add_div_two (h: n < (n + m) / 2): n < m := + lt_of_succ_lt (left_lt_add_div_two.mp h) -theorem avg_le_of_le (h: n ≤ m): (n + m) / 2 ≤ m := - avg_le_iff_le_succ.mpr (le_add_right_of_le h) +theorem add_div_two_le_right_of_le (h: n ≤ m): (n + m) / 2 ≤ m := + add_div_two_le_right.mpr (le_add_right_of_le h) end Nat namespace Array @@ -72,7 +72,7 @@ namespace Array let mid := (low + high) / 2 - have hmh: mid ≤ high := Nat.avg_le_of_le hlh + have hmh: mid ≤ high := Nat.add_div_two_le_right_of_le hlh have hms: mid < s := Nat.lt_of_le_of_lt hmh hhs let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as @@ -677,8 +677,8 @@ mutual apply qsort.sort_loop_pivot_swap_sorts - case hlm => exact Nat.le_avg_iff_le.mpr hlh - case hmh => exact Nat.avg_lt_iff_lt.mpr hlh' + case hlm => exact Nat.left_le_add_div_two.mpr hlh + case hmh => exact Nat.add_div_two_lt_right.mpr hlh' case hltas => exact hltas case hlttr => exact hlttr @@ -687,8 +687,8 @@ mutual repeat any_goals first | apply Nat.le_refl - | apply Nat.avg_le_of_le - | apply Nat.le_avg_iff_le.mpr + | apply Nat.add_div_two_le_right_of_le + | apply Nat.left_le_add_div_two.mpr | apply IPerm.refl | apply IPerm.ite | apply IPerm.trans_swap From bcdb315e9caaa3215d878c160918309045f2759b Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 12:05:15 +0000 Subject: [PATCH 17/54] remove unnecessary low <= high hypothesis --- src/Init/Data/Array/QSort.lean | 76 +++++++++++++++++----------------- 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 286eb8335fb6..6f59e6f9b546 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -53,26 +53,26 @@ end Nat namespace Array @[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) : Array α := + (hhs: low < high → high < as.size := by omega) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) - (hlh: low ≤ high) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := + (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := let s := as.size have hs: as.size = s := rfl if hlh': low >= high then ⟨as, hs⟩ else - have hlh': low < high := Nat.gt_of_not_le hlh' - have hhs := hhs hlh' + have hlh: low < high := Nat.gt_of_not_le hlh' + have hhs := hhs hlh let s := as.size have hs: as.size = s := rfl - have hls: low < s := Nat.lt_of_le_of_lt hlh hhs + have hls: low < s := Nat.lt_trans hlh hhs let mid := (low + high) / 2 - have hmh: mid ≤ high := Nat.add_div_two_le_right_of_le hlh + have hmh: mid ≤ high := Nat.add_div_two_le_right_of_le (Nat.le_of_lt hlh) have hms: mid < s := Nat.lt_of_le_of_lt hmh hhs let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as @@ -113,7 +113,7 @@ namespace Array have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ - else if hih: i >= high then + else if i >= high then -- this can only happen if low == high assuming lt is antisymmetric -- that's because i == j == high implies that all k in [low, high) are less than the pivot as[high] -- in particular, this means that if mid != high, as[mid] is less than as[high], which is impossible, @@ -123,15 +123,13 @@ namespace Array ⟨as, hs⟩ else - have hih: i < high := Nat.gt_of_not_le hih - let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] - let ⟨as, hs'⟩ := sort as low i hli (λ _ ↦ hs ▸ his) + let ⟨as, hs'⟩ := sort as low i (λ _ ↦ hs ▸ his) have hs: as.size = s := by rw [← hs, hs'] - let ⟨as, hs'⟩ := sort as (i+1) high hih (λ _ ↦ hs ▸ hhs) + let ⟨as, hs'⟩ := sort as (i+1) high (λ _ ↦ hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ @@ -139,24 +137,24 @@ namespace Array have hll: low ≤ low := Nat.le_refl low - let ⟨as, hs'⟩ := loop as low low hll hll hlh (hs ▸ hhs) + let ⟨as, hs'⟩ := loop as low low hll hll (Nat.le_of_lt hlh) (hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ termination_by (high - low, 1, 0) - (sort as low high hlh hhs).1 + (sort as low high hhs).1 @[simp] theorem size_qsort.sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): - (qsort.sort lt as low high hlh hhs).1.size = as.size := by - exact (qsort.sort lt as low high hlh hhs).2 + (hhs: low < high → high < as.size := by omega): + (qsort.sort lt as low high hhs).1.size = as.size := by + exact (qsort.sort lt as low high hhs).2 @[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega): - (qsort as lt low high hlh hhs).size = as.size := by + (hhs: low < high → high < as.size := by omega): + (qsort as lt low high hhs).size = as.size := by unfold qsort - exact (qsort.sort lt as low high hlh hhs).2 + exact (qsort.sort lt as low high hhs).2 inductive IPerm {α} (low high: Nat): Array α → Array α → Prop where | refl: IPerm low high as as @@ -482,14 +480,14 @@ mutual (ha: IForAll as (lt pivot · = false) low (i + 1)) (hb: IForAll as (lt · pivot = false) (i + 1) (high + 1)) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): - have ⟨as', hs'⟩ := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) - ISortOf lt low high as0 (qsort.sort lt as' (i + 1) high hih (λ _ ↦ hs' ▸ hhs)) := by + have ⟨as', hs'⟩ := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) + ISortOf lt low high as0 (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by - have h1 := qsort.sort_sorts as lt low i hli (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr - let ahs' := qsort.sort lt as low i hli (λ _ ↦ Nat.lt_trans hih hhs) + have h1 := qsort.sort_sorts as lt low i (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr + let ahs' := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) let as' := ahs'.1 let hs' := ahs'.2 - have h2 := qsort.sort_sorts as' lt (i + 1) high hih (λ _ ↦ hs' ▸ hhs) hltas hlttr + have h2 := qsort.sort_sorts as' lt (i + 1) high (λ _ ↦ hs' ▸ hhs) hltas hlttr constructor case perm => apply IPerm.trans hp @@ -600,6 +598,9 @@ mutual case hb => exact (hph ▸ hb).swap_right hij hhs case hltas => exact hltas case hlttr => exact hlttr + case hli => exact hli + case hih => exact Nat.gt_of_not_le hhi + termination_by (high - low, 1, high - j) theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) @@ -652,33 +653,34 @@ mutual termination_by (high - low, 2, 0) theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) + (hhs: low < high → high < as.size := by omega) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): - ISortOf lt low high as (qsort.sort lt as low high hlh hhs) := by + ISortOf lt low high as (qsort.sort lt as low high hhs) := by unfold qsort.sort - by_cases hlh': low ≥ high + by_cases hlh: low ≥ high case pos => - simp [hlh'] + simp [hlh] constructor case ord => intro i j hli hij hjh hjs - have hlh := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjh) + have hlh' := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjh) exfalso have hlh'': ¬(low ≥ high) := by - exact Nat.not_le_of_lt hlh - exact hlh'' hlh' + exact Nat.not_le_of_lt hlh' + exact hlh'' hlh case perm => exact IPerm.refl case neg => - simp only [hlh'] - have hlh': low < high := Nat.gt_of_not_le hlh' + simp only [hlh] + have hlh: low < high := Nat.gt_of_not_le hlh + have hlh': low ≤ high := Nat.le_of_lt hlh apply qsort.sort_loop_pivot_swap_sorts - case hlm => exact Nat.left_le_add_div_two.mpr hlh - case hmh => exact Nat.add_div_two_lt_right.mpr hlh' + case hlm => exact Nat.left_le_add_div_two.mpr hlh' + case hmh => exact Nat.add_div_two_lt_right.mpr hlh case hltas => exact hltas case hlttr => exact hlttr @@ -697,9 +699,9 @@ mutual end theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlh: low ≤ high := by omega) (hhs: low < high → high < as.size := by omega) + (hhs: low < high → high < as.size := by omega) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): - ISortOf lt low high as (qsort as lt low high hlh hhs) := by + ISortOf lt low high as (qsort as lt low high hhs) := by unfold qsort apply qsort.sort_sorts · exact hltas From 65a5ac6b27a05c5bf962aeea93b1aad02437e421 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 13:14:38 +0000 Subject: [PATCH 18/54] remove high < as.size hypothesis, add single inlined check in qsort This removes all bounds hypotheses on qsort, making it more general and simpler to use. --- src/Init/Data/Array/QSort.lean | 78 +++++++++++++++++++++++++--------- 1 file changed, 58 insertions(+), 20 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 6f59e6f9b546..a587aee56f02 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -52,9 +52,7 @@ end Nat namespace Array -@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hhs: low < high → high < as.size := by omega) : Array α := - +@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := let s := as.size @@ -143,18 +141,26 @@ namespace Array ⟨as, hs⟩ termination_by (high - low, 1, 0) - (sort as low high hhs).1 + have hhs := by + intro hlh + split + · assumption + · apply Nat.sub_one_lt + intro h0 + simp [h0] at hlh + + (sort as low (if high < as.size then high else as.size - 1) hhs).1 @[simp] theorem size_qsort.sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hhs: low < high → high < as.size := by omega): + (hhs: low < high → high < as.size): (qsort.sort lt as low high hhs).1.size = as.size := by exact (qsort.sort lt as low high hhs).2 -@[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hhs: low < high → high < as.size := by omega): - (qsort as lt low high hhs).size = as.size := by +@[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1): + (qsort as lt low high).size = as.size := by unfold qsort - exact (qsort.sort lt as low high hhs).2 + split + all_goals exact (qsort.sort _ _ _ _ _).2 inductive IPerm {α} (low high: Nat): Array α → Array α → Prop where | refl: IPerm low high as as @@ -199,6 +205,18 @@ theorem size_eq {α} {as: Array α} {as': Array α} {low high: Nat} | trans _ _ ih ih' => rwa [ih'] at ih | swap => simp only [size_swap] +theorem resize_out_of_bounds (p: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): + IPerm low high' as0 as := by + induction p with + | refl => exact refl + | trans p' _ ih ih' => exact trans (ih hsh') (ih' (p'.size_eq ▸ hsh')) + | swap as i his hli _ j hjs hlj _ => + have hih': i ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt his) hsh' + have hjh': j ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh' + exact swap as + i his hli hih' + j hjs hlj hjh' + def getElem?_lower {α: Type u} {as: Array α} {as': Array α} {low high: Nat} (hkl: k < low) (p: IPerm low high as as'): as[k]? = as'[k]? := by induction p with @@ -393,6 +411,13 @@ theorem restrict {low high: Nat} intro i j hli hij hjl hjs exact p i j (Nat.le_trans hll hli) hij (Nat.le_trans hjl hhh) hjs +theorem resize_out_of_bounds (h: IOrdered lt low high as) (hsh: (as.size - 1) ≤ high): + IOrdered lt low high' as := by + unfold IOrdered + intro i j hli hij _ hjs + have hjh: j ≤ high := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh + exact h i j hli hij hjh hjs + /-- can use IPerm.expand if the endpoints don't match --/ theorem transport_lower {low high : Nat} {as as' : Array α} (hp : IPerm (low + 1) high as as') @@ -467,11 +492,15 @@ theorem mkSingle (lt : α → α → Bool) (k: Nat) (as0: Array α) (as: Array theorem trans {lt: α → α → Bool} {low high: Nat} {as as' as'': Array α} (hp: IPerm low high as as') (hs: ISortOf lt low high as' as''): (ISortOf lt low high as as'') := by - constructor - case ord => - exact hs.ord - case perm => - apply IPerm.trans hp hs.perm + constructor + case perm => exact hp.trans hs.perm + case ord => exact hs.ord + +theorem resize_out_of_bounds (h: ISortOf lt low high as0 as) (hsh: (as.size - 1) ≤ high) (hsh': (as0.size - 1) ≤ high'): + ISortOf lt low high' as0 as := by + constructor + case perm => exact h.perm.resize_out_of_bounds hsh' + case ord => exact h.ord.resize_out_of_bounds hsh end ISortOf mutual @@ -653,7 +682,7 @@ mutual termination_by (high - low, 2, 0) theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hhs: low < high → high < as.size := by omega) + (hhs: low < high → high < as.size) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): @@ -699,12 +728,21 @@ mutual end theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hhs: low < high → high < as.size := by omega) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): - ISortOf lt low high as (qsort as lt low high hhs) := by + ISortOf lt low high as (qsort as lt low high) := by unfold qsort - apply qsort.sort_sorts - · exact hltas - · exact hlttr + split + case isTrue => + apply qsort.sort_sorts + · exact hltas + · exact hlttr + case isFalse h => + apply ISortOf.resize_out_of_bounds + · apply qsort.sort_sorts + · exact hltas + · exact hlttr + · simp only [size_qsort.sort, Nat.le_refl] + · apply Nat.sub_le_of_le_add + exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) end Array From d4b3a77b5440d996f614ed44a5eb529668f04e6d Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 13:27:49 +0000 Subject: [PATCH 19/54] style --- src/Init/Data/Array/QSort.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index a587aee56f02..24a68805b7f1 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -185,7 +185,7 @@ theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → theorem trans_swap {as0 as: Array α} (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by apply IPerm.trans hp - apply IPerm.swap as i his hli hih j hjs hlj hjh + exact IPerm.swap as i his hli hih j hjs hlj hjh theorem expand {α} {low high: Nat} {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} From 0a1f6e18bebcfd860deb29aa902d10994ee3a5c0 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 13:47:28 +0000 Subject: [PATCH 20/54] do IPerm.trans in the callers to simplify definitions --- src/Init/Data/Array/QSort.lean | 179 +++++++++++++++++---------------- 1 file changed, 94 insertions(+), 85 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 24a68805b7f1..0129f0e103be 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -504,13 +504,13 @@ theorem resize_out_of_bounds (h: ISortOf lt low high as0 as) (hsh: (as.size - 1) end ISortOf mutual - theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hli : low ≤ i) (hih : i < high) (hhs : high < as.size) (ha: IForAll as (lt pivot · = false) low (i + 1)) (hb: IForAll as (lt · pivot = false) (i + 1) (high + 1)) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): have ⟨as', hs'⟩ := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) - ISortOf lt low high as0 (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by + ISortOf lt low high as (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by have h1 := qsort.sort_sorts as lt low i (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr let ahs' := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) @@ -519,7 +519,6 @@ mutual have h2 := qsort.sort_sorts as' lt (i + 1) high (λ _ ↦ hs' ▸ hhs) hltas hlttr constructor case perm => - apply IPerm.trans hp apply IPerm.trans · apply IPerm.expand (Nat.le_refl _) (Nat.le_of_lt hih) h1.perm · apply IPerm.expand (Nat.le_add_right_of_le hli) (Nat.le_refl _) h2.perm @@ -538,14 +537,14 @@ mutual case h2 => exact h2.ord termination_by (high - low, 0, 0) - theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as: Array α) {pivot : α} (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) (ha: IForAll as (lt · pivot) low i) (hb: IForAll as (lt · pivot = false) i j) (hc: IForAll as (lt · pivot) low high → low = high) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): - ISortOf lt low high as0 (qsort.sort.loop lt low high pivot as i j hli hij hjh hhs) := by + ISortOf lt low high as (qsort.sort.loop lt low high pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs @@ -563,36 +562,40 @@ mutual all_goals simp only [hjp, Bool.false_eq_true, ↓reduceIte] case pos => - apply qsort.sort_loop_sorts - case hph => simpa only [getElem_after_swap hij hjh' hhs] - case ha => exact ha.swap_left hij hjp - case hb => exact hb.swap_right hij hjs - case hc => intro h; apply hc; exact h.of_swap hli hij hjh' - case hltas => exact hltas - case hlttr => exact hlttr - case hp => exact .trans hp (.swap as i his hli hih j hjs hlj hjh) + apply ISortOf.trans + case hs => + apply qsort.sort_loop_sorts + case hph => simpa only [getElem_after_swap hij hjh' hhs] + case ha => exact ha.swap_left hij hjp + case hb => exact hb.swap_right hij hjs + case hc => intro h; apply hc; exact h.of_swap hli hij hjh' + case hltas => exact hltas + case hlttr => exact hlttr + case hp => exact .swap as i his hli hih j hjs hlj hjh case neg => - apply qsort.sort_loop_sorts - case hph => exact hph - case ha => - exact ha - - case hb => - intro k hks hik hkj1 - by_cases hkj: k < j - · specialize hb k hks hik hkj - exact hb - · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj - subst k - exact eq_false_of_ne_true hjp - - case hc => - exact hc - - case hltas => exact hltas - case hlttr => exact hlttr - case hp => exact hp + apply ISortOf.trans + case hs => + apply qsort.sort_loop_sorts + case hph => exact hph + case ha => + exact ha + + case hb => + intro k hks hik hkj1 + by_cases hkj: k < j + · specialize hb k hks hik hkj + exact hb + · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj + subst k + exact eq_false_of_ne_true hjp + + case hc => + exact hc + + case hltas => exact hltas + case hlttr => exact hlttr + case hp => exact .refl case neg => have hjh: j = high := Nat.le_antisymm hjh (Nat.le_of_not_lt hjh') @@ -607,32 +610,34 @@ mutual suffices h: low = high by subst high apply ISortOf.mkSingle - exact hp + exact .refl apply hc exact ha case neg => - apply qsort.sort_sort_sorts - case hhs => simpa [size_swap] + apply ISortOf.trans + case hs => + apply qsort.sort_sort_sorts + case hhs => simpa [size_swap] + case ha => + let ha := ha.map (λ x a ↦ eq_false_of_ne_true (hltas a)) + + have hhh: lt as[high] as[high] = false := by + exact eq_false_of_ne_true fun a => hltas a a + + exact (hph ▸ ha).swap_left hij hhh + case hb => exact (hph ▸ hb).swap_right hij hhs + case hltas => exact hltas + case hlttr => exact hlttr + case hli => exact hli + case hih => exact Nat.gt_of_not_le hhi case hp => - exact IPerm.trans_swap hp i his hli hih high hhs hlh (Nat.le_refl _) - case ha => - let ha := ha.map (λ x a ↦ eq_false_of_ne_true (hltas a)) - - have hhh: lt as[high] as[high] = false := by - exact eq_false_of_ne_true fun a => hltas a a - - exact (hph ▸ ha).swap_left hij hhh - case hb => exact (hph ▸ hb).swap_right hij hhs - case hltas => exact hltas - case hlttr => exact hlttr - case hli => exact hli - case hih => exact Nat.gt_of_not_le hhi + exact IPerm.swap as i his hli hih high hhs hlh (Nat.le_refl _) termination_by (high - low, 1, high - j) - theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as0: Array α) (as: Array α) (hp: IPerm low high as0 as) + theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) --(hltas: lt as[mid] as[high] = true → lt as[high] as[mid] = true → False) (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): @@ -640,46 +645,48 @@ mutual let as' := if lt (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] - ISortOf lt low high as0 (qsort.sort.loop lt low high (as'[high]'(hs' ▸ hhs)) as' low low + ISortOf lt low high as (qsort.sort.loop lt low high (as'[high]'(hs' ▸ hhs)) as' low low (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by have hms := Nat.lt_trans hmh hhs have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) have hmh': mid ≠ high := Nat.ne_of_lt hmh - apply qsort.sort_loop_sorts - case hc => - intro h - simp only [IForAll, size_ite, size_swap, ite_self] at h - specialize h mid hms hlm hmh - simp [swap_def] at h - split at h - case isTrue h' => - rw [getElem_set_ne] at h - rw [getElem_set_eq] at h - rw [getElem_set_eq] at h - exfalso - exact hltas h' h - · rfl - · rfl - · exact Ne.symm hmh' - case isFalse h' => + apply ISortOf.trans + case hs => + apply qsort.sort_loop_sorts + case hc => + intro h + simp only [IForAll, size_ite, size_swap, ite_self] at h + specialize h mid hms hlm hmh + simp [swap_def] at h + split at h + case isTrue h' => + rw [getElem_set_ne] at h + rw [getElem_set_eq] at h + rw [getElem_set_eq] at h + exfalso + exact hltas h' h + · rfl + · rfl + · exact Ne.symm hmh' + case isFalse h' => + exfalso + exact h' h + case hph => rfl + case hltas => exact hltas + case hlttr => exact hlttr + all_goals + intro k hks hlk hkl + have hll: low < low := Nat.lt_of_le_of_lt hlk hkl exfalso - exact h' h - case hph => rfl - case hltas => exact hltas - case hlttr => exact hlttr + exact (Nat.ne_of_lt hll) rfl case hp => split case isTrue h => - exact .trans hp <| .swap as mid hms hlm (Nat.le_of_lt hmh) high hhs hlh (Nat.le_refl _) + exact .swap as mid hms hlm (Nat.le_of_lt hmh) high hhs hlh (Nat.le_refl _) case isFalse h => - exact hp - all_goals - intro k hks hlk hkl - have hll: low < low := Nat.lt_of_le_of_lt hlk hkl - exfalso - exact (Nat.ne_of_lt hll) rfl - termination_by (high - low, 2, 0) + exact .refl + termination_by (high - low, 2, 0) theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) @@ -706,13 +713,15 @@ mutual have hlh: low < high := Nat.gt_of_not_le hlh have hlh': low ≤ high := Nat.le_of_lt hlh - apply qsort.sort_loop_pivot_swap_sorts + apply ISortOf.trans + case hs => + apply qsort.sort_loop_pivot_swap_sorts - case hlm => exact Nat.left_le_add_div_two.mpr hlh' - case hmh => exact Nat.add_div_two_lt_right.mpr hlh + case hlm => exact Nat.left_le_add_div_two.mpr hlh' + case hmh => exact Nat.add_div_two_lt_right.mpr hlh - case hltas => exact hltas - case hlttr => exact hlttr + case hltas => exact hltas + case hlttr => exact hlttr case hp => repeat any_goals From 6a060e5a3f68d8af6c0a9927e01aacee11eddaa0 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 14:12:53 +0000 Subject: [PATCH 21/54] change IOrdered to support both lt and le --- src/Init/Data/Array/QSort.lean | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 0129f0e103be..12f119128e1b 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -391,9 +391,14 @@ def IsAsymm {α} (r: α → α → Prop) := def IsTrans {α} (r: α → α → Prop) := {x: α} → {y: α} → {z: α} → r x y → r y z → r x z -def IOrdered (lt: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := +/-- +If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] +If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] + -/ +def IOrdered (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → - lt (as[j]'hjs) (as[i]'(Nat.lt_trans hij hjs)) = false + r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) = true + ∨ r (as[j]'hjs) (as[i]'(Nat.lt_trans hij hjs)) = false namespace IOrdered theorem mkSingle (lt : α → α → Bool) (k: Nat) (as: Array α): @@ -436,10 +441,10 @@ induction hp with rw [getElem_set_ne] · simp [size_swap] at hbs exact h a b hla hab hbl hbs - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hli)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hlj)) · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hli)) · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hlj)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hlj)) theorem glue {lt : α → α → Bool} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} @@ -463,6 +468,7 @@ theorem glue have hai: a < i + 1 := by exact Nat.gt_of_not_le hia specialize ha a has hla hai specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) + right exact hlttr hb ha end IOrdered From b71ba3ac5cd8ce1da4621cd709d12a9741ef2825 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 14:47:43 +0000 Subject: [PATCH 22/54] . --- src/Init/Data/Array/QSort.lean | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 12f119128e1b..ba0cce35edba 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -391,14 +391,34 @@ def IsAsymm {α} (r: α → α → Prop) := def IsTrans {α} (r: α → α → Prop) := {x: α} → {y: α} → {z: α} → r x y → r y z → r x z +/- +structure IsMultiTrans {α} (r: α → α → Prop) where + -pos: {x: α} → {y: α} → {z: α} → r x y → r y z → r x z + neg: {x: α} → {y: α} → {z: α} → ¬r x y → ¬r y z → ¬r x z + -p_of_pn: {x: α} → {y: α} → {z: α} → r x y → ¬r z y → r x z + -p_of_np: {x: α} → {y: α} → {z: α} → ¬r y x → r y z → r x z + n_of_np: {x: α} → {y: α} → {z: α} → ¬r x y → r z y → ¬r x z + n_of_pn: {x: α} → {y: α} → {z: α} → r y x → ¬r y z → ¬r x z +-/ + + + /-- + If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] + If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] + -/ +abbrev le_of_any (r: α → α → Prop) (i j: α):= r i j ∨ ¬r j i +abbrev le_of_any_b (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false + +def IPairwise (r: α → α → Prop) (low: Nat) (high: Nat) (as: Array α) := + ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → + r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) + /-- If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] -/ -def IOrdered (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := - ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → - r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) = true - ∨ r (as[j]'hjs) (as[i]'(Nat.lt_trans hij hjs)) = false +abbrev IOrdered (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := + IPairwise (le_of_any_b (r · ·)) low high as namespace IOrdered theorem mkSingle (lt : α → α → Bool) (k: Nat) (as: Array α): From 90406929a609c082679b67e8a448180a62450f59 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 15:07:19 +0000 Subject: [PATCH 23/54] start, first part of rel work --- src/Init/Data/Array/QSort.lean | 77 ++++++++++++++++++---------------- 1 file changed, 41 insertions(+), 36 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index ba0cce35edba..8d3b9d642ac1 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -406,7 +406,6 @@ structure IsMultiTrans {α} (r: α → α → Prop) where If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] -/ -abbrev le_of_any (r: α → α → Prop) (i j: α):= r i j ∨ ¬r j i abbrev le_of_any_b (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false def IPairwise (r: α → α → Prop) (low: Nat) (high: Nat) (as: Array α) := @@ -420,10 +419,10 @@ If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] abbrev IOrdered (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := IPairwise (le_of_any_b (r · ·)) low high as -namespace IOrdered -theorem mkSingle (lt : α → α → Bool) (k: Nat) (as: Array α): - IOrdered lt k k as := by - unfold IOrdered +namespace IPairwise +theorem mkSingle (r : α → α → Prop) (k: Nat) (as: Array α): + IPairwise r k k as := by + unfold IPairwise intro i j hli hij hjl hjs exfalso have hkk: k < k := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjl) @@ -431,14 +430,14 @@ theorem mkSingle (lt : α → α → Bool) (k: Nat) (as: Array α): theorem restrict {low high: Nat} {low' high': Nat} (hll: low ≤ low') (hhh: high' ≤ high) {as: Array α} - (p: IOrdered lt low high as): IOrdered lt low' high' as := by - unfold IOrdered + (p: IPairwise r low high as): IPairwise r low' high' as := by + unfold IPairwise intro i j hli hij hjl hjs exact p i j (Nat.le_trans hll hli) hij (Nat.le_trans hjl hhh) hjs -theorem resize_out_of_bounds (h: IOrdered lt low high as) (hsh: (as.size - 1) ≤ high): - IOrdered lt low high' as := by - unfold IOrdered +theorem resize_out_of_bounds (h: IPairwise r low high as) (hsh: (as.size - 1) ≤ high): + IPairwise r low high' as := by + unfold IPairwise intro i j hli hij _ hjs have hjh: j ≤ high := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh exact h i j hli hij hjh hjs @@ -446,8 +445,8 @@ theorem resize_out_of_bounds (h: IOrdered lt low high as) (hsh: (as.size - 1) /-- can use IPerm.expand if the endpoints don't match --/ theorem transport_lower {low high : Nat} {as as' : Array α} (hp : IPerm (low + 1) high as as') - (h : as.IOrdered lt begin low): - as'.IOrdered lt begin low := by + (h : as.IPairwise r begin low): + as'.IPairwise r begin low := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) @@ -467,14 +466,14 @@ induction hp with · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hlj)) theorem glue - {lt : α → α → Bool} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} - (ha : as.IForAll (fun x => lt pivot x = false) low (i + 1)) - (hb : as.IForAll (fun x => lt x pivot = false) (i + 1) (high + 1)) - (hlttr : IsTrans fun x x_1 => lt x x_1 = false) - (h1 : IOrdered lt low i as) - (h2 : IOrdered lt (i + 1) high as): - IOrdered lt low high as := by - unfold IOrdered + {r : α → α → Prop} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} + (ha : as.IForAll (r · pivot) low (i + 1)) + (hb : as.IForAll (r pivot ·) (i + 1) (high + 1)) + (hlttr : IsTrans r) + (h1 : IPairwise r low i as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + unfold IPairwise intro a b hla hab hbh hbs have has := Nat.lt_trans hab hbs @@ -488,10 +487,9 @@ theorem glue have hai: a < i + 1 := by exact Nat.gt_of_not_le hia specialize ha a has hla hai specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) - right - exact hlttr hb ha + exact hlttr ha hb -end IOrdered +end IPairwise abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as.size) (hks: k < as.size): α := (as.swap ⟨i, his⟩ ⟨j, hjs⟩)[k]'( @@ -513,7 +511,7 @@ structure ISortOf (lt: α → α → Bool) (low high: Nat) (orig: Array α) (sor namespace ISortOf theorem mkSingle (lt : α → α → Bool) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): - ISortOf lt k k as0 as := ⟨hp, IOrdered.mkSingle lt k as⟩ + ISortOf lt k k as0 as := ⟨hp, .mkSingle (le_of_any_b lt) k as⟩ theorem trans {lt: α → α → Bool} {low high: Nat} {as as' as'': Array α} (hp: IPerm low high as as') (hs: ISortOf lt low high as' as''): @@ -532,9 +530,9 @@ end ISortOf mutual theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hli : low ≤ i) (hih : i < high) (hhs : high < as.size) - (ha: IForAll as (lt pivot · = false) low (i + 1)) - (hb: IForAll as (lt · pivot = false) (i + 1) (high + 1)) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + (ha: IForAll as ((le_of_any_b lt) · pivot) low (i + 1)) + (hb: IForAll as ((le_of_any_b lt) pivot ·) (i + 1) (high + 1)) + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): have ⟨as', hs'⟩ := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) ISortOf lt low high as (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by @@ -550,14 +548,14 @@ mutual · apply IPerm.expand (Nat.le_add_right_of_le hli) (Nat.le_refl _) h2.perm case ord => - apply IOrdered.glue + apply IPairwise.glue case hlttr => exact hlttr case pivot => exact pivot case i => exact i case ha => exact (ha.transport_in h1.perm).transport_lower h2.perm case hb => exact (hb.transport_higher h1.perm).transport_in h2.perm case h1 => - apply IOrdered.transport_lower + apply IPairwise.transport_lower case hp => exact h2.perm case h => exact h1.ord case h2 => exact h2.ord @@ -569,7 +567,7 @@ mutual (ha: IForAll as (lt · pivot) low i) (hb: IForAll as (lt · pivot = false) i j) (hc: IForAll as (lt · pivot) low high → low = high) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): ISortOf lt low high as (qsort.sort.loop lt low high pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop @@ -647,13 +645,20 @@ mutual apply qsort.sort_sort_sorts case hhs => simpa [size_swap] case ha => - let ha := ha.map (λ x a ↦ eq_false_of_ne_true (hltas a)) + let ha: as.IForAll (le_of_any_b lt · pivot) low i := ha.map (λ x a ↦ by + right + exact eq_false_of_ne_true (hltas a)) - have hhh: lt as[high] as[high] = false := by + have hhh: (le_of_any_b lt) as[high] as[high] := by + right exact eq_false_of_ne_true fun a => hltas a a exact (hph ▸ ha).swap_left hij hhh - case hb => exact (hph ▸ hb).swap_right hij hhs + case hb => + let hb: as.IForAll (le_of_any_b lt pivot ·) i high := hb.map (λ x a ↦ by + right + exact a) + exact (hph ▸ hb).swap_right hij hhs case hltas => exact hltas case hlttr => exact hlttr case hli => exact hli @@ -666,7 +671,7 @@ mutual theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) --(hltas: lt as[mid] as[high] = true → lt as[high] as[mid] = true → False) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): let as' := if lt (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] @@ -718,7 +723,7 @@ mutual (hhs: low < high → high < as.size) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): ISortOf lt low high as (qsort.sort lt as low high hhs) := by unfold qsort.sort by_cases hlh: low ≥ high @@ -763,7 +768,7 @@ mutual end theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (lt · · = false)): + (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): ISortOf lt low high as (qsort as lt low high) := by unfold qsort split From 3707d3f42a204e24385181be229692d355f87d91 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 15:38:36 +0000 Subject: [PATCH 24/54] rel work --- src/Init/Data/Array/QSort.lean | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 8d3b9d642ac1..c31c22b2fa18 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -408,6 +408,13 @@ structure IsMultiTrans {α} (r: α → α → Prop) where -/ abbrev le_of_any_b (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false +def le_of_any_b_refl (r: α → α → Bool) (x: α): (le_of_any_b r) x x := by + by_cases h: r x x + · left + exact h + · right + exact eq_false_of_ne_true h + def IPairwise (r: α → α → Prop) (low: Nat) (high: Nat) (as: Array α) := ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) @@ -646,14 +653,10 @@ mutual case hhs => simpa [size_swap] case ha => let ha: as.IForAll (le_of_any_b lt · pivot) low i := ha.map (λ x a ↦ by - right - exact eq_false_of_ne_true (hltas a)) - - have hhh: (le_of_any_b lt) as[high] as[high] := by - right - exact eq_false_of_ne_true fun a => hltas a a + left + exact a) - exact (hph ▸ ha).swap_left hij hhh + exact (hph ▸ ha).swap_left hij (le_of_any_b_refl lt _) case hb => let hb: as.IForAll (le_of_any_b lt pivot ·) i high := hb.map (λ x a ↦ by right From f552bf17d3d6be229c47e845a534af710bb294ed Mon Sep 17 00:00:00 2001 From: lyphyser Date: Mon, 16 Sep 2024 21:34:26 +0000 Subject: [PATCH 25/54] new algorithm compiles --- src/Init/Data/Array/QSort.lean | 467 ++++++++++++++++++++------------- 1 file changed, 280 insertions(+), 187 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index c31c22b2fa18..3c2cae311097 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -8,6 +8,7 @@ import Init.Data.Array.Basic import Init.Data.Array.Lemmas import Init.Data.Nat.Mod +namespace Array @[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): (if P then a else b).size = (if P then a.size else b.size) := by split @@ -18,6 +19,17 @@ import Init.Data.Nat.Mod split all_goals rfl +theorem set_getElem_eq {as: Array α} {his: i < as.size} {his': i < as.size}: as.set ⟨i, his⟩ (as[i]'his') = as := by + apply Array.ext + · simp only [size_set] + · intro k _ _ + rw [getElem_set] + split + all_goals + try subst k + simp only +end Array + namespace Nat @[simp] theorem left_lt_add_div_two: n < (n + m) / 2 ↔ n + 1 < m := by rw [← succ_le, @@ -86,12 +98,13 @@ namespace Array -- invariant: lo ≤ k < i → lt as[i] pivot, i ≤ k < j -> ¬lt as[i] pivot let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): {as': Array α // as'.size = as.size}:= + have _hlh := hlh let s := as.size have hs: as.size = s := rfl have his: i < s := Nat.lt_of_le_of_lt hij (Nat.lt_of_le_of_lt hjh hhs) - if hjh : j < high then - have hjs: j < s := Nat.lt_trans hjh hhs + if hjh' : j < high then + have hjs: j < s := Nat.lt_trans hjh' hhs if lt (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ @@ -100,31 +113,23 @@ namespace Array have hij: i + 1 ≤ j + 1 := Nat.add_le_add_right hij 1 have hli: low ≤ i + 1 := Nat.le_add_right_of_le hli - let ⟨as, hs'⟩ := loop as (i+1) (j+1) hli hij hjh (hs ▸ hhs) + let ⟨as, hs'⟩ := loop as (i+1) (j+1) hli hij hjh' (hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ else have hij: i ≤ j + 1 := Nat.le_add_right_of_le hij - let ⟨as, hs'⟩ := loop as i (j+1) hli hij hjh (hs ▸ hhs) + let ⟨as, hs'⟩ := loop as i (j+1) hli hij hjh' (hs ▸ hhs) have hs: as.size = s := by rw [← hs, hs'] ⟨as, hs⟩ - else if i >= high then - -- this can only happen if low == high assuming lt is antisymmetric - -- that's because i == j == high implies that all k in [low, high) are less than the pivot as[high] - -- in particular, this means that if mid != high, as[mid] is less than as[high], which is impossible, - -- because we swap them in that case, so that a[mid] >= a[high] - -- hence, mid = high, which implies (low + high) / 2 = high, which implies that low = high or - -- low = high + 1, the latter of which is impossible because low <= high; hence, low == high - - ⟨as, hs⟩ else let as := as.swap ⟨i, hs ▸ his⟩ ⟨high, hs ▸ hhs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] - let ⟨as, hs'⟩ := sort as low i (λ _ ↦ hs ▸ his) + have hi1s: i - 1 < s := Nat.lt_of_le_of_lt (Nat.sub_le i 1) his + let ⟨as, hs'⟩ := sort as low (i - 1) (λ _ ↦ hs ▸ hi1s) have hs: as.size = s := by rw [← hs, hs'] let ⟨as, hs'⟩ := sort as (i+1) high (λ _ ↦ hs ▸ hhs) @@ -151,7 +156,7 @@ namespace Array (sort as low (if high < as.size then high else as.size - 1) hhs).1 -@[simp] theorem size_qsort.sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) +@[simp] theorem qsort.size_sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size): (qsort.sort lt as low high hhs).1.size = as.size := by exact (qsort.sort lt as low high hhs).2 @@ -189,8 +194,8 @@ theorem trans_swap {as0 as: Array α} (hp: IPerm low high as0 as) (i: Nat) (his: theorem expand {α} {low high: Nat} {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} - (p: IPerm low high as as'): IPerm low' high' as as' := by - induction p with + (hp: IPerm low high as as'): IPerm low' high' as as' := by + induction hp with | refl => exact refl | trans _ _ ih ih' => exact trans ih ih' | swap as i his hli hih j hjs hlj hjh => @@ -198,16 +203,41 @@ theorem expand {α} {low high: Nat} i his (Nat.le_trans hll hli) (Nat.le_trans hih hhh) j hjs (Nat.le_trans hll hlj) (Nat.le_trans hjh hhh) +theorem expand_up {α} {low high: Nat} {as: Array α} {as': Array α} (hhh: high ≤ high') + (hp: IPerm low high as as'): IPerm low high' as as' := + hp.expand (Nat.le_refl _) hhh + +theorem expand_down {α} {low high: Nat} {as: Array α} {as': Array α} (hll: low' ≤ low) + (hp: IPerm low high as as'): IPerm low' high as as' := + hp.expand hll (Nat.le_refl _) + theorem size_eq {α} {as: Array α} {as': Array α} {low high: Nat} - (p: IPerm low high as as' ): as.size = as'.size := by - induction p with + (hp: IPerm low high as as' ): as.size = as'.size := by + induction hp with | refl => rfl | trans _ _ ih ih' => rwa [ih'] at ih | swap => simp only [size_swap] -theorem resize_out_of_bounds (p: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): +theorem eq_of_trivial (hp: IPerm k k as as' ): as = as' := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rw [ih, ih'] + | swap as i his hli hih j hjs hlj hjh => + have hik: i = k := Nat.le_antisymm hih hli + have hjk: j = k := Nat.le_antisymm hjh hlj + subst i j + rw [swap_def] + simp + rw [set_getElem_eq] + + + + + + +theorem resize_out_of_bounds (hp: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): IPerm low high' as0 as := by - induction p with + induction hp with | refl => exact refl | trans p' _ ih ih' => exact trans (ih hsh') (ih' (p'.size_eq ▸ hsh')) | swap as i his hli _ j hjs hlj _ => @@ -217,9 +247,8 @@ theorem resize_out_of_bounds (p: IPerm low high as0 as) (hsh': (as0.size - 1) i his hli hih' j hjs hlj hjh' -def getElem?_lower {α: Type u} {as: Array α} {as': Array α} {low high: Nat} (hkl: k < low) - (p: IPerm low high as as'): as[k]? = as'[k]? := by - induction p with +def getElem?_lower (hp: IPerm low high as as') (hkl: k < low): as[k]? = as'[k]? := by + induction hp with | refl => rfl | trans _ _ ih ih' => rwa [ih'] at ih | swap _ _ _ hli _ _ _ hlj _ => @@ -229,9 +258,8 @@ def getElem?_lower {α: Type u} {as: Array α} {as': Array α} {low high: Nat} ( · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) -def getElem?_higher {α: Type u} {as: Array α} {as': Array α} {low high: Nat} (hhk: high < k) - (p: IPerm low high as as'): as[k]? = as'[k]? := by - induction p with +def getElem?_higher (hp: IPerm low high as as') (hhk: high < k): as[k]? = as'[k]? := by + induction hp with | refl => rfl | trans _ _ ih ih' => rwa [ih'] at ih | swap _ _ _ _ hih _ _ _ hjh => @@ -240,6 +268,19 @@ def getElem?_higher {α: Type u} {as: Array α} {as': Array α} {low high: Nat} rw [getElem?_set_ne] · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) + +def getElem_lower (hp: IPerm low high as as') (hkl: k < low) + {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by + apply Option.some_inj.mp + simp only [← getElem?_lt] + apply hp.getElem?_lower hkl + +def getElem_higher (hp: IPerm low high as as') (hhk: high < k) + {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by + apply Option.some_inj.mp + simp only [← getElem?_lt] + apply hp.getElem?_higher hhk + end IPerm def IForAll (as: Array α) (P: α → Prop) (low high: Nat) := @@ -255,6 +296,12 @@ theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as P low high) (f: (a specialize ha k hks hlk hkh exact f as[k] ha +theorem restrict (ha: IForAll as P low high) + (hll: low ≤ low') (hhh: high' ≤ high) + : IForAll as P low' high' := by + intro k hks hlk' hkh' + exact ha k hks (Nat.le_trans hll hlk') (Nat.le_trans hkh' hhh) + theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) (ha: IForAll as P low i): @@ -263,8 +310,7 @@ theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} rw [size_swap] at hks simp only [swap_def] by_cases hki: k < i - · rw [getElem_set_ne] - rw [getElem_set_ne] + · rw [getElem_set_ne, getElem_set_ne] exact ha k hks hlk hki · exact Ne.symm (Nat.ne_of_lt hki) · have hkj: k < j := Nat.lt_of_lt_of_le hki hij @@ -273,11 +319,9 @@ theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} subst k by_cases hij: i = j · subst i - simp only [get_eq_getElem, getElem_set_eq] + simp only [getElem_set_eq] exact hjp - rw [getElem_set_ne] - rw [getElem_set_eq] - simp only [get_eq_getElem] + rw [getElem_set_ne, getElem_set_eq] exact hjp · rfl · intro h @@ -290,15 +334,14 @@ theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hj rw [size_swap] at hks simp only [swap_def] by_cases hkj: k < j - · rw [getElem_set_ne] - rw [getElem_set_ne] + · rw [getElem_set_ne, getElem_set_ne] have hik: i ≤ k := Nat.le_of_succ_le hi1x exact hb k hks hik hkj · exact Nat.ne_of_lt hi1x · exact Ne.symm (Nat.ne_of_lt hkj) · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj subst k - simp only [get_eq_getElem, getElem_set_eq] + simp only [getElem_set_eq] exact hb i (Nat.lt_trans hi1x hjs) (Nat.le_refl i) hi1x theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} @@ -327,67 +370,68 @@ theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low · exact Ne.symm hki · exact Ne.symm hkj -/-- can use IPerm.expand if the sizes don't match --/ -theorem transport_in {low high : Nat} {as as' : Array α} - (hp : IPerm low high as as') - (h : as.IForAll P low (high + 1)): - as'.IForAll P low (high + 1) := by +theorem transport_enclosing {low high : Nat} {as as' : Array α} + (h : as.IForAll P low high) + (hp : IPerm plow phigh as as') + (hll: low ≤ plow) + (hhh: phigh < high): + as'.IForAll P low high := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) - | swap as i his hli hih j hjs hlj hjh => + | swap as i his hpli hiph j hjs hplj hjph => intro k hks hlk hkh simp [swap_def] rw [getElem_set] rw [getElem_set] split - · exact h i his hli (Nat.lt_add_one_of_le hih) + · exact h i his (Nat.le_trans hll hpli) (Nat.lt_of_le_of_lt hiph hhh) · split - · exact h j hjs hlj (Nat.lt_add_one_of_le hjh) + · exact h j hjs (Nat.le_trans hll hplj) (Nat.lt_of_le_of_lt hjph hhh) · simp [size_swap] at hks exact h k hks hlk hkh -/-- can use IPerm.expand if the endpoints don't match --/ -theorem transport_lower {low high : Nat} {as as' : Array α} - (hp : IPerm low high as as') - (h : as.IForAll P begin low): - as'.IForAll P begin low := by +theorem transport_outside {low high : Nat} {as as' : Array α} + (h : as.IForAll P low high) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k < high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + as'.IForAll P low high := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) -| swap as i his hli _ j hjs hlj _ => - intro k hks hbk hkl +| swap as i his hli hih j hjs hlj hjh => + intro k hks hlk hkh simp [swap_def] - rw [getElem_set_ne] - rw [getElem_set_ne] + repeat rw [getElem_set_ne] · simp [size_swap] at hks - exact h k hks hbk hkl - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) + exact h k hks hlk hkh + all_goals + intro he + simp only at he + subst k + · exact hd i hlk hkh hli hih + · exact hd j hlk hkh hlj hjh + +theorem transport_lower {low high : Nat} {as as' : Array α} + (h : as.IForAll P low high) + (hp : IPerm plow phigh as as') + (hd: high ≤ plow): + as'.IForAll P low high := by + apply h.transport_outside hp + intro k _ hkh hplk _ + exact Nat.not_le.mpr (Nat.lt_of_le_of_lt hplk hkh) hd -/-- can use IPerm.expand if the endpoints don't match --/ theorem transport_higher {low high : Nat} {as as' : Array α} - (hp : IPerm low high as as') - (h : as.IForAll P (high + 1) ends): - as'.IForAll P (high + 1) ends := by -induction hp with -| refl => exact h -| trans _ _ ih ih' => exact ih' (ih h) -| swap as i his _ hih j hjs _ hjh => - intro k hks hhk hke - simp [swap_def] - rw [getElem_set_ne] - rw [getElem_set_ne] - · simp [size_swap] at hks - exact h k hks hhk hke - · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) - · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) + (h : as.IForAll P low high) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + as'.IForAll P low high := by + apply h.transport_outside hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd end IForAll -def IsAsymm {α} (r: α → α → Prop) := - {x: α} → {y: α} → r x y → r y x → False - def IsTrans {α} (r: α → α → Prop) := {x: α} → {y: α} → {z: α} → r x y → r y z → r x z @@ -401,7 +445,6 @@ structure IsMultiTrans {α} (r: α → α → Prop) where n_of_pn: {x: α} → {y: α} → {z: α} → r y x → ¬r y z → ¬r x z -/ - /-- If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] @@ -449,30 +492,49 @@ theorem resize_out_of_bounds (h: IPairwise r low high as) (hsh: (as.size - 1) have hjh: j ≤ high := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh exact h i j hli hij hjh hjs -/-- can use IPerm.expand if the endpoints don't match --/ -theorem transport_lower {low high : Nat} {as as' : Array α} - (hp : IPerm (low + 1) high as as') - (h : as.IPairwise r begin low): - as'.IPairwise r begin low := by +theorem transport_outside + (h : as.IPairwise r low high) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k ≤ high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + as'.IPairwise r low high := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) -| swap as i his hli _ j hjs hlj _ => +| swap as i his hli hih j hjs hlj hjh => intro a b hla hab hbl hbs have hal := Nat.lt_of_lt_of_le hab hbl simp [swap_def] - rw [getElem_set_ne] - rw [getElem_set_ne] - rw [getElem_set_ne] - rw [getElem_set_ne] + repeat rw [getElem_set_ne] · simp [size_swap] at hbs exact h a b hla hab hbl hbs - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hli)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_le_of_lt hbl hlj)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hli)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_trans hal hlj)) - -theorem glue + all_goals + intro he + simp only at he + subst_eqs + · exact hd i (Nat.le_trans hla (Nat.le_of_lt hab)) hbl hli hih + · exact hd j (Nat.le_trans hla (Nat.le_of_lt hab)) hbl hlj hjh + · exact hd i hla (Nat.le_of_lt hal) hli hih + · exact hd j hla (Nat.le_of_lt hal) hlj hjh + +theorem transport_lower + (h : as.IPairwise r low high) + (hp : IPerm plow phigh as as') + (hd: high < plow): + as'.IPairwise r low high := by + apply h.transport_outside hp + intro k _ hkh hplk _ + exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd + +theorem transport_higher + (h : as.IPairwise r low high) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + as'.IPairwise r low high := by + apply h.transport_outside hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd + +theorem glue_with_pivot {r : α → α → Prop} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} (ha : as.IForAll (r · pivot) low (i + 1)) (hb : as.IForAll (r pivot ·) (i + 1) (high + 1)) @@ -496,6 +558,55 @@ theorem glue specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) exact hlttr ha hb +theorem glue_with_middle + {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} + (his: i < as.size) + (ha : as.IForAll (r · (as[i]'his)) low i) + (hb : as.IForAll (r (as[i]'his) ·) (i + 1) (high + 1)) + (hlttr : IsTrans r) + (h1 : IPairwise r low (i - 1) as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + unfold IPairwise + intro a b hla hab hbh hbs + have has := Nat.lt_trans hab hbs + + by_cases hbi: b < i + · exact h1 a b hla hab (Nat.le_sub_one_of_lt hbi) hbs + + have hib: i ≤ b := Nat.le_of_not_lt hbi + by_cases hia: i < a + · exact h2 a b hia hab hbh hbs + + have hai: a ≤ i := by exact Nat.le_of_not_lt hia + + have ha: a < i → r as[a] (as[i]'his) := λ hai' ↦ ha a has hla hai' + have hb: i < b → r (as[i]'his) as[b] := λ hib' ↦ hb b hbs hib' (Nat.lt_add_one_of_le hbh) + + by_cases hai': a < i + · by_cases hib': i < b + · exact hlttr (ha hai') (hb hib') + · have hib: i = b := by exact Nat.le_antisymm hib (Nat.le_of_not_lt hib') + subst b + exact (ha hai') + · have hai: a = i := by exact Nat.le_antisymm hai (Nat.le_of_not_lt hai') + subst a + exact (hb hab) + +theorem glue_with_middle_eq_pivot + {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} + (his: i < as.size) + (hpi: as[i]'his = pivot) + (ha : as.IForAll (r · pivot) low i) + (hb : as.IForAll (r pivot ·) (i + 1) (high + 1)) + (hlttr : IsTrans r) + (h1 : IPairwise r low (i - 1) as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + subst pivot + apply glue_with_middle + all_goals assumption + end IPairwise abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as.size) (hks: k < as.size): α := @@ -536,53 +647,82 @@ end ISortOf mutual theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) - (hli : low ≤ i) (hih : i < high) (hhs : high < as.size) + (hlh: low < high) (hli : low ≤ i) (hih : i ≤ high) (hhs : high < as.size) + (hpi: as[i]'(Nat.lt_of_le_of_lt hih hhs) = pivot) (ha: IForAll as ((le_of_any_b lt) · pivot) low (i + 1)) (hb: IForAll as ((le_of_any_b lt) pivot ·) (i + 1) (high + 1)) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): - have ⟨as', hs'⟩ := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) + (hlttr: IsTrans (le_of_any_b lt)): + have ⟨as', hs'⟩ := qsort.sort lt as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) ISortOf lt low high as (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by + have his := Nat.lt_of_le_of_lt hih hhs + have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih + have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs - have h1 := qsort.sort_sorts as lt low i (λ _ ↦ Nat.lt_trans hih hhs) hltas hlttr - let ahs' := qsort.sort lt as low i (λ _ ↦ Nat.lt_trans hih hhs) + have h1 := qsort.sort_sorts as lt low (i - 1) (λ _ ↦ h1is) hlttr + let ahs' := qsort.sort lt as low (i - 1) (λ _ ↦ h1is) let as' := ahs'.1 let hs' := ahs'.2 - have h2 := qsort.sort_sorts as' lt (i + 1) high (λ _ ↦ hs' ▸ hhs) hltas hlttr + have h2 := qsort.sort_sorts as' lt (i + 1) high (λ _ ↦ hs' ▸ hhs) hlttr + constructor case perm => apply IPerm.trans - · apply IPerm.expand (Nat.le_refl _) (Nat.le_of_lt hih) h1.perm + · apply IPerm.expand (Nat.le_refl _) h1ih h1.perm · apply IPerm.expand (Nat.le_add_right_of_le hli) (Nat.le_refl _) h2.perm case ord => - apply IPairwise.glue + apply IPairwise.glue_with_middle_eq_pivot case hlttr => exact hlttr - case pivot => exact pivot case i => exact i - case ha => exact (ha.transport_in h1.perm).transport_lower h2.perm - case hb => exact (hb.transport_higher h1.perm).transport_in h2.perm + case his => simpa [qsort.size_sort] + case ha => + --have foo: i ≤ i + 1 := by exact Nat.le_add_right i 1 + --have huh: i - 1 + 1 = i := by apply? + apply ((ha.transport_enclosing h1.perm ?_ ?_).transport_lower h2.perm ?_).restrict ?_ ?_ + · exact Nat.le_refl _ + · exact Nat.sub_lt_succ i 1 + · exact Nat.le_refl (i + 1) + · exact Nat.le_refl low + · exact Nat.le_add_right i 1 + case hb => + apply (hb.transport_higher h1.perm ?_).transport_enclosing h2.perm ?_ ?_ + · exact Nat.sub_lt_succ i 1 + · exact Nat.le_refl _ + · exact Nat.lt_add_one high + case hpi => + subst pivot + simp only [as', ahs'] at h2 -- needed? + + by_cases h0i: 0 < i + · rw [h1.perm.getElem_higher] + rw [h2.perm.getElem_lower] + · exact Nat.lt_add_one i + · exact Nat.lt_of_lt_of_eq his hs'.symm + · exact Nat.sub_one_lt_of_lt h0i + · have h0i: i = 0 := by exact Nat.eq_zero_of_not_pos h0i + subst i + have: low = 0 := by exact Nat.eq_zero_of_le_zero hli + subst low + simp + rw [h1.perm.getElem_empty] case h1 => - apply IPairwise.transport_lower - case hp => exact h2.perm - case h => exact h1.ord + apply h1.ord.transport_lower h2.perm (Nat.sub_lt_succ i 1) case h2 => exact h2.ord termination_by (high - low, 0, 0) - theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (as: Array α) + theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) {pivot : α} (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) (ha: IForAll as (lt · pivot) low i) (hb: IForAll as (lt · pivot = false) i j) - (hc: IForAll as (lt · pivot) low high → low = high) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): - ISortOf lt low high as (qsort.sort.loop lt low high pivot as i j hli hij hjh hhs) := by + (hlttr: IsTrans (le_of_any_b lt)): + ISortOf lt low high as (qsort.sort.loop lt low high hlh pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs have his: i < as.size := Nat.lt_of_le_of_lt hij hjs have hih: i ≤ high := Nat.le_trans hij hjh have hlj: low ≤ j := Nat.le_trans hli hij - have hlh: low ≤ high := Nat.le_trans hli hih by_cases hjh': j < high all_goals simp only [hjh', ↓reduceDIte] @@ -599,8 +739,6 @@ mutual case hph => simpa only [getElem_after_swap hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs - case hc => intro h; apply hc; exact h.of_swap hli hij hjh' - case hltas => exact hltas case hlttr => exact hlttr case hp => exact .swap as i his hli hih j hjs hlj hjh @@ -621,65 +759,43 @@ mutual subst k exact eq_false_of_ne_true hjp - case hc => - exact hc - - case hltas => exact hltas case hlttr => exact hlttr case hp => exact .refl case neg => have hjh: j = high := Nat.le_antisymm hjh (Nat.le_of_not_lt hjh') subst j - by_cases hhi: i ≥ high - all_goals simp only [hhi, ↓reduceDIte] - - case pos => - have hih: i ≤ high := Nat.le_trans hij hjh - have hi: i = high := Nat.le_antisymm hih hhi - subst i - suffices h: low = high by - subst high - apply ISortOf.mkSingle - exact .refl - - apply hc - exact ha - - case neg => - apply ISortOf.trans - case hs => - apply qsort.sort_sort_sorts - case hhs => simpa [size_swap] - case ha => - let ha: as.IForAll (le_of_any_b lt · pivot) low i := ha.map (λ x a ↦ by - left - exact a) - - exact (hph ▸ ha).swap_left hij (le_of_any_b_refl lt _) - case hb => - let hb: as.IForAll (le_of_any_b lt pivot ·) i high := hb.map (λ x a ↦ by - right - exact a) - exact (hph ▸ hb).swap_right hij hhs - case hltas => exact hltas - case hlttr => exact hlttr - case hli => exact hli - case hih => exact Nat.gt_of_not_le hhi - case hp => - exact IPerm.swap as i his hli hih high hhs hlh (Nat.le_refl _) - - termination_by (high - low, 1, high - j) - - theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (as: Array α) + apply ISortOf.trans + case hs => + apply qsort.sort_sort_sorts + case hhs => simpa [size_swap] + case ha => + let ha: as.IForAll (le_of_any_b lt · pivot) low i := ha.map (λ x a ↦ by + left + exact a) + + exact (hph ▸ ha).swap_left hij (le_of_any_b_refl lt _) + case hb => + let hb: as.IForAll (le_of_any_b lt pivot ·) i high := hb.map (λ x a ↦ by + right + exact a) + exact (hph ▸ hb).swap_right hij hhs + case hlttr => exact hlttr + case hli => exact hli + case hih => exact hih + case hlh => exact hlh + case hp => + exact IPerm.swap as i his hli hih high hhs (Nat.le_of_lt hlh) (Nat.le_refl _) + termination_by (high - low, 1, high - j) + + theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) - --(hltas: lt as[mid] as[high] = true → lt as[high] as[mid] = true → False) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): + (hlttr: IsTrans (le_of_any_b lt)): let as' := if lt (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] - ISortOf lt low high as (qsort.sort.loop lt low high (as'[high]'(hs' ▸ hhs)) as' low low + ISortOf lt low high as (qsort.sort.loop lt low high hlh (as'[high]'(hs' ▸ hhs)) as' low low (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by have hms := Nat.lt_trans hmh hhs have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) @@ -688,26 +804,7 @@ mutual apply ISortOf.trans case hs => apply qsort.sort_loop_sorts - case hc => - intro h - simp only [IForAll, size_ite, size_swap, ite_self] at h - specialize h mid hms hlm hmh - simp [swap_def] at h - split at h - case isTrue h' => - rw [getElem_set_ne] at h - rw [getElem_set_eq] at h - rw [getElem_set_eq] at h - exfalso - exact hltas h' h - · rfl - · rfl - · exact Ne.symm hmh' - case isFalse h' => - exfalso - exact h' h case hph => rfl - case hltas => exact hltas case hlttr => exact hlttr all_goals intro k hks hlk hkl @@ -725,8 +822,7 @@ mutual theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother - --(hltas: {i: Nat} → (hli: low ≤ i) → (hih: i ≤ high) → {j: Nat} → (hlj: low ≤ j) → (hjh: j ≤ high) → lt as[i] as[j] = true → lt as[j] as[i] = true → False): - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): + (hlttr: IsTrans (le_of_any_b lt)): ISortOf lt low high as (qsort.sort lt as low high hhs) := by unfold qsort.sort by_cases hlh: low ≥ high @@ -754,7 +850,6 @@ mutual case hlm => exact Nat.left_le_add_div_two.mpr hlh' case hmh => exact Nat.add_div_two_lt_right.mpr hlh - case hltas => exact hltas case hlttr => exact hlttr case hp => @@ -771,20 +866,18 @@ mutual end theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hltas: IsAsymm (lt · ·)) (hlttr: IsTrans (le_of_any_b lt)): + (hlttr: IsTrans (le_of_any_b lt)): ISortOf lt low high as (qsort as lt low high) := by unfold qsort split case isTrue => apply qsort.sort_sorts - · exact hltas · exact hlttr case isFalse h => apply ISortOf.resize_out_of_bounds · apply qsort.sort_sorts - · exact hltas · exact hlttr - · simp only [size_qsort.sort, Nat.le_refl] + · simp only [qsort.size_sort, Nat.le_refl] · apply Nat.sub_le_of_le_add exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) From 5f212f74ee6fad9594e72e8fb05772ef81567089 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 00:49:27 +0000 Subject: [PATCH 26/54] ITransLeB compiles!!! --- src/Init/Data/Array/QSort.lean | 560 +++++++++++++++++++++++---------- 1 file changed, 396 insertions(+), 164 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 3c2cae311097..4e6bf4688efe 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -19,7 +19,7 @@ namespace Array split all_goals rfl -theorem set_getElem_eq {as: Array α} {his: i < as.size} {his': i < as.size}: as.set ⟨i, his⟩ (as[i]'his') = as := by +@[simp] theorem set_getElem_eq {as: Array α} {his: i < as.size} {his': i < as.size}: as.set ⟨i, his⟩ (as[i]'his') = as := by apply Array.ext · simp only [size_set] · intro k _ _ @@ -64,7 +64,7 @@ end Nat namespace Array -@[inline] def qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := +@[inline] def qsort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := let s := as.size @@ -85,18 +85,18 @@ namespace Array have hmh: mid ≤ high := Nat.add_div_two_le_right_of_le (Nat.le_of_lt hlh) have hms: mid < s := Nat.lt_of_le_of_lt hmh hhs - let as := if lt (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as + let as := if r (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let as := if lt (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as + let as := if r (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let as := if lt (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as + let as := if r (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] let pivot := as[high]'(hs ▸ hhs) - -- invariant: lo ≤ k < i → lt as[i] pivot, i ≤ k < j -> ¬lt as[i] pivot + -- invariant: lo ≤ k < i → r as[i] pivot, i ≤ k < j -> ¬lt as[i] pivot let rec @[specialize] loop (as : Array α) (i j : Nat) (hli: low ≤ i) (hij: i ≤ j) (hjh: j ≤ high) (hhs: high < as.size): {as': Array α // as'.size = as.size}:= have _hlh := hlh let s := as.size @@ -106,7 +106,7 @@ namespace Array if hjh' : j < high then have hjs: j < s := Nat.lt_trans hjh' hhs - if lt (as[j]'(hs ▸ hjs)) pivot then + if r (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] @@ -156,13 +156,13 @@ namespace Array (sort as low (if high < as.size then high else as.size - 1) hhs).1 -@[simp] theorem qsort.size_sort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) +@[simp] theorem qsort.size_sort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size): - (qsort.sort lt as low high hhs).1.size = as.size := by - exact (qsort.sort lt as low high hhs).2 + (qsort.sort r as low high hhs).1.size = as.size := by + exact (qsort.sort r as low high hhs).2 -@[simp] theorem size_qsort (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1): - (qsort as lt low high).size = as.size := by +@[simp] theorem size_qsort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1): + (qsort as r low high).size = as.size := by unfold qsort split all_goals exact (qsort.sort _ _ _ _ _).2 @@ -218,7 +218,7 @@ theorem size_eq {α} {as: Array α} {as': Array α} {low high: Nat} | trans _ _ ih ih' => rwa [ih'] at ih | swap => simp only [size_swap] -theorem eq_of_trivial (hp: IPerm k k as as' ): as = as' := by +theorem eq_of_singleton (hp: IPerm k k as as' ): as = as' := by induction hp with | refl => rfl | trans _ _ ih ih' => rw [ih, ih'] @@ -227,13 +227,26 @@ theorem eq_of_trivial (hp: IPerm k k as as' ): as = as' := by have hjk: j = k := Nat.le_antisymm hjh hlj subst i j rw [swap_def] - simp - rw [set_getElem_eq] - - - - - + apply Array.ext + · simp only [size_set] + · intro k _ _ + repeat rw [getElem_set] + split + all_goals + try subst k + simp only [get_eq_getElem] + +theorem eq_of_trivial (hp: IPerm low high as as' ) (h: high ≤ low): as = as' := by + by_cases h': high = low + · subst high + apply eq_of_singleton hp + · induction hp with + | refl => rfl + | trans _ _ ih ih' => rw [ih, ih'] + | swap as i his hli hih j hjs _ _ => + exfalso + have h: high < low := Nat.lt_of_le_of_ne h h' + exact Nat.not_lt.mpr (Nat.le_trans hli hih) h theorem resize_out_of_bounds (hp: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): IPerm low high' as0 as := by @@ -283,29 +296,48 @@ def getElem_higher (hp: IPerm low high as as') (hhk: high < k) end IPerm -def IForAll (as: Array α) (P: α → Prop) (low high: Nat) := +def IForAll (as: Array α) (low high: Nat) (P: α → Prop) := ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) -abbrev IForAllSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (P: α → Prop) (low high: Nat) := - IForAll (as.swap ⟨i, his⟩ ⟨j, hjs⟩) P low high +abbrev IForAllSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat)(P: α → Prop) := + IForAll (as.swap ⟨i, his⟩ ⟨j, hjs⟩) low high P + + +def ITrans {α} (as: Array α) (low high: Nat) (r: α → α → Prop) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → + r (as[i]'his) (as[j]'hjs) → r (as[j]'hjs) (as[k]'hks) → r (as[i]'his) (as[k]'hks) + + /-- + Turns a relation into one that behaves like le + If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] + If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] + -/ +abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false + +def ITransLeB {α} (as: Array α) (low high: Nat) (r: α → α → Bool) := + ITrans as low high (le_of_relation r) + +def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by + by_cases h: r x x + · left + exact h + · right + exact eq_false_of_ne_true h + namespace IForAll -theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as P low high) (f: (a: α) → P a → Q a): - IForAll as Q low high := by +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as low high P) (f: (a: α) → P a → Q a): + IForAll as low high Q := by intro k hks hlk hkh specialize ha k hks hlk hkh exact f as[k] ha -theorem restrict (ha: IForAll as P low high) - (hll: low ≤ low') (hhh: high' ≤ high) - : IForAll as P low' high' := by - intro k hks hlk' hkh' - exact ha k hks (Nat.le_trans hll hlk') (Nat.le_trans hkh' hhh) - theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) - (ha: IForAll as P low i): - IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs P low (i + 1) := by + (ha: IForAll as low i P): + IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by intro k hks hlk hki1 rw [size_swap] at hks simp only [swap_def] @@ -328,8 +360,8 @@ theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} exact hij (Eq.symm h) theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hjs: j < as.size) - (hb: IForAll as P i j): - IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs P (i + 1) (j + 1) := by + (hb: IForAll as i j P): + IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by intro k hks hi1x hkj1 rw [size_swap] at hks simp only [swap_def] @@ -346,7 +378,7 @@ theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hj theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} (h: IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs - P low high): IForAll as P low high := by + low high P): IForAll as low high P := by have his := Nat.lt_of_le_of_lt hij hjs intro k hks hlk hkh simp [IForAllSwap, IForAll, size_swap, swap_def] at h @@ -369,96 +401,263 @@ theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low rwa [getElem_set_ne] at h · exact Ne.symm hki · exact Ne.symm hkj +end IForAll + +set_option hygiene false in +macro "transport_lemmas" + α:ident + "(" T:term ")" + "(" Ts:term* ")" + "(" ub:term ")" + "(" ub':term ")" + trans:ident + not_trans:ident + intros:num : command => +`( + theorem restrict {as: Array $α} {low high low' high': Nat} (ha: $T as low high $Ts*) + (hll: low ≤ low') (hhh: high' ≤ high) + : $T as low' high' $Ts* := by + iterate $intros intro _ + apply ha + all_goals + try first + | apply Nat.le_trans hll _ + | apply Nat.le_trans _ hhh + assumption + + theorem transport_enclosing {as as': Array $α} {low high plow phigh: Nat} + (h : $T as low high $Ts*) + (hp : IPerm plow phigh as as') + (hll: low ≤ plow) + (hhh: $ub phigh high) : + $T as' low high $Ts* := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := $trans haph hhh + have hbh := $trans hbph hhh + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set] + repeat any_goals split + all_goals + apply h + all_goals assumption -theorem transport_enclosing {low high : Nat} {as as' : Array α} + theorem transport_outside {as as': Array $α} {low high plow phigh: Nat} + (h : $T as low high $Ts*) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: $ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + $T as' low high $Ts* := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as i his hli hih j hjs hlj hjh => + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set_ne] + · apply h + all_goals assumption + all_goals + intro he + subst_eqs + apply hd + all_goals assumption + + theorem transport_lower {as as': Array $α} {low high plow phigh: Nat} + (h : $T as low high $Ts*) + (hp : IPerm plow phigh as as') + (hd: $ub' high plow): + $T as' low high $Ts* := by + apply transport_outside h hp + intro k _ hkh hplk _ + exact $not_trans ($trans hplk hkh) hd + + theorem transport_higher {as as': Array $α} {low high plow phigh: Nat} + (h : $T as low high $Ts*) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + $T as' low high $Ts* := by + apply transport_outside h hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd +) + +namespace IForAll +variable {α} {P: α → Prop} +transport_lemmas α (IForAll) (P) (LT.lt) (LE.le) Nat.lt_of_le_of_lt Nat.not_le.mpr 4 +end IForAll + +namespace ITrans +variable {α} {r: α → α → Prop} + +transport_lemmas α (ITrans) (r) (LE.le) (LT.lt) Nat.le_trans Nat.not_lt.mpr 12 +end ITrans + +/- +theorem transport_lower {low high : Nat} {as as' : Array α} + (h : as.IForAll P low high) + (hp : IPerm plow phigh as as') + (hd: high ≤ plow): + as'.IForAll P low high := by + apply h.transport_outside hp + intro k _ hkh hplk _ + exact Nat.not_le.mpr (Nat.lt_of_le_of_lt hplk hkh) hd + +theorem transport_lower' {low high : Nat} {as as' : Array α} + (h : as.ITrans low high rel) + (hp : IPerm plow phigh as as') + (hd: high < plow): + as'.ITrans low high rel := by + apply transport_outside' h hp + intro k _ hkh hplk _ + exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd + +theorem transport_higher {low high : Nat} {as as' : Array α} (h : as.IForAll P low high) (hp : IPerm plow phigh as as') + (hd: phigh < low): + as'.IForAll P low high := by + apply h.transport_outside hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd + +theorem transport_higher' {low high : Nat} {as as' : Array α} + (h : as.ITrans low high rel) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + as'.ITrans low high rel := by + apply transport_outside' h hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd +-/ + +/- +theorem transport_enclosing + (h : as.IForAll low high P) + (hp : IPerm plow phigh as as') (hll: low ≤ plow) (hhh: phigh < high): - as'.IForAll P low high := by + as'.IForAll low high P := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) - | swap as i his hpli hiph j hjs hplj hjph => - intro k hks hlk hkh + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := Nat.lt_of_le_of_lt haph hhh + have hbh := Nat.lt_of_le_of_lt hbph hhh + iterate 4 intro _ simp [swap_def] - rw [getElem_set] - rw [getElem_set] - split - · exact h i his (Nat.le_trans hll hpli) (Nat.lt_of_le_of_lt hiph hhh) - · split - · exact h j hjs (Nat.le_trans hll hplj) (Nat.lt_of_le_of_lt hjph hhh) - · simp [size_swap] at hks - exact h k hks hlk hkh + repeat rw [getElem_set] + repeat any_goals split + all_goals + apply h + any_goals assumption + +theorem transport_enclosing' + (h : as.ITrans low high r) + (hp : IPerm plow phigh as as') + (hll: low ≤ plow) + (hhh: phigh ≤ high): + as'.ITrans low high r := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := Nat.le_trans haph hhh + have hbh := Nat.le_trans hbph hhh + iterate 12 intro _ + simp [swap_def] + repeat rw [getElem_set] + repeat any_goals split + all_goals + apply h + all_goals assumption theorem transport_outside {low high : Nat} {as as' : Array α} - (h : as.IForAll P low high) + (h : as.IForAll low high P) (hp : IPerm plow phigh as as') (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k < high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - as'.IForAll P low high := by + as'.IForAll low high P := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) | swap as i his hli hih j hjs hlj hjh => - intro k hks hlk hkh + iterate 4 intro _ simp [swap_def] repeat rw [getElem_set_ne] - · simp [size_swap] at hks - exact h k hks hlk hkh + · apply h + all_goals assumption all_goals intro he - simp only at he - subst k - · exact hd i hlk hkh hli hih - · exact hd j hlk hkh hlj hjh + subst_eqs + apply hd + all_goals assumption + +theorem transport_outside' + (h : as.ITrans low high r) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k ≤ high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + as'.ITrans low high r := by +induction hp with +| refl => exact h +| trans _ _ ih ih' => exact ih' (ih h) +| swap as i his hli hih j hjs hlj hjh => + iterate 12 intro _ + simp [swap_def] + repeat rw [getElem_set_ne] + · apply h + all_goals assumption + all_goals + intro he + subst_eqs + apply hd + all_goals assumption theorem transport_lower {low high : Nat} {as as' : Array α} - (h : as.IForAll P low high) + (h : as.IForAll low high P) (hp : IPerm plow phigh as as') (hd: high ≤ plow): - as'.IForAll P low high := by + as'.IForAll low high P := by apply h.transport_outside hp intro k _ hkh hplk _ exact Nat.not_le.mpr (Nat.lt_of_le_of_lt hplk hkh) hd +theorem transport_lower' {low high : Nat} {as as' : Array α} + (h : as.ITrans low high rel) + (hp : IPerm plow phigh as as') + (hd: high < plow): + as'.ITrans low high rel := by + apply transport_outside' h hp + intro k _ hkh hplk _ + exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd + theorem transport_higher {low high : Nat} {as as' : Array α} - (h : as.IForAll P low high) + (h : as.IForAll low high P) (hp : IPerm plow phigh as as') (hd: phigh < low): - as'.IForAll P low high := by + as'.IForAll low high P := by apply h.transport_outside hp intro k hlk _ _ hkph exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd -end IForAll - -def IsTrans {α} (r: α → α → Prop) := - {x: α} → {y: α} → {z: α} → r x y → r y z → r x z - -/- -structure IsMultiTrans {α} (r: α → α → Prop) where - -pos: {x: α} → {y: α} → {z: α} → r x y → r y z → r x z - neg: {x: α} → {y: α} → {z: α} → ¬r x y → ¬r y z → ¬r x z - -p_of_pn: {x: α} → {y: α} → {z: α} → r x y → ¬r z y → r x z - -p_of_np: {x: α} → {y: α} → {z: α} → ¬r y x → r y z → r x z - n_of_np: {x: α} → {y: α} → {z: α} → ¬r x y → r z y → ¬r x z - n_of_pn: {x: α} → {y: α} → {z: α} → r y x → ¬r y z → ¬r x z +theorem transport_higher' {low high : Nat} {as as' : Array α} + (h : as.ITrans low high rel) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + as'.ITrans low high rel := by + apply transport_outside' h hp + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd -/ - /-- - If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] - If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] - -/ -abbrev le_of_any_b (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false - -def le_of_any_b_refl (r: α → α → Bool) (x: α): (le_of_any_b r) x x := by - by_cases h: r x x - · left - exact h - · right - exact eq_false_of_ne_true h - -def IPairwise (r: α → α → Prop) (low: Nat) (high: Nat) (as: Array α) := +def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) @@ -466,8 +665,8 @@ def IPairwise (r: α → α → Prop) (low: Nat) (high: Nat) (as: Array α) := If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] -/ -abbrev IOrdered (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := - IPairwise (le_of_any_b (r · ·)) low high as +abbrev IPairwiseLeB (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := + IPairwise (le_of_relation (r · ·)) low high as namespace IPairwise theorem mkSingle (r : α → α → Prop) (k: Nat) (as: Array α): @@ -534,11 +733,12 @@ theorem transport_higher intro k hlk _ _ hkph exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd +/- theorem glue_with_pivot {r : α → α → Prop} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} - (ha : as.IForAll (r · pivot) low (i + 1)) - (hb : as.IForAll (r pivot ·) (i + 1) (high + 1)) - (hlttr : IsTrans r) + (ha : as.IForAll low (i + 1) (r · pivot)) + (hb : as.IForAll (i + 1) (high + 1) (r pivot ·)) + (hrtle : ITrans as low high r) (h1 : IPairwise r low i as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -556,14 +756,15 @@ theorem glue_with_pivot have hai: a < i + 1 := by exact Nat.gt_of_not_le hia specialize ha a has hla hai specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) - exact hlttr ha hb + exact hrtle ha hb +-/ theorem glue_with_middle {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} (his: i < as.size) - (ha : as.IForAll (r · (as[i]'his)) low i) - (hb : as.IForAll (r (as[i]'his) ·) (i + 1) (high + 1)) - (hlttr : IsTrans r) + (ha : as.IForAll low i (r · (as[i]'his))) + (hb : as.IForAll (i + 1) (high + 1) (r (as[i]'his) ·)) + (hrtle : ITrans as low high r) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -580,12 +781,17 @@ theorem glue_with_middle have hai: a ≤ i := by exact Nat.le_of_not_lt hia - have ha: a < i → r as[a] (as[i]'his) := λ hai' ↦ ha a has hla hai' - have hb: i < b → r (as[i]'his) as[b] := λ hib' ↦ hb b hbs hib' (Nat.lt_add_one_of_le hbh) + have ha: a < i → r (as[a]'has) (as[i]'his) := λ hai' ↦ ha a has hla hai' + have hb: i < b → r (as[i]'his) (as[b]'hbs) := λ hib' ↦ hb b hbs hib' (Nat.lt_add_one_of_le hbh) + + have hah := Nat.le_trans (Nat.le_of_lt hab) hbh + have hli := Nat.le_trans hla hai + have hih := Nat.le_trans hib hbh + have hlb := Nat.le_trans hla (Nat.le_of_lt hab) by_cases hai': a < i · by_cases hib': i < b - · exact hlttr (ha hai') (hb hib') + · exact hrtle a has hla hah i his hli hih b hbs hlb hbh (ha hai') (hb hib') · have hib: i = b := by exact Nat.le_antisymm hib (Nat.le_of_not_lt hib') subst b exact (ha hai') @@ -597,9 +803,9 @@ theorem glue_with_middle_eq_pivot {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} (his: i < as.size) (hpi: as[i]'his = pivot) - (ha : as.IForAll (r · pivot) low i) - (hb : as.IForAll (r pivot ·) (i + 1) (high + 1)) - (hlttr : IsTrans r) + (ha : as.IForAll low i (r · pivot)) + (hb : as.IForAll (i + 1) (high + 1) (r pivot ·)) + (hrtle : ITrans as low high r) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -623,46 +829,51 @@ theorem getElem_after_swap {as: Array α} {i j high: Nat} (hij: i ≤ j) (hjh: j · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hij hjh) · exact Nat.ne_of_lt (hjh) -structure ISortOf (lt: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where +structure ISortOf (r: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where perm: IPerm low high orig sorted - ord: IOrdered lt low high sorted + ord: IPairwiseLeB r low high sorted namespace ISortOf -theorem mkSingle (lt : α → α → Bool) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): - ISortOf lt k k as0 as := ⟨hp, .mkSingle (le_of_any_b lt) k as⟩ +theorem mkSingle (r: α → α → Bool) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): + ISortOf r k k as0 as := ⟨hp, .mkSingle (le_of_relation r) k as⟩ -theorem trans {lt: α → α → Bool} {low high: Nat} {as as' as'': Array α} - (hp: IPerm low high as as') (hs: ISortOf lt low high as' as''): - (ISortOf lt low high as as'') := by +theorem trans {r: α → α → Bool} {low high: Nat} {as as' as'': Array α} + (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): + (ISortOf r low high as as'') := by constructor case perm => exact hp.trans hs.perm case ord => exact hs.ord -theorem resize_out_of_bounds (h: ISortOf lt low high as0 as) (hsh: (as.size - 1) ≤ high) (hsh': (as0.size - 1) ≤ high'): - ISortOf lt low high' as0 as := by +theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) ≤ high) (hsh': (as0.size - 1) ≤ high'): + ISortOf r low high' as0 as := by constructor case perm => exact h.perm.resize_out_of_bounds hsh' case ord => exact h.ord.resize_out_of_bounds hsh end ISortOf mutual - theorem qsort.sort_sort_sorts (lt : α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) + theorem qsort.sort_sort_sorts (r: α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hlh: low < high) (hli : low ≤ i) (hih : i ≤ high) (hhs : high < as.size) (hpi: as[i]'(Nat.lt_of_le_of_lt hih hhs) = pivot) - (ha: IForAll as ((le_of_any_b lt) · pivot) low (i + 1)) - (hb: IForAll as ((le_of_any_b lt) pivot ·) (i + 1) (high + 1)) - (hlttr: IsTrans (le_of_any_b lt)): - have ⟨as', hs'⟩ := qsort.sort lt as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) - ISortOf lt low high as (qsort.sort lt as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by + (ha: IForAll as low (i + 1) ((le_of_relation r) · pivot)) + (hb: IForAll as (i + 1) (high + 1) ((le_of_relation r) pivot ·)) + (hrtle: ITransLeB as low high r): + have ⟨as', hs'⟩ := qsort.sort r as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) + ISortOf r low high as (qsort.sort r as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by have his := Nat.lt_of_le_of_lt hih hhs have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs - have h1 := qsort.sort_sorts as lt low (i - 1) (λ _ ↦ h1is) hlttr - let ahs' := qsort.sort lt as low (i - 1) (λ _ ↦ h1is) + have h1 := qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) (hrtle.restrict (Nat.le_refl _) h1ih) + + let ahs' := qsort.sort r as low (i - 1) (λ _ ↦ h1is) let as' := ahs'.1 let hs' := ahs'.2 - have h2 := qsort.sort_sorts as' lt (i + 1) high (λ _ ↦ hs' ▸ hhs) hlttr + have h2 := by + apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) ((hrtle.restrict ?_ ?_).transport_higher h1.perm ?_) + · exact Nat.le_add_right_of_le hli + · exact Nat.le_refl _ + · exact Nat.sub_lt_succ i 1 constructor case perm => @@ -672,7 +883,12 @@ mutual case ord => apply IPairwise.glue_with_middle_eq_pivot - case hlttr => exact hlttr + case hrtle => + apply (hrtle.transport_enclosing h1.perm ?_ ?_).transport_enclosing h2.perm ?_ ?_ + · exact Nat.le_refl _ + · exact h1ih + · exact Nat.le_add_right_of_le hli + · exact Nat.le_refl _ case i => exact i case his => simpa [qsort.size_sort] case ha => @@ -703,20 +919,23 @@ mutual subst i have: low = 0 := by exact Nat.eq_zero_of_le_zero hli subst low - simp - rw [h1.perm.getElem_empty] + simp_all + simp [h1.perm.eq_of_trivial] + rw [h2.perm.getElem_lower] + exact Nat.one_pos + case h1 => apply h1.ord.transport_lower h2.perm (Nat.sub_lt_succ i 1) case h2 => exact h2.ord termination_by (high - low, 0, 0) - theorem qsort.sort_loop_sorts (lt : α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) + theorem qsort.sort_loop_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) {pivot : α} (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) - (ha: IForAll as (lt · pivot) low i) - (hb: IForAll as (lt · pivot = false) i j) - (hlttr: IsTrans (le_of_any_b lt)): - ISortOf lt low high as (qsort.sort.loop lt low high hlh pivot as i j hli hij hjh hhs) := by + (ha: IForAll as low i (r · pivot)) + (hb: IForAll as i j (r · pivot = false)) + (hrtle: ITransLeB as low high r): + ISortOf r low high as (qsort.sort.loop r low high hlh pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs @@ -729,7 +948,7 @@ mutual case pos => have hjs: j < as.size := Nat.lt_trans hjh' hhs - by_cases hjp: lt (as[j]'hjs) pivot = true + by_cases hjp: r (as[j]'hjs) pivot = true all_goals simp only [hjp, Bool.false_eq_true, ↓reduceIte] case pos => @@ -739,7 +958,7 @@ mutual case hph => simpa only [getElem_after_swap hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs - case hlttr => exact hlttr + case hrtle => exact hrtle.transport_enclosing (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) case hp => exact .swap as i his hli hih j hjs hlj hjh case neg => @@ -759,7 +978,7 @@ mutual subst k exact eq_false_of_ne_true hjp - case hlttr => exact hlttr + case hrtle => exact hrtle case hp => exact .refl case neg => @@ -770,42 +989,54 @@ mutual apply qsort.sort_sort_sorts case hhs => simpa [size_swap] case ha => - let ha: as.IForAll (le_of_any_b lt · pivot) low i := ha.map (λ x a ↦ by + let ha: as.IForAll low i (le_of_relation r · pivot) := ha.map (λ x a ↦ by left exact a) - exact (hph ▸ ha).swap_left hij (le_of_any_b_refl lt _) + exact (hph ▸ ha).swap_left hij (le_of_relation_refl r _) case hb => - let hb: as.IForAll (le_of_any_b lt pivot ·) i high := hb.map (λ x a ↦ by + let hb: as.IForAll i high (le_of_relation r pivot ·) := hb.map (λ x a ↦ by right exact a) exact (hph ▸ hb).swap_right hij hhs - case hlttr => exact hlttr + case hrtle => exact hrtle.transport_enclosing (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) case hli => exact hli case hih => exact hih case hlh => exact hlh + case hpi => + simp only [swap_def, get_eq_getElem, getElem_set, getElem_set_eq, ite_eq_right_iff, ↓reduceIte] + intro h + simp only [h] case hp => exact IPerm.swap as i his hli hih high hhs (Nat.le_of_lt hlh) (Nat.le_refl _) termination_by (high - low, 1, high - j) - theorem qsort.sort_loop_pivot_swap_sorts (lt : α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) + theorem qsort.sort_loop_pivot_swap_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) - (hlttr: IsTrans (le_of_any_b lt)): + (hrtle: ITransLeB as low high r): - let as' := if lt (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as + let as' := if r (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] - ISortOf lt low high as (qsort.sort.loop lt low high hlh (as'[high]'(hs' ▸ hhs)) as' low low + ISortOf r low high as (qsort.sort.loop r low high hlh (as'[high]'(hs' ▸ hhs)) as' low low (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by have hms := Nat.lt_trans hmh hhs have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) - have hmh': mid ≠ high := Nat.ne_of_lt hmh apply ISortOf.trans case hs => apply qsort.sort_loop_sorts case hph => rfl - case hlttr => exact hlttr + case hrtle => + apply hrtle.transport_enclosing ?_ (Nat.le_refl _) (Nat.le_refl _) + apply IPerm.ite + · apply IPerm.swap + all_goals + first + | apply Nat.le_refl _ + | assumption + | apply Nat.le_of_lt; assumption + · apply IPerm.refl all_goals intro k hks hlk hkl have hll: low < low := Nat.lt_of_le_of_lt hlk hkl @@ -819,11 +1050,11 @@ mutual exact .refl termination_by (high - low, 2, 0) - theorem qsort.sort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) + theorem qsort.sort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother - (hlttr: IsTrans (le_of_any_b lt)): - ISortOf lt low high as (qsort.sort lt as low high hhs) := by + (hrtle: ITransLeB as low high r): + ISortOf r low high as (qsort.sort r as low high hhs) := by unfold qsort.sort by_cases hlh: low ≥ high case pos => @@ -850,35 +1081,36 @@ mutual case hlm => exact Nat.left_le_add_div_two.mpr hlh' case hmh => exact Nat.add_div_two_lt_right.mpr hlh - case hlttr => exact hlttr - - case hp => - repeat any_goals - first - | apply Nat.le_refl - | apply Nat.add_div_two_le_right_of_le - | apply Nat.left_le_add_div_two.mpr - | apply IPerm.refl - | apply IPerm.ite - | apply IPerm.trans_swap - | assumption + case hrtle => + apply hrtle.transport_enclosing ?hp (Nat.le_refl _) (Nat.le_refl _) + repeat any_goals + first + | apply Nat.le_refl + | apply Nat.add_div_two_le_right_of_le + | apply Nat.left_le_add_div_two.mpr + | apply IPerm.refl + | apply IPerm.ite + | apply IPerm.trans_swap + | assumption termination_by ((sizeOf high) - (sizeOf low), 3, 0) end -theorem qsort_sorts (as: Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) - (hlttr: IsTrans (le_of_any_b lt)): - ISortOf lt low high as (qsort as lt low high) := by +theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) + (hrtle: ITransLeB as low high r): + ISortOf r low high as (qsort as r low high) := by unfold qsort split case isTrue => apply qsort.sort_sorts - · exact hlttr + · exact hrtle case isFalse h => + have hsh: as.size - 1 ≤ high := by + apply Nat.sub_le_of_le_add + exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) apply ISortOf.resize_out_of_bounds · apply qsort.sort_sorts - · exact hlttr + · exact hrtle.restrict (Nat.le_refl _) hsh · simp only [qsort.size_sort, Nat.le_refl] - · apply Nat.sub_le_of_le_add - exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) + · exact hsh end Array From d0beff56fd5d6cf7eac104f97703f138543b168a Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 00:54:06 +0000 Subject: [PATCH 27/54] delete commented out code --- src/Init/Data/Array/QSort.lean | 213 ++++----------------------------- 1 file changed, 24 insertions(+), 189 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 4e6bf4688efe..a603314577a5 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -302,31 +302,6 @@ def IForAll (as: Array α) (low high: Nat) (P: α → Prop) := abbrev IForAllSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat)(P: α → Prop) := IForAll (as.swap ⟨i, his⟩ ⟨j, hjs⟩) low high P - -def ITrans {α} (as: Array α) (low high: Nat) (r: α → α → Prop) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → - (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → - r (as[i]'his) (as[j]'hjs) → r (as[j]'hjs) (as[k]'hks) → r (as[i]'his) (as[k]'hks) - - /-- - Turns a relation into one that behaves like le - If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] - If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] - -/ -abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false - -def ITransLeB {α} (as: Array α) (low high: Nat) (r: α → α → Bool) := - ITrans as low high (le_of_relation r) - -def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by - by_cases h: r x x - · left - exact h - · right - exact eq_false_of_ne_true h - - namespace IForAll theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as low high P) (f: (a: α) → P a → Q a): IForAll as low high Q := by @@ -403,6 +378,29 @@ theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low · exact Ne.symm hkj end IForAll +def ITrans {α} (as: Array α) (low high: Nat) (r: α → α → Prop) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → + r (as[i]'his) (as[j]'hjs) → r (as[j]'hjs) (as[k]'hks) → r (as[i]'his) (as[k]'hks) + + /-- + Turns a relation into one that behaves like le + If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] + If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] + -/ +abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false + +def ITransLeB {α} (as: Array α) (low high: Nat) (r: α → α → Bool) := + ITrans as low high (le_of_relation r) + +def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by + by_cases h: r x x + · left + exact h + · right + exact eq_false_of_ne_true h + set_option hygiene false in macro "transport_lemmas" α:ident @@ -497,166 +495,6 @@ variable {α} {r: α → α → Prop} transport_lemmas α (ITrans) (r) (LE.le) (LT.lt) Nat.le_trans Nat.not_lt.mpr 12 end ITrans -/- -theorem transport_lower {low high : Nat} {as as' : Array α} - (h : as.IForAll P low high) - (hp : IPerm plow phigh as as') - (hd: high ≤ plow): - as'.IForAll P low high := by - apply h.transport_outside hp - intro k _ hkh hplk _ - exact Nat.not_le.mpr (Nat.lt_of_le_of_lt hplk hkh) hd - -theorem transport_lower' {low high : Nat} {as as' : Array α} - (h : as.ITrans low high rel) - (hp : IPerm plow phigh as as') - (hd: high < plow): - as'.ITrans low high rel := by - apply transport_outside' h hp - intro k _ hkh hplk _ - exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd - -theorem transport_higher {low high : Nat} {as as' : Array α} - (h : as.IForAll P low high) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - as'.IForAll P low high := by - apply h.transport_outside hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd - -theorem transport_higher' {low high : Nat} {as as' : Array α} - (h : as.ITrans low high rel) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - as'.ITrans low high rel := by - apply transport_outside' h hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd --/ - -/- -theorem transport_enclosing - (h : as.IForAll low high P) - (hp : IPerm plow phigh as as') - (hll: low ≤ plow) - (hhh: phigh < high): - as'.IForAll low high P := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as a has hpla haph b hbs hplb hbph => - have hla := Nat.le_trans hll hpla - have hlb := Nat.le_trans hll hplb - have hah := Nat.lt_of_le_of_lt haph hhh - have hbh := Nat.lt_of_le_of_lt hbph hhh - iterate 4 intro _ - simp [swap_def] - repeat rw [getElem_set] - repeat any_goals split - all_goals - apply h - any_goals assumption - -theorem transport_enclosing' - (h : as.ITrans low high r) - (hp : IPerm plow phigh as as') - (hll: low ≤ plow) - (hhh: phigh ≤ high): - as'.ITrans low high r := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as a has hpla haph b hbs hplb hbph => - have hla := Nat.le_trans hll hpla - have hlb := Nat.le_trans hll hplb - have hah := Nat.le_trans haph hhh - have hbh := Nat.le_trans hbph hhh - iterate 12 intro _ - simp [swap_def] - repeat rw [getElem_set] - repeat any_goals split - all_goals - apply h - all_goals assumption - -theorem transport_outside {low high : Nat} {as as' : Array α} - (h : as.IForAll low high P) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k < high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - as'.IForAll low high P := by -induction hp with -| refl => exact h -| trans _ _ ih ih' => exact ih' (ih h) -| swap as i his hli hih j hjs hlj hjh => - iterate 4 intro _ - simp [swap_def] - repeat rw [getElem_set_ne] - · apply h - all_goals assumption - all_goals - intro he - subst_eqs - apply hd - all_goals assumption - -theorem transport_outside' - (h : as.ITrans low high r) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k ≤ high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - as'.ITrans low high r := by -induction hp with -| refl => exact h -| trans _ _ ih ih' => exact ih' (ih h) -| swap as i his hli hih j hjs hlj hjh => - iterate 12 intro _ - simp [swap_def] - repeat rw [getElem_set_ne] - · apply h - all_goals assumption - all_goals - intro he - subst_eqs - apply hd - all_goals assumption - -theorem transport_lower {low high : Nat} {as as' : Array α} - (h : as.IForAll low high P) - (hp : IPerm plow phigh as as') - (hd: high ≤ plow): - as'.IForAll low high P := by - apply h.transport_outside hp - intro k _ hkh hplk _ - exact Nat.not_le.mpr (Nat.lt_of_le_of_lt hplk hkh) hd - -theorem transport_lower' {low high : Nat} {as as' : Array α} - (h : as.ITrans low high rel) - (hp : IPerm plow phigh as as') - (hd: high < plow): - as'.ITrans low high rel := by - apply transport_outside' h hp - intro k _ hkh hplk _ - exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd - -theorem transport_higher {low high : Nat} {as as' : Array α} - (h : as.IForAll low high P) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - as'.IForAll low high P := by - apply h.transport_outside hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd - -theorem transport_higher' {low high : Nat} {as as' : Array α} - (h : as.ITrans low high rel) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - as'.ITrans low high rel := by - apply transport_outside' h hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd --/ - def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) @@ -892,8 +730,6 @@ mutual case i => exact i case his => simpa [qsort.size_sort] case ha => - --have foo: i ≤ i + 1 := by exact Nat.le_add_right i 1 - --have huh: i - 1 + 1 = i := by apply? apply ((ha.transport_enclosing h1.perm ?_ ?_).transport_lower h2.perm ?_).restrict ?_ ?_ · exact Nat.le_refl _ · exact Nat.sub_lt_succ i 1 @@ -1052,7 +888,6 @@ mutual theorem qsort.sort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) - -- TODO: to use this less constrained version, we need proofs that as'es are a permutation of eac hother (hrtle: ITransLeB as low high r): ISortOf r low high as (qsort.sort r as low high hhs) := by unfold qsort.sort @@ -1109,7 +944,7 @@ theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := a exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) apply ISortOf.resize_out_of_bounds · apply qsort.sort_sorts - · exact hrtle.restrict (Nat.le_refl _) hsh + case hrtle => exact hrtle.restrict (Nat.le_refl _) hsh · simp only [qsort.size_sort, Nat.le_refl] · exact hsh From b12fb8c00c2de66d69680e6ac5a9341e911a7684 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 01:03:59 +0000 Subject: [PATCH 28/54] Make generic structs take Props instead of Bools --- src/Init/Data/Array/QSort.lean | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index a603314577a5..2f05165a4d54 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -667,15 +667,18 @@ theorem getElem_after_swap {as: Array α} {i j high: Nat} (hij: i ≤ j) (hjh: j · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hij hjh) · exact Nat.ne_of_lt (hjh) -structure ISortOf (r: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where +structure ISortOf (r: α → α → Prop) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where perm: IPerm low high orig sorted - ord: IPairwiseLeB r low high sorted + ord: IPairwise r low high sorted + +abbrev ISortOfLeB (r: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop + := ISortOf (le_of_relation r) low high orig sorted namespace ISortOf -theorem mkSingle (r: α → α → Bool) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): - ISortOf r k k as0 as := ⟨hp, .mkSingle (le_of_relation r) k as⟩ +theorem mkSingle (r: α → α → Prop) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): + ISortOf r k k as0 as := ⟨hp, .mkSingle r k as⟩ -theorem trans {r: α → α → Bool} {low high: Nat} {as as' as'': Array α} +theorem trans {r: α → α → Prop} {low high: Nat} {as as' as'': Array α} (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): (ISortOf r low high as as'') := by constructor @@ -697,7 +700,7 @@ mutual (hb: IForAll as (i + 1) (high + 1) ((le_of_relation r) pivot ·)) (hrtle: ITransLeB as low high r): have ⟨as', hs'⟩ := qsort.sort r as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) - ISortOf r low high as (qsort.sort r as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by + ISortOfLeB r low high as (qsort.sort r as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by have his := Nat.lt_of_le_of_lt hih hhs have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs @@ -771,7 +774,7 @@ mutual (ha: IForAll as low i (r · pivot)) (hb: IForAll as i j (r · pivot = false)) (hrtle: ITransLeB as low high r): - ISortOf r low high as (qsort.sort.loop r low high hlh pivot as i j hli hij hjh hhs) := by + ISortOfLeB r low high as (qsort.sort.loop r low high hlh pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs @@ -854,7 +857,7 @@ mutual let as' := if r (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] - ISortOf r low high as (qsort.sort.loop r low high hlh (as'[high]'(hs' ▸ hhs)) as' low low + ISortOfLeB r low high as (qsort.sort.loop r low high hlh (as'[high]'(hs' ▸ hhs)) as' low low (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by have hms := Nat.lt_trans hmh hhs have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) @@ -889,7 +892,7 @@ mutual theorem qsort.sort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) (hrtle: ITransLeB as low high r): - ISortOf r low high as (qsort.sort r as low high hhs) := by + ISortOfLeB r low high as (qsort.sort r as low high hhs) := by unfold qsort.sort by_cases hlh: low ≥ high case pos => @@ -932,7 +935,7 @@ end theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hrtle: ITransLeB as low high r): - ISortOf r low high as (qsort as r low high) := by + ISortOfLeB r low high as (qsort as r low high) := by unfold qsort split case isTrue => From 14a124ef31c6f5c523bb71781fb24980166017fe Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 01:12:44 +0000 Subject: [PATCH 29/54] delete most implicits in favor of autoimplicit --- src/Init/Data/Array/QSort.lean | 39 +++++++++++++++++----------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 2f05165a4d54..55198a57e997 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -19,7 +19,7 @@ namespace Array split all_goals rfl -@[simp] theorem set_getElem_eq {as: Array α} {his: i < as.size} {his': i < as.size}: as.set ⟨i, his⟩ (as[i]'his') = as := by +@[simp] theorem set_getElem_eq (as: Array α) (his: i < as.size) (his': i < as.size): as.set ⟨i, his⟩ (as[i]'his') = as := by apply Array.ext · simp only [size_set] · intro k _ _ @@ -167,7 +167,7 @@ namespace Array split all_goals exact (qsort.sort _ _ _ _ _).2 -inductive IPerm {α} (low high: Nat): Array α → Array α → Prop where +inductive IPerm (low high: Nat): Array α → Array α → Prop where | refl: IPerm low high as as | swap (as: Array α) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as (as.swap ⟨i, his⟩ ⟨j, hjs⟩) | trans {as as' as'': Array α}: IPerm low high as as' → IPerm low high as' as'' → IPerm low high as as'' @@ -187,12 +187,12 @@ theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → case isTrue h => exact hpt h case isFalse h => exact hpf h -theorem trans_swap {as0 as: Array α} (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): +theorem trans_swap (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by apply IPerm.trans hp exact IPerm.swap as i his hli hih j hjs hlj hjh -theorem expand {α} {low high: Nat} +theorem expand {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} (hp: IPerm low high as as'): IPerm low' high' as as' := by induction hp with @@ -203,15 +203,15 @@ theorem expand {α} {low high: Nat} i his (Nat.le_trans hll hli) (Nat.le_trans hih hhh) j hjs (Nat.le_trans hll hlj) (Nat.le_trans hjh hhh) -theorem expand_up {α} {low high: Nat} {as: Array α} {as': Array α} (hhh: high ≤ high') +theorem expand_up (hhh: high ≤ high') (hp: IPerm low high as as'): IPerm low high' as as' := hp.expand (Nat.le_refl _) hhh -theorem expand_down {α} {low high: Nat} {as: Array α} {as': Array α} (hll: low' ≤ low) +theorem expand_down (hll: low' ≤ low) (hp: IPerm low high as as'): IPerm low' high as as' := hp.expand hll (Nat.le_refl _) -theorem size_eq {α} {as: Array α} {as': Array α} {low high: Nat} +theorem size_eq (hp: IPerm low high as as' ): as.size = as'.size := by induction hp with | refl => rfl @@ -309,7 +309,7 @@ theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as low high P) (f: (a specialize ha k hks hlk hkh exact f as[k] ha -theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} +theorem swap_left (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) (ha: IForAll as low i P): IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by @@ -334,7 +334,8 @@ theorem swap_left {as: Array α} {P: α → Prop} {low: Nat} {i j: Nat} · intro h exact hij (Eq.symm h) -theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hjs: j < as.size) +theorem swap_right + (hij: i ≤ j) (hjs: j < as.size) (hb: IForAll as i j P): IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by intro k hks hi1x hkj1 @@ -351,7 +352,8 @@ theorem swap_right {as: Array α} {P: α → Prop} {i j: Nat} (hij: i ≤ j) (hj simp only [getElem_set_eq] exact hb i (Nat.lt_trans hi1x hjs) (Nat.le_refl i) hi1x -theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} +theorem of_swap + (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} (h: IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low high P): IForAll as low high P := by have his := Nat.lt_of_le_of_lt hij hjs @@ -378,7 +380,7 @@ theorem of_swap {as: Array α} {P: α → Prop} {low high i j: Nat} (hli: low · exact Ne.symm hkj end IForAll -def ITrans {α} (as: Array α) (low high: Nat) (r: α → α → Prop) := +def ITrans (as: Array α) (low high: Nat) (r: α → α → Prop) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → @@ -391,7 +393,7 @@ def ITrans {α} (as: Array α) (low high: Nat) (r: α → α → Prop) := -/ abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false -def ITransLeB {α} (as: Array α) (low high: Nat) (r: α → α → Bool) := +def ITransLeB (as: Array α) (low high: Nat) (r: α → α → Bool) := ITrans as low high (le_of_relation r) def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by @@ -515,8 +517,7 @@ theorem mkSingle (r : α → α → Prop) (k: Nat) (as: Array α): have hkk: k < k := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjl) exact (Nat.ne_of_lt hkk) rfl -theorem restrict {low high: Nat} - {low' high': Nat} (hll: low ≤ low') (hhh: high' ≤ high) {as: Array α} +theorem restrict (hll: low ≤ low') (hhh: high' ≤ high) {as: Array α} (p: IPairwise r low high as): IPairwise r low' high' as := by unfold IPairwise intro i j hli hij hjl hjs @@ -573,7 +574,6 @@ theorem transport_higher /- theorem glue_with_pivot - {r : α → α → Prop} {low high : Nat} {pivot : α} {i : Nat} {as : Array α} (ha : as.IForAll low (i + 1) (r · pivot)) (hb : as.IForAll (i + 1) (high + 1) (r pivot ·)) (hrtle : ITrans as low high r) @@ -598,7 +598,6 @@ theorem glue_with_pivot -/ theorem glue_with_middle - {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} (his: i < as.size) (ha : as.IForAll low i (r · (as[i]'his))) (hb : as.IForAll (i + 1) (high + 1) (r (as[i]'his) ·)) @@ -658,7 +657,7 @@ abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as. le_of_le_of_eq hks (Eq.symm (size_swap as ⟨i, his⟩ ⟨j, hjs⟩)) ) -theorem getElem_after_swap {as: Array α} {i j high: Nat} (hij: i ≤ j) (hjh: j < high) (hhs: high < as.size): +theorem getElem_after_swap (as: Array α) (hij: i ≤ j) (hjh: j < high) (hhs: high < as.size): as.swap_getElem i j high (Nat.lt_of_le_of_lt hij (Nat.lt_trans hjh hhs)) (Nat.lt_trans hjh hhs) hhs = (as[high]'hhs) := by simp [swap_getElem, swap_def] @@ -678,7 +677,7 @@ namespace ISortOf theorem mkSingle (r: α → α → Prop) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): ISortOf r k k as0 as := ⟨hp, .mkSingle r k as⟩ -theorem trans {r: α → α → Prop} {low high: Nat} {as as' as'': Array α} +theorem trans (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): (ISortOf r low high as as'') := by constructor @@ -769,7 +768,7 @@ mutual termination_by (high - low, 0, 0) theorem qsort.sort_loop_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) - {pivot : α} (i j : Nat) + (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) (ha: IForAll as low i (r · pivot)) (hb: IForAll as i j (r · pivot = false)) @@ -794,7 +793,7 @@ mutual apply ISortOf.trans case hs => apply qsort.sort_loop_sorts - case hph => simpa only [getElem_after_swap hij hjh' hhs] + case hph => simpa only [getElem_after_swap _ hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs case hrtle => exact hrtle.transport_enclosing (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) From 7330b4bc4fd2f7ad406f047c393130d1e097dca1 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 04:41:37 +0000 Subject: [PATCH 30/54] initial refactor to typeclasses for transport --- src/Init/Data/Array/QSort.lean | 304 +++++++++++++++++++++------------ 1 file changed, 195 insertions(+), 109 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 55198a57e997..3b6125ab0775 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -296,23 +296,43 @@ def getElem_higher (hp: IPerm low high as as') (hhk: high < k) end IPerm -def IForAll (as: Array α) (low high: Nat) (P: α → Prop) := +def IForAllIco (P: α → Prop) (low high: Nat) (as: Array α) := ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) -abbrev IForAllSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat)(P: α → Prop) := - IForAll (as.swap ⟨i, his⟩ ⟨j, hjs⟩) low high P +def IForAllIcc (P: α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + P (as[i]'his) -namespace IForAll -theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAll as low high P) (f: (a: α) → P a → Q a): - IForAll as low high Q := by +def IForAllIcc2 (P: α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + P (as[i]'his) (as[j]'hjs) + +def IForAllIcc3 (P: α → α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → + P (as[i]'his) (as[j]'hjs) (as[k]'hks) + +def IForAllIcc2I (P: Nat → Nat → α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + P i j (as[i]'his) (as[j]'hjs) + +abbrev IForAllIcoSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat) (P: α → Prop) := + IForAllIco P low high (as.swap ⟨i, his⟩ ⟨j, hjs⟩) + +namespace IForAllIco +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: (a: α) → P a → Q a): + IForAllIco Q low high as := by intro k hks hlk hkh specialize ha k hks hlk hkh exact f as[k] ha theorem swap_left (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) - (ha: IForAll as low i P): - IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by + (ha: IForAllIco P low i as): + IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by intro k hks hlk hki1 rw [size_swap] at hks simp only [swap_def] @@ -336,8 +356,8 @@ theorem swap_left theorem swap_right (hij: i ≤ j) (hjs: j < as.size) - (hb: IForAll as i j P): - IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by + (hb: IForAllIco P i j as): + IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by intro k hks hi1x hkj1 rw [size_swap] at hks simp only [swap_def] @@ -354,11 +374,11 @@ theorem swap_right theorem of_swap (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} - (h: IForAllSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs - low high P): IForAll as low high P := by + (h: IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs + low high P): IForAllIco P low high as := by have his := Nat.lt_of_le_of_lt hij hjs intro k hks hlk hkh - simp [IForAllSwap, IForAll, size_swap, swap_def] at h + simp [IForAllIcoSwap, IForAllIco, size_swap, swap_def] at h by_cases hki: k = i · subst k have hlj: low ≤ j := Nat.le_trans hli hij @@ -378,13 +398,10 @@ theorem of_swap rwa [getElem_set_ne] at h · exact Ne.symm hki · exact Ne.symm hkj -end IForAll +end IForAllIco -def ITrans (as: Array α) (low high: Nat) (r: α → α → Prop) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → - (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → - r (as[i]'his) (as[j]'hjs) → r (as[j]'hjs) (as[k]'hks) → r (as[i]'his) (as[k]'hks) +abbrev ITrans (r: α → α → Prop) := + IForAllIcc3 (λ x y z ↦ r x y → r y z → r x z) /-- Turns a relation into one that behaves like le @@ -393,8 +410,8 @@ def ITrans (as: Array α) (low high: Nat) (r: α → α → Prop) := -/ abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false -def ITransLeB (as: Array α) (low high: Nat) (r: α → α → Bool) := - ITrans as low high (le_of_relation r) +abbrev ITransLeB (r: α → α → Bool) := + ITrans (le_of_relation r) def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by by_cases h: r x x @@ -403,42 +420,136 @@ def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x · right exact eq_false_of_ne_true h +abbrev ICompat (r: α → α → Prop) (r': α → α → Prop) := + IForAllIcc2 (λ x y ↦ r x y → r' x y) + + +class Restrictable (α) (T: Nat → Nat → Array α → Prop) where + restrict (ha: T low high as) + (hll: low ≤ low') (hhh: high' ≤ high) + : T low' high' as + +class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where + transport_outside + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + T low high as' + +class LteOp (r: Nat → Nat → Prop) where + co: Nat → Nat → Prop + of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z + not: ¬(co a b) ↔ (r b a) + +instance: LteOp (LE.le) where + co := LT.lt + of_le_of xy yz := Nat.le_trans xy yz + not := Nat.not_lt + +instance: LteOp (LT.lt) where + co := LE.le + of_le_of xy yz := Nat.lt_of_le_of_lt xy yz + not := Nat.not_le + +open Restrictable (restrict) +open TransportableOutside (transport_outside) + +theorem transport_lower {α} {T: Nat → Nat → Array α → Prop} + [TransportableOutside α T r] [LteOp r] + {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: LteOp.co r high plow): + T low high as' := by + apply transport_outside h hp (ub := r) + intro k _ hkh hplk _ + exact LteOp.not.mpr (LteOp.of_le_of hplk hkh) hd + +theorem transport_higher {α} {T: Nat → Nat → Array α → Prop} + [TransportableOutside α T r] [LteOp r] + {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + T low high as' := by + apply transport_outside h hp (ub := r) + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd + +class TransportableEnclosing (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) + extends TransportableOutside α T ub where + transport_enclosing + (h : T low high as) + (hp : IPerm plow phigh as as') + (hll: low ≤ plow) + (hhh: ub phigh high) : + T low high as' +open TransportableEnclosing (transport_enclosing) + +set_option hygiene false in +macro "transport_lemmas_outside" + α:ident + "(" T:term ")" + "(" ub:term ")" + intros:num : command => +`( +instance: Restrictable α ($T) where + restrict {low high: Nat} {as: Array $α} {low' high': Nat} (ha: $T low high as) + (hll: low ≤ low') (hhh: high' ≤ high) + : $T low' high' as := by + iterate $intros intro _ + apply ha + all_goals + try first + | apply Nat.le_trans hll _ + | apply Nat.le_trans _ hhh + assumption + +instance: TransportableOutside α ($T) $ub where + transport_outside {low high: Nat} {as: Array $α} {plow phigh: Nat} {as': Array $α} + (h : $T low high as) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: $ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + $T low high as' := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as i his hli hih j hjs hlj hjh => + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set_ne] + · apply h + all_goals assumption + all_goals + intro he + subst_eqs + apply hd + all_goals assumption +) + set_option hygiene false in macro "transport_lemmas" α:ident "(" T:term ")" - "(" Ts:term* ")" "(" ub:term ")" - "(" ub':term ")" - trans:ident - not_trans:ident intros:num : command => `( - theorem restrict {as: Array $α} {low high low' high': Nat} (ha: $T as low high $Ts*) - (hll: low ≤ low') (hhh: high' ≤ high) - : $T as low' high' $Ts* := by - iterate $intros intro _ - apply ha - all_goals - try first - | apply Nat.le_trans hll _ - | apply Nat.le_trans _ hhh - assumption + transport_lemmas_outside $α ($T) ($ub) $intros theorem transport_enclosing {as as': Array $α} {low high plow phigh: Nat} - (h : $T as low high $Ts*) + (h : $T low high as) (hp : IPerm plow phigh as as') (hll: low ≤ plow) (hhh: $ub phigh high) : - $T as' low high $Ts* := by + $T low high as' := by induction hp with | refl => exact h | trans _ _ ih ih' => exact ih' (ih h) | swap as a has hpla haph b hbs hplb hbph => have hla := Nat.le_trans hll hpla have hlb := Nat.le_trans hll hplb - have hah := $trans haph hhh - have hbh := $trans hbph hhh + have hah := LteOp.of_le_of haph hhh + have hbh := LteOp.of_le_of hbph hhh iterate $intros intro _ simp [swap_def] repeat rw [getElem_set] @@ -446,56 +557,31 @@ macro "transport_lemmas" all_goals apply h all_goals assumption +) - theorem transport_outside {as as': Array $α} {low high plow phigh: Nat} - (h : $T as low high $Ts*) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: $ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - $T as' low high $Ts* := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as i his hli hih j hjs hlj hjh => - iterate $intros intro _ - simp [swap_def] - repeat rw [getElem_set_ne] - · apply h - all_goals assumption - all_goals - intro he - subst_eqs - apply hd - all_goals assumption - - theorem transport_lower {as as': Array $α} {low high plow phigh: Nat} - (h : $T as low high $Ts*) - (hp : IPerm plow phigh as as') - (hd: $ub' high plow): - $T as' low high $Ts* := by - apply transport_outside h hp - intro k _ hkh hplk _ - exact $not_trans ($trans hplk hkh) hd +namespace IForAllIco +variable {α} {P: α → Prop} - theorem transport_higher {as as': Array $α} {low high plow phigh: Nat} - (h : $T as low high $Ts*) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - $T as' low high $Ts* := by - apply transport_outside h hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd -) +transport_lemmas α (IForAllIco P) (LT.lt) 4 +end IForAllIco -namespace IForAll +namespace IForAllIcc variable {α} {P: α → Prop} -transport_lemmas α (IForAll) (P) (LT.lt) (LE.le) Nat.lt_of_le_of_lt Nat.not_le.mpr 4 -end IForAll -namespace ITrans -variable {α} {r: α → α → Prop} +transport_lemmas α (IForAllIcc P) (LE.le) 4 +end IForAllIcc -transport_lemmas α (ITrans) (r) (LE.le) (LT.lt) Nat.le_trans Nat.not_lt.mpr 12 -end ITrans +namespace IForAllIcc2 +variable {α} {P: α → α → Prop} + +transport_lemmas α (IForAllIcc2 P) (LE.le) 8 +end IForAllIcc2 + +namespace IForAllIcc3 +variable {α} {P: α → α → α → Prop} + +transport_lemmas α (IForAllIcc3 P) (LE.le) 12 +end IForAllIcc3 def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → @@ -574,9 +660,9 @@ theorem transport_higher /- theorem glue_with_pivot - (ha : as.IForAll low (i + 1) (r · pivot)) - (hb : as.IForAll (i + 1) (high + 1) (r pivot ·)) - (hrtle : ITrans as low high r) + (ha : as.IForAllIco low (i + 1) (r · pivot)) + (hb : as.IForAllIco (i + 1) (high + 1) (r pivot ·)) + (hrtle : ITrans low high as r) (h1 : IPairwise r low i as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -598,10 +684,10 @@ theorem glue_with_pivot -/ theorem glue_with_middle - (his: i < as.size) - (ha : as.IForAll low i (r · (as[i]'his))) - (hb : as.IForAll (i + 1) (high + 1) (r (as[i]'his) ·)) - (hrtle : ITrans as low high r) + (his: i < as.size) {r: α → α → Prop} + (ha : IForAllIco (r · (as[i]'his)) low i as) + (hb : IForAllIco (r (as[i]'his) ·) (i + 1) (high + 1) as) + (hrtle : ITrans r low high as) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -640,9 +726,9 @@ theorem glue_with_middle_eq_pivot {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} (his: i < as.size) (hpi: as[i]'his = pivot) - (ha : as.IForAll low i (r · pivot)) - (hb : as.IForAll (i + 1) (high + 1) (r pivot ·)) - (hrtle : ITrans as low high r) + (ha : as.IForAllIco (r · pivot) low i) + (hb : as.IForAllIco (r pivot ·) (i + 1) (high + 1)) + (hrtle : ITrans r low high as) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -695,22 +781,22 @@ mutual theorem qsort.sort_sort_sorts (r: α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hlh: low < high) (hli : low ≤ i) (hih : i ≤ high) (hhs : high < as.size) (hpi: as[i]'(Nat.lt_of_le_of_lt hih hhs) = pivot) - (ha: IForAll as low (i + 1) ((le_of_relation r) · pivot)) - (hb: IForAll as (i + 1) (high + 1) ((le_of_relation r) pivot ·)) - (hrtle: ITransLeB as low high r): + (ha: IForAllIco ((le_of_relation r) · pivot) low (i + 1) as) + (hb: IForAllIco ((le_of_relation r) pivot ·) (i + 1) (high + 1) as) + (hrtle: ITransLeB r low high as): have ⟨as', hs'⟩ := qsort.sort r as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) ISortOfLeB r low high as (qsort.sort r as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by have his := Nat.lt_of_le_of_lt hih hhs have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs - have h1 := qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) (hrtle.restrict (Nat.le_refl _) h1ih) + have h1 := qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) (restrict hrtle (Nat.le_refl _) h1ih) let ahs' := qsort.sort r as low (i - 1) (λ _ ↦ h1is) let as' := ahs'.1 let hs' := ahs'.2 have h2 := by - apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) ((hrtle.restrict ?_ ?_).transport_higher h1.perm ?_) + apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) (transport_higher (restrict hrtle ?_ ?_) h1.perm ?_) · exact Nat.le_add_right_of_le hli · exact Nat.le_refl _ · exact Nat.sub_lt_succ i 1 @@ -732,14 +818,14 @@ mutual case i => exact i case his => simpa [qsort.size_sort] case ha => - apply ((ha.transport_enclosing h1.perm ?_ ?_).transport_lower h2.perm ?_).restrict ?_ ?_ + apply restrict (transport_lower (ha.transport_enclosing h1.perm ?_ ?_) h2.perm ?_) ?_ ?_ · exact Nat.le_refl _ · exact Nat.sub_lt_succ i 1 · exact Nat.le_refl (i + 1) · exact Nat.le_refl low · exact Nat.le_add_right i 1 case hb => - apply (hb.transport_higher h1.perm ?_).transport_enclosing h2.perm ?_ ?_ + apply (transport_higher hb h1.perm ?_).transport_enclosing h2.perm ?_ ?_ · exact Nat.sub_lt_succ i 1 · exact Nat.le_refl _ · exact Nat.lt_add_one high @@ -770,9 +856,9 @@ mutual theorem qsort.sort_loop_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) - (ha: IForAll as low i (r · pivot)) - (hb: IForAll as i j (r · pivot = false)) - (hrtle: ITransLeB as low high r): + (ha: IForAllIco (r · pivot) low i as) + (hb: IForAllIco (r · pivot = false) i j as) + (hrtle: ITransLeB r low high as): ISortOfLeB r low high as (qsort.sort.loop r low high hlh pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop @@ -827,13 +913,13 @@ mutual apply qsort.sort_sort_sorts case hhs => simpa [size_swap] case ha => - let ha: as.IForAll low i (le_of_relation r · pivot) := ha.map (λ x a ↦ by + let ha: IForAllIco (le_of_relation r · pivot) low i as := ha.map (λ x a ↦ by left exact a) exact (hph ▸ ha).swap_left hij (le_of_relation_refl r _) case hb => - let hb: as.IForAll i high (le_of_relation r pivot ·) := hb.map (λ x a ↦ by + let hb: IForAllIco (le_of_relation r pivot ·) i high as := hb.map (λ x a ↦ by right exact a) exact (hph ▸ hb).swap_right hij hhs @@ -851,7 +937,7 @@ mutual theorem qsort.sort_loop_pivot_swap_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) - (hrtle: ITransLeB as low high r): + (hrtle: ITransLeB r low high as): let as' := if r (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] @@ -890,7 +976,7 @@ mutual theorem qsort.sort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) - (hrtle: ITransLeB as low high r): + (hrtle: ITransLeB r low high as): ISortOfLeB r low high as (qsort.sort r as low high hhs) := by unfold qsort.sort by_cases hlh: low ≥ high @@ -933,7 +1019,7 @@ mutual end theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) - (hrtle: ITransLeB as low high r): + (hrtle: ITransLeB r low high as): ISortOfLeB r low high as (qsort as r low high) := by unfold qsort split @@ -946,7 +1032,7 @@ theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := a exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) apply ISortOf.resize_out_of_bounds · apply qsort.sort_sorts - case hrtle => exact hrtle.restrict (Nat.le_refl _) hsh + case hrtle => exact restrict hrtle (Nat.le_refl _) hsh · simp only [qsort.size_sort, Nat.le_refl] · exact hsh From 09fdf1a0ccda39e5b08f193e717ea9186a6fe6af Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 11:10:00 +0000 Subject: [PATCH 31/54] more refactor to typeclasses --- src/Init/Data/Array/QSort.lean | 221 +++++++++++++++++---------------- 1 file changed, 116 insertions(+), 105 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 3b6125ab0775..9012a438bbb1 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -314,11 +314,19 @@ def IForAllIcc3 (P: α → α → α → Prop) (low high: Nat) (as: Array α) := (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → P (as[i]'his) (as[j]'hjs) (as[k]'hks) +/- def IForAllIcc2I (P: Nat → Nat → α → α → Prop) (low high: Nat) (as: Array α) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → P i j (as[i]'his) (as[j]'hjs) +-- equivalent IForAllIcc2I (λ i j x y ↦ i < j → r x y) low high as +-/ + +def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := + ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → + r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) + abbrev IForAllIcoSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat) (P: α → Prop) := IForAllIco P low high (as.swap ⟨i, his⟩ ⟨j, hjs⟩) @@ -423,12 +431,19 @@ def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x abbrev ICompat (r: α → α → Prop) (r': α → α → Prop) := IForAllIcc2 (λ x y ↦ r x y → r' x y) +class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where + restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) + (hsh: ub (as.size - 1) high): T low high' as + +export RestrictableOutOfBounds (restrict_out_of_bounds) class Restrictable (α) (T: Nat → Nat → Array α → Prop) where restrict (ha: T low high as) (hll: low ≤ low') (hhh: high' ≤ high) : T low' high' as +export Restrictable (restrict) + class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where transport_outside (h : T low high as) @@ -436,6 +451,8 @@ class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outP (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): T low high as' +export TransportableOutside (transport_outside) + class LteOp (r: Nat → Nat → Prop) where co: Nat → Nat → Prop of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z @@ -451,9 +468,6 @@ instance: LteOp (LT.lt) where of_le_of xy yz := Nat.lt_of_le_of_lt xy yz not := Nat.not_le -open Restrictable (restrict) -open TransportableOutside (transport_outside) - theorem transport_lower {α} {T: Nat → Nat → Array α → Prop} [TransportableOutside α T r] [LteOp r] {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} @@ -484,28 +498,59 @@ class TransportableEnclosing (α) (T: Nat → Nat → Array α → Prop) (ub: ou (hll: low ≤ plow) (hhh: ub phigh high) : T low high as' -open TransportableEnclosing (transport_enclosing) -set_option hygiene false in -macro "transport_lemmas_outside" +export TransportableEnclosing (transport_enclosing) + +scoped macro "singleton_inhabited" + α:ident + "(" T:term ")" + intros:num : command => +`( +instance {k: Nat} {as: Array $α}: + Inhabited ($T k k as) where + default := by + iterate $intros intro _ + exfalso + suffices hkk: k < k by + exact (Nat.ne_of_lt hkk) rfl + first + | exact Nat.lt_of_le_of_lt (by assumption) (by assumption) + | exact Nat.lt_of_le_of_lt (by assumption) (Nat.lt_of_lt_of_le (by assumption) (by assumption)) + | done +) + +scoped macro "transport_lemmas_outside" α:ident "(" T:term ")" "(" ub:term ")" intros:num : command => `( -instance: Restrictable α ($T) where - restrict {low high: Nat} {as: Array $α} {low' high': Nat} (ha: $T low high as) +instance: Restrictable $α ($T) where + restrict {low high: Nat} {as: Array $α} {low' high': Nat} (h: $T low high as) (hll: low ≤ low') (hhh: high' ≤ high) : $T low' high' as := by iterate $intros intro _ - apply ha + apply h all_goals try first | apply Nat.le_trans hll _ | apply Nat.le_trans _ hhh assumption -instance: TransportableOutside α ($T) $ub where +instance: RestrictableOutOfBounds $α ($T) $ub where + restrict_out_of_bounds {low high: Nat} {as: Array $α} {high': Nat} (h: $T low high as) + (hsh: $ub (as.size - 1) high): + $T low high' as := by + iterate $intros intro _ + apply h + repeat any_goals + first + | assumption + | apply Nat.le_trans _ hsh + | apply Nat.succ_le_succ + | apply Nat.le_sub_one_of_lt + +instance: TransportableOutside $α ($T) $ub where transport_outside {low high: Nat} {as: Array $α} {plow phigh: Nat} {as': Array $α} (h : $T low high as) (hp : IPerm plow phigh as as') @@ -516,19 +561,30 @@ instance: TransportableOutside α ($T) $ub where | trans _ _ ih ih' => exact ih' (ih h) | swap as i his hli hih j hjs hlj hjh => iterate $intros intro _ - simp [swap_def] + simp only [swap_def] repeat rw [getElem_set_ne] · apply h all_goals assumption all_goals intro he subst_eqs - apply hd - all_goals assumption + first + | apply hd i + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | apply hd j + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) ) set_option hygiene false in -macro "transport_lemmas" +scoped macro "transport_lemmas" α:ident "(" T:term ")" "(" ub:term ")" @@ -536,32 +592,45 @@ macro "transport_lemmas" `( transport_lemmas_outside $α ($T) ($ub) $intros - theorem transport_enclosing {as as': Array $α} {low high plow phigh: Nat} +instance: TransportableEnclosing $α ($T) $ub where + transport_enclosing {low high: Nat} {as: Array $α} {plow phigh: Nat} {as': Array $α} (h : $T low high as) (hp : IPerm plow phigh as as') (hll: low ≤ plow) (hhh: $ub phigh high) : $T low high as' := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as a has hpla haph b hbs hplb hbph => - have hla := Nat.le_trans hll hpla - have hlb := Nat.le_trans hll hplb - have hah := LteOp.of_le_of haph hhh - have hbh := LteOp.of_le_of hbph hhh - iterate $intros intro _ - simp [swap_def] - repeat rw [getElem_set] - repeat any_goals split - all_goals - apply h - all_goals assumption + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := LteOp.of_le_of haph hhh + have hbh := LteOp.of_le_of hbph hhh + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set] + repeat any_goals split + all_goals + apply h + all_goals assumption ) +def problem (i i' high: Nat) (hij' : i' < i) + (hjh' : i ≤ high): i' < high := by + apply Nat.lt_of_lt_of_le (m := i) (by assumption) (by assumption) + +namespace IPairwise +variable {α} {P: α → α → Prop} + +singleton_inhabited α (IPairwise P) 6 +transport_lemmas_outside α (IPairwise P) (LE.le) 6 +end IPairwise + namespace IForAllIco variable {α} {P: α → Prop} +singleton_inhabited α (IForAllIco P) 4 transport_lemmas α (IForAllIco P) (LT.lt) 4 end IForAllIco @@ -583,9 +652,13 @@ variable {α} {P: α → α → α → Prop} transport_lemmas α (IForAllIcc3 P) (LE.le) 12 end IForAllIcc3 -def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := - ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → - r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) +/- +namespace IForAllIcc2I +variable {α} {P: Nat → Nat → α → α → Prop} + +transport_lemmas_outside α (IForAllIcc2I P) (LE.le) 8 +end IForAllIcc2I +-/ /-- If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] @@ -595,68 +668,6 @@ abbrev IPairwiseLeB (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array IPairwise (le_of_relation (r · ·)) low high as namespace IPairwise -theorem mkSingle (r : α → α → Prop) (k: Nat) (as: Array α): - IPairwise r k k as := by - unfold IPairwise - intro i j hli hij hjl hjs - exfalso - have hkk: k < k := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjl) - exact (Nat.ne_of_lt hkk) rfl - -theorem restrict (hll: low ≤ low') (hhh: high' ≤ high) {as: Array α} - (p: IPairwise r low high as): IPairwise r low' high' as := by - unfold IPairwise - intro i j hli hij hjl hjs - exact p i j (Nat.le_trans hll hli) hij (Nat.le_trans hjl hhh) hjs - -theorem resize_out_of_bounds (h: IPairwise r low high as) (hsh: (as.size - 1) ≤ high): - IPairwise r low high' as := by - unfold IPairwise - intro i j hli hij _ hjs - have hjh: j ≤ high := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh - exact h i j hli hij hjh hjs - -theorem transport_outside - (h : as.IPairwise r low high) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: k ≤ high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - as'.IPairwise r low high := by -induction hp with -| refl => exact h -| trans _ _ ih ih' => exact ih' (ih h) -| swap as i his hli hih j hjs hlj hjh => - intro a b hla hab hbl hbs - have hal := Nat.lt_of_lt_of_le hab hbl - simp [swap_def] - repeat rw [getElem_set_ne] - · simp [size_swap] at hbs - exact h a b hla hab hbl hbs - all_goals - intro he - simp only at he - subst_eqs - · exact hd i (Nat.le_trans hla (Nat.le_of_lt hab)) hbl hli hih - · exact hd j (Nat.le_trans hla (Nat.le_of_lt hab)) hbl hlj hjh - · exact hd i hla (Nat.le_of_lt hal) hli hih - · exact hd j hla (Nat.le_of_lt hal) hlj hjh - -theorem transport_lower - (h : as.IPairwise r low high) - (hp : IPerm plow phigh as as') - (hd: high < plow): - as'.IPairwise r low high := by - apply h.transport_outside hp - intro k _ hkh hplk _ - exact Nat.not_lt.mpr (Nat.le_trans hplk hkh) hd - -theorem transport_higher - (h : as.IPairwise r low high) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - as'.IPairwise r low high := by - apply h.transport_outside hp - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd /- theorem glue_with_pivot @@ -761,7 +772,7 @@ abbrev ISortOfLeB (r: α → α → Bool) (low high: Nat) (orig: Array α) (sort namespace ISortOf theorem mkSingle (r: α → α → Prop) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): - ISortOf r k k as0 as := ⟨hp, .mkSingle r k as⟩ + ISortOf r k k as0 as := ⟨hp, default⟩ theorem trans (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): @@ -774,7 +785,7 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) ISortOf r low high' as0 as := by constructor case perm => exact h.perm.resize_out_of_bounds hsh' - case ord => exact h.ord.resize_out_of_bounds hsh + case ord => exact restrict_out_of_bounds h.ord hsh end ISortOf mutual @@ -810,7 +821,7 @@ mutual case ord => apply IPairwise.glue_with_middle_eq_pivot case hrtle => - apply (hrtle.transport_enclosing h1.perm ?_ ?_).transport_enclosing h2.perm ?_ ?_ + apply transport_enclosing (transport_enclosing hrtle h1.perm ?_ ?_) h2.perm ?_ ?_ · exact Nat.le_refl _ · exact h1ih · exact Nat.le_add_right_of_le hli @@ -818,14 +829,14 @@ mutual case i => exact i case his => simpa [qsort.size_sort] case ha => - apply restrict (transport_lower (ha.transport_enclosing h1.perm ?_ ?_) h2.perm ?_) ?_ ?_ + apply restrict (transport_lower (transport_enclosing ha h1.perm ?_ ?_) h2.perm ?_) ?_ ?_ · exact Nat.le_refl _ · exact Nat.sub_lt_succ i 1 · exact Nat.le_refl (i + 1) · exact Nat.le_refl low · exact Nat.le_add_right i 1 case hb => - apply (transport_higher hb h1.perm ?_).transport_enclosing h2.perm ?_ ?_ + apply transport_enclosing (transport_higher hb h1.perm ?_) h2.perm ?_ ?_ · exact Nat.sub_lt_succ i 1 · exact Nat.le_refl _ · exact Nat.lt_add_one high @@ -849,7 +860,7 @@ mutual exact Nat.one_pos case h1 => - apply h1.ord.transport_lower h2.perm (Nat.sub_lt_succ i 1) + apply transport_lower h1.ord h2.perm (Nat.sub_lt_succ i 1) case h2 => exact h2.ord termination_by (high - low, 0, 0) @@ -882,7 +893,7 @@ mutual case hph => simpa only [getElem_after_swap _ hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs - case hrtle => exact hrtle.transport_enclosing (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) + case hrtle => exact transport_enclosing hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) case hp => exact .swap as i his hli hih j hjs hlj hjh case neg => @@ -923,7 +934,7 @@ mutual right exact a) exact (hph ▸ hb).swap_right hij hhs - case hrtle => exact hrtle.transport_enclosing (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) + case hrtle => exact transport_enclosing hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) case hli => exact hli case hih => exact hih case hlh => exact hlh @@ -952,7 +963,7 @@ mutual apply qsort.sort_loop_sorts case hph => rfl case hrtle => - apply hrtle.transport_enclosing ?_ (Nat.le_refl _) (Nat.le_refl _) + apply transport_enclosing hrtle ?_ (Nat.le_refl _) (Nat.le_refl _) apply IPerm.ite · apply IPerm.swap all_goals @@ -1005,7 +1016,7 @@ mutual case hmh => exact Nat.add_div_two_lt_right.mpr hlh case hrtle => - apply hrtle.transport_enclosing ?hp (Nat.le_refl _) (Nat.le_refl _) + apply transport_enclosing hrtle ?hp (Nat.le_refl _) (Nat.le_refl _) repeat any_goals first | apply Nat.le_refl From cccfc74e556285244c0171211b6c39d41f058c4e Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 11:18:27 +0000 Subject: [PATCH 32/54] use repeat' instead of repeat any_goals --- src/Init/Data/Array/QSort.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 9012a438bbb1..21f71e359a27 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -543,7 +543,7 @@ instance: RestrictableOutOfBounds $α ($T) $ub where $T low high' as := by iterate $intros intro _ apply h - repeat any_goals + repeat' first | assumption | apply Nat.le_trans _ hsh @@ -610,7 +610,7 @@ instance: TransportableEnclosing $α ($T) $ub where iterate $intros intro _ simp [swap_def] repeat rw [getElem_set] - repeat any_goals split + repeat' split all_goals apply h all_goals assumption @@ -1017,7 +1017,7 @@ mutual case hrtle => apply transport_enclosing hrtle ?hp (Nat.le_refl _) (Nat.le_refl _) - repeat any_goals + repeat' first | apply Nat.le_refl | apply Nat.add_div_two_le_right_of_le From ec64dd911c8ec28c26989063a1dbf74cec64860d Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 11:30:52 +0000 Subject: [PATCH 33/54] restore glue_with_pivot --- src/Init/Data/Array/QSort.lean | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 21f71e359a27..8077dc27fff7 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -669,17 +669,20 @@ abbrev IPairwiseLeB (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array namespace IPairwise -/- theorem glue_with_pivot - (ha : as.IForAllIco low (i + 1) (r · pivot)) - (hb : as.IForAllIco (i + 1) (high + 1) (r pivot ·)) - (hrtle : ITrans low high as r) + {r: α → α → Prop} + {p: Nat} (hps: p < as.size) (hlp: low ≤ p) (hph: p ≤ high) (hp: pivot = as[p]'hps) + (ha : IForAllIco (r · pivot) low (i + 1) as) + (hb : IForAllIco (r pivot ·) (i + 1) (high + 1) as) + (hrtle : ITrans r low high as) (h1 : IPairwise r low i as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by unfold IPairwise intro a b hla hab hbh hbs have has := Nat.lt_trans hab hbs + have hlb := Nat.le_trans hla (Nat.le_of_lt hab) + have hah: a ≤ high := Nat.le_trans (Nat.le_of_lt hab) hbh by_cases hbi: b ≤ i · exact h1 a b hla hab hbi hbs @@ -689,10 +692,10 @@ theorem glue_with_pivot · exact h2 a b hia hab hbh hbs have hai: a < i + 1 := by exact Nat.gt_of_not_le hia - specialize ha a has hla hai - specialize hb b hbs hib (Nat.lt_add_one_of_le hbh) - exact hrtle ha hb --/ + + exact hrtle a has hla hah p hps hlp hph b hbs hlb hbh + (hp ▸ (ha a has hla hai)) + (hp ▸ (hb b hbs hib (Nat.lt_add_one_of_le hbh))) theorem glue_with_middle (his: i < as.size) {r: α → α → Prop} From b20952bb5dc2b12007384efb5c4fe5b6b3a2d973 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 12:11:34 +0000 Subject: [PATCH 34/54] object refactoring --- src/Init/Data/Array/QSort.lean | 207 +++++++++++++++++---------------- 1 file changed, 109 insertions(+), 98 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 8077dc27fff7..cf6c39fe7fd7 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -431,11 +431,18 @@ def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x abbrev ICompat (r: α → α → Prop) (r': α → α → Prop) := IForAllIcc2 (λ x y ↦ r x y → r' x y) -class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where - restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) - (hsh: ub (as.size - 1) high): T low high' as - -export RestrictableOutOfBounds (restrict_out_of_bounds) +local macro "elementwise" + n:ident h:ident : tactic => +`(tactic| { + intros + constructor + · apply $n + any_goals assumption + exact $h.1 + · apply $n + any_goals assumption + exact $h.2 +}) class Restrictable (α) (T: Nat → Nat → Array α → Prop) where restrict (ha: T low high as) @@ -444,6 +451,20 @@ class Restrictable (α) (T: Nat → Nat → Array α → Prop) where export Restrictable (restrict) +instance [Restrictable α T1] [Restrictable α T2]: + Restrictable α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) where + restrict h := by elementwise restrict h + +class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where + restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) + (hsh: ub (as.size - 1) high): T low high' as + +export RestrictableOutOfBounds (restrict_out_of_bounds) + +instance [RestrictableOutOfBounds α T1 ub] [RestrictableOutOfBounds α T2 ub]: + RestrictableOutOfBounds α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + restrict_out_of_bounds h := by elementwise restrict_out_of_bounds h + class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where transport_outside (h : T low high as) @@ -453,6 +474,10 @@ class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outP export TransportableOutside (transport_outside) +instance [TransportableOutside α T1 ub] [TransportableOutside α T2 ub]: + TransportableOutside α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + transport_outside h := by elementwise transport_outside h + class LteOp (r: Nat → Nat → Prop) where co: Nat → Nat → Prop of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z @@ -501,7 +526,11 @@ class TransportableEnclosing (α) (T: Nat → Nat → Array α → Prop) (ub: ou export TransportableEnclosing (transport_enclosing) -scoped macro "singleton_inhabited" +instance [TransportableEnclosing α T1 ub] [TransportableEnclosing α T2 ub]: + TransportableEnclosing α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + transport_enclosing h := by elementwise transport_enclosing h + +scoped macro "impl_singleton_inhabited" α:ident "(" T:term ")" intros:num : command => @@ -519,144 +548,126 @@ instance {k: Nat} {as: Array $α}: | done ) -scoped macro "transport_lemmas_outside" +scoped macro "impl_transport_outside" α:ident "(" T:term ")" "(" ub:term ")" intros:num : command => `( -instance: Restrictable $α ($T) where - restrict {low high: Nat} {as: Array $α} {low' high': Nat} (h: $T low high as) - (hll: low ≤ low') (hhh: high' ≤ high) - : $T low' high' as := by - iterate $intros intro _ - apply h - all_goals - try first - | apply Nat.le_trans hll _ - | apply Nat.le_trans _ hhh - assumption - -instance: RestrictableOutOfBounds $α ($T) $ub where - restrict_out_of_bounds {low high: Nat} {as: Array $α} {high': Nat} (h: $T low high as) - (hsh: $ub (as.size - 1) high): - $T low high' as := by - iterate $intros intro _ - apply h - repeat' - first - | assumption - | apply Nat.le_trans _ hsh - | apply Nat.succ_le_succ - | apply Nat.le_sub_one_of_lt - -instance: TransportableOutside $α ($T) $ub where - transport_outside {low high: Nat} {as: Array $α} {plow phigh: Nat} {as': Array $α} - (h : $T low high as) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: $ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - $T low high as' := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as i his hli hih j hjs hlj hjh => + instance: Restrictable $α ($T) where + restrict h hll hhh := by iterate $intros intro _ - simp only [swap_def] - repeat rw [getElem_set_ne] - · apply h - all_goals assumption + apply h all_goals - intro he - subst_eqs + try first + | apply Nat.le_trans hll _ + | apply Nat.le_trans _ hhh + assumption + + instance: RestrictableOutOfBounds $α ($T) $ub where + restrict_out_of_bounds h hsh := by + iterate $intros intro _ + apply h + repeat' first - | apply hd i - all_goals - first - | assumption - | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) - | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) - | apply hd j - all_goals - first - | assumption - | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) - | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | assumption + | apply Nat.le_trans _ hsh + | apply Nat.succ_le_succ + | apply Nat.le_sub_one_of_lt + + instance: TransportableOutside $α ($T) $ub where + transport_outside h hp hd := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as i his hli hih j hjs hlj hjh => + iterate $intros intro _ + simp only [swap_def] + repeat rw [getElem_set_ne] + · apply h + all_goals assumption + all_goals + intro he + subst_eqs + first + | apply hd i + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | apply hd j + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) ) -set_option hygiene false in -scoped macro "transport_lemmas" +scoped macro "impl_transport" α:ident "(" T:term ")" "(" ub:term ")" intros:num : command => `( - transport_lemmas_outside $α ($T) ($ub) $intros - -instance: TransportableEnclosing $α ($T) $ub where - transport_enclosing {low high: Nat} {as: Array $α} {plow phigh: Nat} {as': Array $α} - (h : $T low high as) - (hp : IPerm plow phigh as as') - (hll: low ≤ plow) - (hhh: $ub phigh high) : - $T low high as' := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as a has hpla haph b hbs hplb hbph => - have hla := Nat.le_trans hll hpla - have hlb := Nat.le_trans hll hplb - have hah := LteOp.of_le_of haph hhh - have hbh := LteOp.of_le_of hbph hhh - iterate $intros intro _ - simp [swap_def] - repeat rw [getElem_set] - repeat' split - all_goals - apply h - all_goals assumption + impl_transport_outside $α ($T) ($ub) $intros + + instance: TransportableEnclosing $α ($T) $ub where + transport_enclosing h hp hll hhh := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := LteOp.of_le_of haph hhh + have hbh := LteOp.of_le_of hbph hhh + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set] + repeat' split + all_goals + apply h + all_goals assumption ) -def problem (i i' high: Nat) (hij' : i' < i) - (hjh' : i ≤ high): i' < high := by - apply Nat.lt_of_lt_of_le (m := i) (by assumption) (by assumption) - namespace IPairwise variable {α} {P: α → α → Prop} -singleton_inhabited α (IPairwise P) 6 -transport_lemmas_outside α (IPairwise P) (LE.le) 6 +impl_singleton_inhabited α (IPairwise P) 6 +impl_transport_outside α (IPairwise P) (LE.le) 6 end IPairwise namespace IForAllIco variable {α} {P: α → Prop} -singleton_inhabited α (IForAllIco P) 4 -transport_lemmas α (IForAllIco P) (LT.lt) 4 +impl_singleton_inhabited α (IForAllIco P) 4 +impl_transport α (IForAllIco P) (LT.lt) 4 end IForAllIco namespace IForAllIcc variable {α} {P: α → Prop} -transport_lemmas α (IForAllIcc P) (LE.le) 4 +impl_transport α (IForAllIcc P) (LE.le) 4 end IForAllIcc namespace IForAllIcc2 variable {α} {P: α → α → Prop} -transport_lemmas α (IForAllIcc2 P) (LE.le) 8 +impl_transport α (IForAllIcc2 P) (LE.le) 8 end IForAllIcc2 namespace IForAllIcc3 variable {α} {P: α → α → α → Prop} -transport_lemmas α (IForAllIcc3 P) (LE.le) 12 +impl_transport α (IForAllIcc3 P) (LE.le) 12 end IForAllIcc3 /- namespace IForAllIcc2I variable {α} {P: Nat → Nat → α → α → Prop} -transport_lemmas_outside α (IForAllIcc2I P) (LE.le) 8 +impl_transport_outside α (IForAllIcc2I P) (LE.le) 8 end IForAllIcc2I -/ From f6b5d88ea5fccc39604e92a7b8a93f48401df99a Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 12:16:13 +0000 Subject: [PATCH 35/54] fixes --- src/Init/Data/Array/QSort.lean | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index cf6c39fe7fd7..4ec82f4cb0f7 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -856,8 +856,6 @@ mutual · exact Nat.lt_add_one high case hpi => subst pivot - simp only [as', ahs'] at h2 -- needed? - by_cases h0i: 0 < i · rw [h1.perm.getElem_higher] rw [h2.perm.getElem_lower] @@ -868,8 +866,7 @@ mutual subst i have: low = 0 := by exact Nat.eq_zero_of_le_zero hli subst low - simp_all - simp [h1.perm.eq_of_trivial] + simp only [Nat.le_refl, h1.perm.eq_of_trivial] rw [h2.perm.getElem_lower] exact Nat.one_pos From 8b598e51e91ce81de6b3af1cc5fae4b778211bc5 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 15:55:54 +0000 Subject: [PATCH 36/54] refactor --- src/Init/Data/Array/QSort.lean | 304 +++++++++++++++++++++------------ 1 file changed, 193 insertions(+), 111 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 4ec82f4cb0f7..3320d5071e38 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -432,18 +432,49 @@ abbrev ICompat (r: α → α → Prop) (r': α → α → Prop) := IForAllIcc2 (λ x y ↦ r x y → r' x y) local macro "elementwise" - n:ident h:ident : tactic => + t:term : tactic => `(tactic| { intros constructor - · apply $n - any_goals assumption + all_goals + apply $t + all_goals assumption +}) + +local macro "elementwise" + t:term "using" h:ident : tactic => +`(tactic| { + intros + constructor + · apply $t + try any_goals assumption exact $h.1 - · apply $n - any_goals assumption + · apply $t + try any_goals assumption exact $h.2 }) +class Trivial (α) (T: Nat → Nat → Array α → Prop) (ub': Nat → Nat → Prop) where + trivial (hll: ub' high low): T low high as + +export Trivial (trivial) + +instance [Trivial α T1 ub'] [Trivial α T2 ub']: + Trivial α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub' where + trivial hhl := by elementwise trivial hhl + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k k as) where + default := trivial (Nat.le_refl _) + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k (k - 1) as) where + default := trivial (Nat.sub_le k 1) + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T (k + 1) k as) where + default := trivial (Nat.le_add_right k 1) + +instance {k: Nat} {as: Array α} [Trivial α T LT.lt]: Inhabited (T (k + 1) k as) where + default := trivial (Nat.lt_add_one k) + class Restrictable (α) (T: Nat → Nat → Array α → Prop) where restrict (ha: T low high as) (hll: low ≤ low') (hhh: high' ≤ high) @@ -453,7 +484,7 @@ export Restrictable (restrict) instance [Restrictable α T1] [Restrictable α T2]: Restrictable α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) where - restrict h := by elementwise restrict h + restrict h := by elementwise restrict using h class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) @@ -463,7 +494,7 @@ export RestrictableOutOfBounds (restrict_out_of_bounds) instance [RestrictableOutOfBounds α T1 ub] [RestrictableOutOfBounds α T2 ub]: RestrictableOutOfBounds α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - restrict_out_of_bounds h := by elementwise restrict_out_of_bounds h + restrict_out_of_bounds h := by elementwise restrict_out_of_bounds using h class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where transport_outside @@ -476,22 +507,28 @@ export TransportableOutside (transport_outside) instance [TransportableOutside α T1 ub] [TransportableOutside α T2 ub]: TransportableOutside α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - transport_outside h := by elementwise transport_outside h + transport_outside h := by elementwise transport_outside using h class LteOp (r: Nat → Nat → Prop) where co: Nat → Nat → Prop of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z not: ¬(co a b) ↔ (r b a) + succ: Nat → Nat + r_succ: ∀ x, r x (succ x) instance: LteOp (LE.le) where co := LT.lt of_le_of xy yz := Nat.le_trans xy yz not := Nat.not_lt + succ x := x + r_succ x := Nat.le_refl x instance: LteOp (LT.lt) where co := LE.le of_le_of xy yz := Nat.lt_of_le_of_lt xy yz not := Nat.not_le + succ x := (x + 1) + r_succ x := Nat.lt_add_one x theorem transport_lower {α} {T: Nat → Nat → Array α → Prop} [TransportableOutside α T r] [LteOp r] @@ -528,32 +565,64 @@ export TransportableEnclosing (transport_enclosing) instance [TransportableEnclosing α T1 ub] [TransportableEnclosing α T2 ub]: TransportableEnclosing α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - transport_enclosing h := by elementwise transport_enclosing h + transport_enclosing h := by elementwise transport_enclosing using h -scoped macro "impl_singleton_inhabited" +theorem transport_exact_icc {α} {T: Nat → Nat → Array α → Prop} + [TransportableEnclosing α T LE.le] + {low high: Nat} {as: Array α} {as': Array α} + (h : T low high as) + (hp : IPerm low high as as'): + T low high as' := by + apply transport_enclosing h hp + · exact Nat.le_refl _ + · exact Nat.le_refl high + +theorem transport_exact_ico {α} {T: Nat → Nat → Array α → Prop} + [TransportableEnclosing α T LT.lt] + {low high: Nat} {as: Array α} {as': Array α} + (h : T low (high + 1) as) + (hp : IPerm low high as as'): + T low (high + 1) as' := by + apply transport_enclosing h hp + · exact Nat.le_refl _ + · exact Nat.lt_add_one high + +set_option hygiene false in +scoped macro "impl_trivial" α:ident "(" T:term ")" + "(" ub'':term ")" intros:num : command => `( -instance {k: Nat} {as: Array $α}: - Inhabited ($T k k as) where - default := by - iterate $intros intro _ - exfalso - suffices hkk: k < k by - exact (Nat.ne_of_lt hkk) rfl - first - | exact Nat.lt_of_le_of_lt (by assumption) (by assumption) - | exact Nat.lt_of_le_of_lt (by assumption) (Nat.lt_of_lt_of_le (by assumption) (by assumption)) - | done + instance: Trivial $α ($T) $ub'' where + trivial hhl := by + iterate $intros intro _ + exfalso + suffices hlh: $ub'' _ _ by + first + | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hlh hhl) + | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hhl hlh) + | done + + try rw [Nat.lt_succ] + first + | exact Nat.lt_of_le_of_lt (by assumption) (by assumption) + | exact Nat.le_trans (by assumption) (by assumption) + | exact Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption)) + | exact Nat.lt_of_le_of_lt (by assumption) (Nat.lt_of_lt_of_le (by assumption) (by assumption)) + | exact Nat.le_trans (by assumption) (Nat.le_trans (Nat.le_of_lt (by assumption)) (by assumption)) + | done ) scoped macro "impl_transport_outside" α:ident "(" T:term ")" "(" ub:term ")" + "(" ub':term ")" intros:num : command => `( + impl_trivial $α ($T) ($ub') $intros + instance: Restrictable $α ($T) where restrict h hll hhh := by iterate $intros intro _ @@ -574,6 +643,7 @@ scoped macro "impl_transport_outside" | apply Nat.le_trans _ hsh | apply Nat.succ_le_succ | apply Nat.le_sub_one_of_lt + | done instance: TransportableOutside $α ($T) $ub where transport_outside h hp hd := by @@ -596,21 +666,24 @@ scoped macro "impl_transport_outside" | assumption | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | done | apply hd j all_goals first | assumption | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | done ) scoped macro "impl_transport" α:ident "(" T:term ")" "(" ub:term ")" + "(" ub':term ")" intros:num : command => `( - impl_transport_outside $α ($T) ($ub) $intros + impl_transport_outside $α ($T) ($ub) ($ub') $intros instance: TransportableEnclosing $α ($T) $ub where transport_enclosing h hp hll hhh := by @@ -634,33 +707,32 @@ scoped macro "impl_transport" namespace IPairwise variable {α} {P: α → α → Prop} -impl_singleton_inhabited α (IPairwise P) 6 -impl_transport_outside α (IPairwise P) (LE.le) 6 +impl_trivial α (IPairwise P) (LE.le) 6 +impl_transport_outside α (IPairwise P) (LE.le) (LT.lt) 6 end IPairwise namespace IForAllIco variable {α} {P: α → Prop} -impl_singleton_inhabited α (IForAllIco P) 4 -impl_transport α (IForAllIco P) (LT.lt) 4 +impl_transport α (IForAllIco P) (LT.lt) (LE.le) 4 end IForAllIco namespace IForAllIcc variable {α} {P: α → Prop} -impl_transport α (IForAllIcc P) (LE.le) 4 +impl_transport α (IForAllIcc P) (LE.le) (LT.lt) 4 end IForAllIcc namespace IForAllIcc2 variable {α} {P: α → α → Prop} -impl_transport α (IForAllIcc2 P) (LE.le) 8 +impl_transport α (IForAllIcc2 P) (LE.le) (LT.lt) 8 end IForAllIcc2 namespace IForAllIcc3 variable {α} {P: α → α → α → Prop} -impl_transport α (IForAllIcc3 P) (LE.le) 12 +impl_transport α (IForAllIcc3 P) (LE.le) (LT.lt) 12 end IForAllIcc3 /- @@ -709,6 +781,7 @@ theorem glue_with_pivot (hp ▸ (hb b hbs hib (Nat.lt_add_one_of_le hbh))) theorem glue_with_middle + (i : Nat) (his: i < as.size) {r: α → α → Prop} (ha : IForAllIco (r · (as[i]'his)) low i as) (hb : IForAllIco (r (as[i]'his) ·) (i + 1) (high + 1) as) @@ -748,7 +821,8 @@ theorem glue_with_middle exact (hb hab) theorem glue_with_middle_eq_pivot - {r : α → α → Prop} {low high : Nat} {i : Nat} {as : Array α} + {r : α → α → Prop} {low high : Nat} {as : Array α} + (i : Nat) (pivot: α) (his: i < as.size) (hpi: as[i]'his = pivot) (ha : as.IForAllIco (r · pivot) low i) @@ -758,7 +832,7 @@ theorem glue_with_middle_eq_pivot (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by subst pivot - apply glue_with_middle + apply glue_with_middle i all_goals assumption end IPairwise @@ -785,8 +859,15 @@ abbrev ISortOfLeB (r: α → α → Bool) (low high: Nat) (orig: Array α) (sort := ISortOf (le_of_relation r) low high orig sorted namespace ISortOf -theorem mkSingle (r: α → α → Prop) (k: Nat) (as0: Array α) (as: Array α) (hp: IPerm k k as0 as): - ISortOf r k k as0 as := ⟨hp, default⟩ +instance [Trivial α (IPairwise r) ub']: + Trivial α (λ low high as ↦ ISortOf r low high as as) ub' where + trivial hhl := by + constructor + case perm => exact IPerm.refl + case ord => exact trivial hhl + +def trivial {high low: Nat} (hhl: high ≤ low): ISortOf r low high as as := + instTrivialOfIPairwise.trivial hhl theorem trans (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): @@ -802,6 +883,7 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) case ord => exact restrict_out_of_bounds h.ord hsh end ISortOf + mutual theorem qsort.sort_sort_sorts (r: α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hlh: low < high) (hli : low ≤ i) (hih : i ≤ high) (hhs : high < as.size) @@ -815,18 +897,20 @@ mutual have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs - have h1 := qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) (restrict hrtle (Nat.le_refl _) h1ih) + have h1 := by + apply qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) ?_ + apply restrict hrtle (Nat.le_refl low) h1ih let ahs' := qsort.sort r as low (i - 1) (λ _ ↦ h1is) let as' := ahs'.1 let hs' := ahs'.2 + have his': i < as'.size := Nat.lt_of_lt_of_eq his hs'.symm have h2 := by - apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) (transport_higher (restrict hrtle ?_ ?_) h1.perm ?_) - · exact Nat.le_add_right_of_le hli - · exact Nat.le_refl _ - · exact Nat.sub_lt_succ i 1 + apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) ?_ + apply transport_higher ?_ h1.perm (Nat.sub_lt_succ i 1) + exact restrict hrtle (Nat.le_succ_of_le hli) (Nat.le_refl high) - constructor + apply ISortOf.mk case perm => apply IPerm.trans · apply IPerm.expand (Nat.le_refl _) h1ih h1.perm @@ -834,37 +918,33 @@ mutual case ord => apply IPairwise.glue_with_middle_eq_pivot - case hrtle => - apply transport_enclosing (transport_enclosing hrtle h1.perm ?_ ?_) h2.perm ?_ ?_ - · exact Nat.le_refl _ - · exact h1ih - · exact Nat.le_add_right_of_le hli - · exact Nat.le_refl _ case i => exact i case his => simpa [qsort.size_sort] + case pivot => exact pivot + + case hrtle => + apply transport_enclosing ?_ h2.perm (Nat.le_add_right_of_le hli) (Nat.le_refl high) + exact transport_enclosing hrtle h1.perm (Nat.le_refl _) h1ih + case ha => - apply restrict (transport_lower (transport_enclosing ha h1.perm ?_ ?_) h2.perm ?_) ?_ ?_ - · exact Nat.le_refl _ - · exact Nat.sub_lt_succ i 1 - · exact Nat.le_refl (i + 1) - · exact Nat.le_refl low - · exact Nat.le_add_right i 1 + apply restrict ?_ (Nat.le_refl low) (Nat.le_add_right i 1) + apply transport_lower ?_ h2.perm (Nat.le_refl (i + 1)) + exact transport_enclosing ha h1.perm (Nat.le_refl low) (Nat.sub_lt_succ i 1) + case hb => - apply transport_enclosing (transport_higher hb h1.perm ?_) h2.perm ?_ ?_ - · exact Nat.sub_lt_succ i 1 - · exact Nat.le_refl _ - · exact Nat.lt_add_one high + apply transport_exact_ico ?_ h2.perm + exact transport_higher hb h1.perm (Nat.sub_lt_succ i 1) + case hpi => subst pivot by_cases h0i: 0 < i - · rw [h1.perm.getElem_higher] - rw [h2.perm.getElem_lower] - · exact Nat.lt_add_one i - · exact Nat.lt_of_lt_of_eq his hs'.symm - · exact Nat.sub_one_lt_of_lt h0i - · have h0i: i = 0 := by exact Nat.eq_zero_of_not_pos h0i + · rw [h1.perm.getElem_higher (Nat.sub_one_lt_of_lt h0i)] + rw [h2.perm.getElem_lower (Nat.le_refl i.succ)] + exact his' + · -- degenerate case when i - 1 saturates, unfortunately have to handle it explicitly + have h0i: i = 0 := Nat.eq_zero_of_not_pos h0i subst i - have: low = 0 := by exact Nat.eq_zero_of_le_zero hli + have: low = 0 := Nat.eq_zero_of_le_zero hli subst low simp only [Nat.le_refl, h1.perm.eq_of_trivial] rw [h2.perm.getElem_lower] @@ -872,7 +952,10 @@ mutual case h1 => apply transport_lower h1.ord h2.perm (Nat.sub_lt_succ i 1) - case h2 => exact h2.ord + + case h2 => + exact h2.ord + termination_by (high - low, 0, 0) theorem qsort.sort_loop_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) @@ -899,62 +982,65 @@ mutual case pos => apply ISortOf.trans + case hp => + exact .swap as i his hli hih j hjs hlj hjh case hs => apply qsort.sort_loop_sorts case hph => simpa only [getElem_after_swap _ hij hjh' hhs] case ha => exact ha.swap_left hij hjp case hb => exact hb.swap_right hij hjs - case hrtle => exact transport_enclosing hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) - case hp => exact .swap as i his hli hih j hjs hlj hjh + case hrtle => exact transport_exact_icc hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) case neg => - apply ISortOf.trans - case hs => - apply qsort.sort_loop_sorts - case hph => exact hph - case ha => - exact ha - - case hb => - intro k hks hik hkj1 - by_cases hkj: k < j - · specialize hb k hks hik hkj - exact hb - · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj - subst k - exact eq_false_of_ne_true hjp - - case hrtle => exact hrtle - case hp => exact .refl + apply qsort.sort_loop_sorts + case hph => exact hph + case ha => + exact ha + + case hb => + intro k hks hik hkj1 + by_cases hkj: k < j + · specialize hb k hks hik hkj + exact hb + · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj + subst k + exact eq_false_of_ne_true hjp + + case hrtle => exact hrtle case neg => have hjh: j = high := Nat.le_antisymm hjh (Nat.le_of_not_lt hjh') subst j apply ISortOf.trans + case hp => + exact IPerm.swap as i his hli hih high hhs (Nat.le_of_lt hlh) (Nat.le_refl _) + case hs => apply qsort.sort_sort_sorts + case hli => exact hli + case hih => exact hih + case hlh => exact hlh case hhs => simpa [size_swap] + case ha => let ha: IForAllIco (le_of_relation r · pivot) low i as := ha.map (λ x a ↦ by left exact a) - exact (hph ▸ ha).swap_left hij (le_of_relation_refl r _) + case hb => let hb: IForAllIco (le_of_relation r pivot ·) i high as := hb.map (λ x a ↦ by right exact a) exact (hph ▸ hb).swap_right hij hhs - case hrtle => exact transport_enclosing hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) (Nat.le_refl _) (Nat.le_refl _) - case hli => exact hli - case hih => exact hih - case hlh => exact hlh + + case hrtle => + exact transport_exact_icc hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) + case hpi => simp only [swap_def, get_eq_getElem, getElem_set, getElem_set_eq, ite_eq_right_iff, ↓reduceIte] intro h simp only [h] - case hp => - exact IPerm.swap as i his hli hih high hhs (Nat.le_of_lt hlh) (Nat.le_refl _) termination_by (high - low, 1, high - j) theorem qsort.sort_loop_pivot_swap_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) @@ -970,6 +1056,7 @@ mutual have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) apply ISortOf.trans + case hs => apply qsort.sort_loop_sorts case hph => rfl @@ -988,6 +1075,7 @@ mutual have hll: low < low := Nat.lt_of_le_of_lt hlk hkl exfalso exact (Nat.ne_of_lt hll) rfl + case hp => split case isTrue h => @@ -1001,19 +1089,11 @@ mutual (hrtle: ITransLeB r low high as): ISortOfLeB r low high as (qsort.sort r as low high hhs) := by unfold qsort.sort - by_cases hlh: low ≥ high + + by_cases hlh: high ≤ low case pos => - simp [hlh] - constructor - case ord => - intro i j hli hij hjh hjs - have hlh' := Nat.lt_of_le_of_lt hli (Nat.lt_of_lt_of_le hij hjh) - exfalso - have hlh'': ¬(low ≥ high) := by - exact Nat.not_le_of_lt hlh' - exact hlh'' hlh - case perm => - exact IPerm.refl + simp only [ge_iff_le, hlh, ↓reduceDIte] + exact ISortOf.trivial hlh case neg => simp only [hlh] have hlh: low < high := Nat.gt_of_not_le hlh @@ -1028,15 +1108,17 @@ mutual case hrtle => apply transport_enclosing hrtle ?hp (Nat.le_refl _) (Nat.le_refl _) - repeat' - first - | apply Nat.le_refl - | apply Nat.add_div_two_le_right_of_le - | apply Nat.left_le_add_div_two.mpr - | apply IPerm.refl - | apply IPerm.ite - | apply IPerm.trans_swap - | assumption + + case hp => + repeat' + first + | apply Nat.le_refl + | apply Nat.add_div_two_le_right_of_le + | apply Nat.left_le_add_div_two.mpr + | apply IPerm.refl + | apply IPerm.ite + | apply IPerm.trans_swap + | assumption termination_by ((sizeOf high) - (sizeOf low), 3, 0) end From 72d6d3080e93b6c5674f182f6c758f86552c4eb8 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 18:19:43 +0000 Subject: [PATCH 37/54] Proof is now as strict as possible --- src/Init/Data/Array/QSort.lean | 212 +++++++++++++++++++++------------ 1 file changed, 133 insertions(+), 79 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 3320d5071e38..dde262d82bb2 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -64,7 +64,7 @@ end Nat namespace Array -@[inline] def qsort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) : Array α := +@[inline] def qsort (as : Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := let s := as.size @@ -85,13 +85,13 @@ namespace Array have hmh: mid ≤ high := Nat.add_div_two_le_right_of_le (Nat.le_of_lt hlh) have hms: mid < s := Nat.lt_of_le_of_lt hmh hhs - let as := if r (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as + let as := if f (as[mid]'(hs ▸ hms)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨mid, hs ▸ hms⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let as := if r (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as + let as := if f (as[high]'(hs ▸ hhs)) (as[low]'(hs ▸ hls)) then as.swap ⟨low, hs ▸ hls⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] - let as := if r (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as + let as := if f (as[mid]'(hs ▸ hms)) (as[high]'(hs ▸ hhs)) then as.swap ⟨mid, hs ▸ hms⟩ ⟨high, hs ▸ hhs⟩ else as have hs: as.size = s := by dsimp only [as]; split; all_goals simp_all only [Array.size_swap] let pivot := as[high]'(hs ▸ hhs) @@ -106,7 +106,7 @@ namespace Array if hjh' : j < high then have hjs: j < s := Nat.lt_trans hjh' hhs - if r (as[j]'(hs ▸ hjs)) pivot then + if f (as[j]'(hs ▸ hjs)) pivot then let as := as.swap ⟨i, hs ▸ his⟩ ⟨j, hs ▸ hjs⟩ have hs: as.size = s := by simp_all only [as, Array.size_swap] @@ -156,13 +156,13 @@ namespace Array (sort as low (if high < as.size then high else as.size - 1) hhs).1 -@[simp] theorem qsort.size_sort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) +@[simp] theorem qsort.size_sort (as : Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size): - (qsort.sort r as low high hhs).1.size = as.size := by - exact (qsort.sort r as low high hhs).2 + (qsort.sort f as low high hhs).1.size = as.size := by + exact (qsort.sort f as low high hhs).2 -@[simp] theorem size_qsort (as : Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1): - (qsort as r low high).size = as.size := by +@[simp] theorem size_qsort (as : Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1): + (qsort as f low high).size = as.size := by unfold qsort split all_goals exact (qsort.sort _ _ _ _ _).2 @@ -416,20 +416,69 @@ abbrev ITrans (r: α → α → Prop) := If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] -/ -abbrev le_of_relation (r: α → α → Bool) (i j: α) := r i j = true ∨ r j i = false +abbrev Completion (r: α → α → Prop) := λ x y ↦ r x y ∨ ¬r y x -abbrev ITransLeB (r: α → α → Bool) := - ITrans (le_of_relation r) +namespace Completion -def le_of_relation_refl (r: α → α → Bool) (x: α): (le_of_relation r) x x := by +def pos (h: r x y): Completion r x y := by + left + exact h + +def neg (h: ¬r y x): Completion r x y := by + right + exact h + +def wtotal (h: ¬Completion r x y): Completion r y x := by + right + intro h' + exact h (Or.inl h') + +def refl [DecidableRel r] (x): Completion r x x := by by_cases h: r x x + · exact pos h + · exact neg h + +def stotal [DecidableRel r]: Completion r x y ∨ Completion r y x := by + by_cases h: Completion r x y · left exact h · right - exact eq_false_of_ne_true h + exact wtotal h + +end Completion + +abbrev ICompat (hr: α → α → Prop) (r: α → α → Prop) := + IForAllIcc2 (λ x y ↦ hr x y → r x y) -abbrev ICompat (r: α → α → Prop) (r': α → α → Prop) := - IForAllIcc2 (λ x y ↦ r x y → r' x y) +abbrev ITransCompat (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := + (ICompat hr r low high as) ∧ (ITrans r low high as) + +abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := + ITransCompat (Completion (f · ·)) r low high as + +inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop +| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) + (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) +| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c + +namespace ITransCompat + +def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 +def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 + +def mkITransGen: ITransCompatCB f (ITransGen (Completion (f · ·)) low high as) low high as := by + constructor + · apply ITransGen.base + · intro i his _ _ j hjs _ _ k hks _ _ + apply ITransGen.trans + +end ITransCompat + +namespace ITransCompatCB + +export ITransCompat (compat trans) + +end ITransCompatCB local macro "elementwise" t:term : tactic => @@ -743,13 +792,6 @@ impl_transport_outside α (IForAllIcc2I P) (LE.le) 8 end IForAllIcc2I -/ -/-- -If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] -If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] - -/ -abbrev IPairwiseLeB (r: α → α → Bool) (low: Nat) (high: Nat) (as: Array α) := - IPairwise (le_of_relation (r · ·)) low high as - namespace IPairwise theorem glue_with_pivot @@ -757,7 +799,7 @@ theorem glue_with_pivot {p: Nat} (hps: p < as.size) (hlp: low ≤ p) (hph: p ≤ high) (hp: pivot = as[p]'hps) (ha : IForAllIco (r · pivot) low (i + 1) as) (hb : IForAllIco (r pivot ·) (i + 1) (high + 1) as) - (hrtle : ITrans r low high as) + (hrel : ITrans r low high as) (h1 : IPairwise r low i as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -776,7 +818,7 @@ theorem glue_with_pivot have hai: a < i + 1 := by exact Nat.gt_of_not_le hia - exact hrtle a has hla hah p hps hlp hph b hbs hlb hbh + exact hrel a has hla hah p hps hlp hph b hbs hlb hbh (hp ▸ (ha a has hla hai)) (hp ▸ (hb b hbs hib (Nat.lt_add_one_of_le hbh))) @@ -785,7 +827,7 @@ theorem glue_with_middle (his: i < as.size) {r: α → α → Prop} (ha : IForAllIco (r · (as[i]'his)) low i as) (hb : IForAllIco (r (as[i]'his) ·) (i + 1) (high + 1) as) - (hrtle : ITrans r low high as) + (hrel : ITrans r low high as) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -812,7 +854,7 @@ theorem glue_with_middle by_cases hai': a < i · by_cases hib': i < b - · exact hrtle a has hla hah i his hli hih b hbs hlb hbh (ha hai') (hb hib') + · exact hrel a has hla hah i his hli hih b hbs hlb hbh (ha hai') (hb hib') · have hib: i = b := by exact Nat.le_antisymm hib (Nat.le_of_not_lt hib') subst b exact (ha hai') @@ -827,7 +869,7 @@ theorem glue_with_middle_eq_pivot (hpi: as[i]'his = pivot) (ha : as.IForAllIco (r · pivot) low i) (hb : as.IForAllIco (r pivot ·) (i + 1) (high + 1)) - (hrtle : ITrans r low high as) + (hrel : ITrans r low high as) (h1 : IPairwise r low (i - 1) as) (h2 : IPairwise r (i + 1) high as): IPairwise r low high as := by @@ -855,9 +897,6 @@ structure ISortOf (r: α → α → Prop) (low high: Nat) (orig: Array α) (sort perm: IPerm low high orig sorted ord: IPairwise r low high sorted -abbrev ISortOfLeB (r: α → α → Bool) (low high: Nat) (orig: Array α) (sorted: Array α): Prop - := ISortOf (le_of_relation r) low high orig sorted - namespace ISortOf instance [Trivial α (IPairwise r) ub']: Trivial α (λ low high as ↦ ISortOf r low high as as) ub' where @@ -885,30 +924,30 @@ end ISortOf mutual - theorem qsort.sort_sort_sorts (r: α → α → Bool) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) + theorem qsort.sort_sort_sorts (f: α → α → Bool) (r: α → α → Prop) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) (hlh: low < high) (hli : low ≤ i) (hih : i ≤ high) (hhs : high < as.size) (hpi: as[i]'(Nat.lt_of_le_of_lt hih hhs) = pivot) - (ha: IForAllIco ((le_of_relation r) · pivot) low (i + 1) as) - (hb: IForAllIco ((le_of_relation r) pivot ·) (i + 1) (high + 1) as) - (hrtle: ITransLeB r low high as): - have ⟨as', hs'⟩ := qsort.sort r as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) - ISortOfLeB r low high as (qsort.sort r as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by + (ha: IForAllIco (r · pivot) low (i + 1) as) + (hb: IForAllIco (r pivot ·) (i + 1) (high + 1) as) + (hrel: ITransCompatCB f r low high as): + have ⟨as', hs'⟩ := qsort.sort f as low (i - 1) (λ _ ↦ Nat.lt_of_le_of_lt (Nat.sub_le i 1) (Nat.lt_of_le_of_lt hih hhs)) + ISortOf r low high as (qsort.sort f as' (i + 1) high (λ _ ↦ hs' ▸ hhs)) := by have his := Nat.lt_of_le_of_lt hih hhs have h1ih: i - 1 ≤ high := Nat.le_trans (Nat.sub_le i 1) hih have h1is: i - 1 < as.size := Nat.lt_of_le_of_lt h1ih hhs have h1 := by - apply qsort.sort_sorts as r low (i - 1) (λ _ ↦ h1is) ?_ - apply restrict hrtle (Nat.le_refl low) h1ih + apply qsort.sort_sorts as f r low (i - 1) (λ _ ↦ h1is) ?_ + apply restrict hrel (Nat.le_refl low) h1ih - let ahs' := qsort.sort r as low (i - 1) (λ _ ↦ h1is) + let ahs' := qsort.sort f as low (i - 1) (λ _ ↦ h1is) let as' := ahs'.1 let hs' := ahs'.2 have his': i < as'.size := Nat.lt_of_lt_of_eq his hs'.symm have h2 := by - apply qsort.sort_sorts as' r (i + 1) high (λ _ ↦ hs' ▸ hhs) ?_ + apply qsort.sort_sorts as' f r (i + 1) high (λ _ ↦ hs' ▸ hhs) ?_ apply transport_higher ?_ h1.perm (Nat.sub_lt_succ i 1) - exact restrict hrtle (Nat.le_succ_of_le hli) (Nat.le_refl high) + exact restrict hrel (Nat.le_succ_of_le hli) (Nat.le_refl high) apply ISortOf.mk case perm => @@ -922,9 +961,9 @@ mutual case his => simpa [qsort.size_sort] case pivot => exact pivot - case hrtle => + case hrel => apply transport_enclosing ?_ h2.perm (Nat.le_add_right_of_le hli) (Nat.le_refl high) - exact transport_enclosing hrtle h1.perm (Nat.le_refl _) h1ih + exact transport_enclosing hrel.trans h1.perm (Nat.le_refl _) h1ih case ha => apply restrict ?_ (Nat.le_refl low) (Nat.le_add_right i 1) @@ -958,13 +997,13 @@ mutual termination_by (high - low, 0, 0) - theorem qsort.sort_loop_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) + theorem qsort.sort_loop_sorts (f: α → α → Bool) (r: α → α → Prop) (low high : Nat) (hlh: low < high) (as: Array α) (i j : Nat) (hli : low ≤ i) (hij : i ≤ j) (hjh : j ≤ high) (hhs : high < as.size) (hph: as[high]'hhs = pivot) (ha: IForAllIco (r · pivot) low i as) - (hb: IForAllIco (r · pivot = false) i j as) - (hrtle: ITransLeB r low high as): - ISortOfLeB r low high as (qsort.sort.loop r low high hlh pivot as i j hli hij hjh hhs) := by + (hb: IForAllIco (r pivot ·) i j as) + (hrel: ITransCompatCB f r low high as): + ISortOf r low high as (qsort.sort.loop f low high hlh pivot as i j hli hij hjh hhs) := by unfold qsort.sort.loop have hjs: j < as.size := Nat.lt_of_le_of_lt hjh hhs @@ -977,21 +1016,23 @@ mutual case pos => have hjs: j < as.size := Nat.lt_trans hjh' hhs - by_cases hjp: r (as[j]'hjs) pivot = true + by_cases hjp: f (as[j]'hjs) pivot = true all_goals simp only [hjp, Bool.false_eq_true, ↓reduceIte] case pos => + have hrjp := hrel.compat j hjs hlj hjh high hhs (Nat.le_trans hli hih) (Nat.le_refl high) (.pos (hph ▸ hjp)) apply ISortOf.trans case hp => exact .swap as i his hli hih j hjs hlj hjh case hs => apply qsort.sort_loop_sorts case hph => simpa only [getElem_after_swap _ hij hjh' hhs] - case ha => exact ha.swap_left hij hjp + case ha => exact ha.swap_left hij (hph ▸ hrjp) case hb => exact hb.swap_right hij hjs - case hrtle => exact transport_exact_icc hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) + case hrel => exact transport_exact_icc hrel (IPerm.swap _ _ _ hli hih _ _ hlj hjh) case neg => + have hrjp := hrel.compat high hhs (Nat.le_trans hli hih) (Nat.le_refl high) j hjs hlj hjh (.neg (hph ▸ hjp)) apply qsort.sort_loop_sorts case hph => exact hph case ha => @@ -1004,9 +1045,9 @@ mutual exact hb · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj subst k - exact eq_false_of_ne_true hjp + exact hph ▸ hrjp - case hrtle => exact hrtle + case hrel => exact hrel case neg => have hjh: j = high := Nat.le_antisymm hjh (Nat.le_of_not_lt hjh') @@ -1023,19 +1064,17 @@ mutual case hhs => simpa [size_swap] case ha => - let ha: IForAllIco (le_of_relation r · pivot) low i as := ha.map (λ x a ↦ by - left - exact a) - exact (hph ▸ ha).swap_left hij (le_of_relation_refl r _) + have hrpp := hrel.compat + high hhs (Nat.le_trans hli hih) (Nat.le_refl high) + high hhs (Nat.le_trans hli hih) (Nat.le_refl high) + (Completion.refl (r := (f · ·)) (as[high]'hhs)) + exact (hph ▸ ha).swap_left hij hrpp case hb => - let hb: IForAllIco (le_of_relation r pivot ·) i high as := hb.map (λ x a ↦ by - right - exact a) exact (hph ▸ hb).swap_right hij hhs - case hrtle => - exact transport_exact_icc hrtle (IPerm.swap _ _ _ hli hih _ _ hlj hjh) + case hrel => + exact transport_exact_icc hrel (IPerm.swap _ _ _ hli hih _ _ hlj hjh) case hpi => simp only [swap_def, get_eq_getElem, getElem_set, getElem_set_eq, ite_eq_right_iff, ↓reduceIte] @@ -1043,14 +1082,14 @@ mutual simp only [h] termination_by (high - low, 1, high - j) - theorem qsort.sort_loop_pivot_swap_sorts (r: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) + theorem qsort.sort_loop_pivot_swap_sorts (f: α → α → Bool) (low high : Nat) (hlh: low < high) (as: Array α) (mid: Nat) (hlm: low ≤ mid) (hmh: mid < high) (hhs : high < as.size) - (hrtle: ITransLeB r low high as): + (hrel: ITransCompatCB f r low high as): - let as' := if r (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as + let as' := if f (as[mid]'(Nat.lt_trans hmh hhs)) (as[high]'hhs) then as.swap ⟨mid, Nat.lt_trans hmh hhs⟩ ⟨high, hhs⟩ else as have hs': as'.size = as.size := by dsimp only [as']; split; all_goals simp_all only [Array.size_swap] - ISortOfLeB r low high as (qsort.sort.loop r low high hlh (as'[high]'(hs' ▸ hhs)) as' low low + ISortOf r low high as (qsort.sort.loop f low high hlh (as'[high]'(hs' ▸ hhs)) as' low low (Nat.le_refl low) (Nat.le_refl low) (Nat.le_trans hlm (Nat.le_of_lt hmh)) (hs' ▸ hhs)).1 := by have hms := Nat.lt_trans hmh hhs have hlh := Nat.le_trans hlm (Nat.le_of_lt hmh) @@ -1060,8 +1099,8 @@ mutual case hs => apply qsort.sort_loop_sorts case hph => rfl - case hrtle => - apply transport_enclosing hrtle ?_ (Nat.le_refl _) (Nat.le_refl _) + case hrel => + apply transport_enclosing hrel ?_ (Nat.le_refl _) (Nat.le_refl _) apply IPerm.ite · apply IPerm.swap all_goals @@ -1084,10 +1123,10 @@ mutual exact .refl termination_by (high - low, 2, 0) - theorem qsort.sort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) + theorem qsort.sort_sorts (as: Array α) (f: α → α → Bool) (r: α → α → Prop) (low := 0) (high := as.size - 1) (hhs: low < high → high < as.size) - (hrtle: ITransLeB r low high as): - ISortOfLeB r low high as (qsort.sort r as low high hhs) := by + (hrel: ITransCompatCB f r low high as): + ISortOf r low high as (qsort.sort f as low high hhs) := by unfold qsort.sort by_cases hlh: high ≤ low @@ -1106,8 +1145,8 @@ mutual case hlm => exact Nat.left_le_add_div_two.mpr hlh' case hmh => exact Nat.add_div_two_lt_right.mpr hlh - case hrtle => - apply transport_enclosing hrtle ?hp (Nat.le_refl _) (Nat.le_refl _) + case hrel => + apply transport_enclosing hrel ?hp (Nat.le_refl _) (Nat.le_refl _) case hp => repeat' @@ -1122,22 +1161,37 @@ mutual termination_by ((sizeOf high) - (sizeOf low), 3, 0) end -theorem qsort_sorts (as: Array α) (r: α → α → Bool) (low := 0) (high := as.size - 1) - (hrtle: ITransLeB r low high as): - ISortOfLeB r low high as (qsort as r low high) := by +theorem qsort_sorts_as (as: Array α) (f: α → α → Bool) (r: α → α → Prop) (low := 0) (high := as.size - 1) + (hrel: ITransCompatCB f r low high as): + ISortOf r low high as (qsort as f low high) := by unfold qsort split case isTrue => apply qsort.sort_sorts - · exact hrtle + · exact hrel case isFalse h => have hsh: as.size - 1 ≤ high := by apply Nat.sub_le_of_le_add exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) apply ISortOf.resize_out_of_bounds · apply qsort.sort_sorts - case hrtle => exact restrict hrtle (Nat.le_refl _) hsh + case hrel => exact restrict hrel (Nat.le_refl _) hsh · simp only [qsort.size_sort, Nat.le_refl] · exact hsh +/-- +We prove that qsort produces an array that: +- Is a permutation of the input (generated by the input by a finite sequence of swaps) +- Is ordered according to the transitive completion of the total completion of f + +The latter means that for any indices i0 < i1 in the range, there is a chain i0 ≤~ k_0 ≤~ ... ≤~ k_n ≤~ i1 +of indices in range, where i ≤~ j means that f(as[i], as[j]) = true or f(as[j], as[i]) = false. + +If f corresponds to a < or ≤ function on a totally ordered set, this simplifies to i < j → as[i] ≤ as[j]. +--/ +theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1): + ISortOf (ITransGen (Completion (f · ·)) low high as) low high as (qsort as f low high) := by + apply qsort_sorts_as + apply ITransCompat.mkITransGen + end Array From b07daae0ebff1b9ba71fa4afad62da477c9d4c58 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Tue, 17 Sep 2024 18:35:17 +0000 Subject: [PATCH 38/54] remove duplicated size_ite/size_dite --- src/Init/Data/Array/Basic.lean | 6 ++++-- src/Init/Data/Array/QSort.lean | 10 ---------- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/src/Init/Data/Array/Basic.lean b/src/Init/Data/Array/Basic.lean index 0b78d5f5962d..15fc18ab9399 100644 --- a/src/Init/Data/Array/Basic.lean +++ b/src/Init/Data/Array/Basic.lean @@ -685,11 +685,13 @@ def indexOf? [BEq α] (a : Array α) (v : α) : Option (Fin a.size) := | ⟨[]⟩ => rfl | ⟨a::as⟩ => simp [pop, Nat.succ_sub_succ_eq_sub, size] -@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): (if P then a else b).size = (if P then a.size else b.size) := by +@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): + (if P then a else b).size = (if P then a.size else b.size) := by split all_goals rfl -@[simp] theorem size_dite (P: Prop) [Decidable P] (a: P → Array α) (b: ¬P → Array α): (if h: P then a h else b h).size = (if h: P then (a h).size else (b h).size) := by +@[simp] theorem size_dite (P: Prop) [Decidable P] (a: P → Array α) (b: ¬P → Array α): + (if h: P then a h else b h).size = (if h: P then (a h).size else (b h).size) := by split all_goals rfl diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index dde262d82bb2..bf6e0a6e6916 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -9,16 +9,6 @@ import Init.Data.Array.Lemmas import Init.Data.Nat.Mod namespace Array -@[simp] theorem size_ite (P: Prop) [Decidable P] (a b: Array α): - (if P then a else b).size = (if P then a.size else b.size) := by - split - all_goals rfl - -@[simp] theorem size_dite (P: Prop) [Decidable P] (a: P → Array α) (b: ¬P → Array α): - (if h: P then a h else b h).size = (if h: P then (a h).size else (b h).size) := by - split - all_goals rfl - @[simp] theorem set_getElem_eq (as: Array α) (his: i < as.size) (his': i < as.size): as.set ⟨i, his⟩ (as[i]'his') = as := by apply Array.ext · simp only [size_set] From c8712cbcd1f8dbae3bd8961e5fc9ecf7351796ee Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 08:15:50 +0000 Subject: [PATCH 39/54] add theorems that qsort sorts for lawful < and <= --- src/Init/Data/Array/QSort.lean | 68 ++++++++++++++++++++++++++++++++-- 1 file changed, 65 insertions(+), 3 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index bf6e0a6e6916..e237b32d942c 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -1169,6 +1169,45 @@ theorem qsort_sorts_as (as: Array α) (f: α → α → Bool) (r: α → α → · simp only [qsort.size_sort, Nat.le_refl] · exact hsh +theorem iTransCompat_of_trans_total (f: α → α → Bool) + (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): + ITransCompatCB (f · ·) (f · · = true) low high as := by + constructor + case left => + intro i his _ _ j hjs _ _ h + cases h + case inl h => + exact h + case inr h => + apply Or.resolve_right + apply total + exact h + case right => + intro i his _ _ j hjs _ _ k hks _ _ hxy hyz + apply trans hxy hyz + +theorem iTransCompat_of_wlinear_asymm (f: α → α → Bool) + (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): + ITransCompatCB (f · ·) (λ x y ↦ f y x = false) low high as := by + constructor + case left => + intro i his _ _ j hjs _ _ h + cases h + case inl h => + apply eq_false_of_ne_true + apply asymm + exact h + case inr h => + apply eq_false_of_ne_true + exact h + case right => + intro i his _ _ j hjs _ _ k hks _ _ hxy hyz + apply eq_false_of_ne_true + intro hki + apply not_or_intro (ne_true_of_eq_false hyz) (ne_true_of_eq_false hxy) + apply wlinear + exact hki + /-- We prove that qsort produces an array that: - Is a permutation of the input (generated by the input by a finite sequence of swaps) @@ -1177,11 +1216,34 @@ We prove that qsort produces an array that: The latter means that for any indices i0 < i1 in the range, there is a chain i0 ≤~ k_0 ≤~ ... ≤~ k_n ≤~ i1 of indices in range, where i ≤~ j means that f(as[i], as[j]) = true or f(as[j], as[i]) = false. -If f corresponds to a < or ≤ function on a totally ordered set, this simplifies to i < j → as[i] ≤ as[j]. +If f corresponds to a ≤ or < function on a totally ordered type, this simplifies to i < j → as[i] ≤ as[j]. +See [qsort_sorts_of_is_le] or [qsort_sorts_of_is_lt] for this special case. --/ theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1): ISortOf (ITransGen (Completion (f · ·)) low high as) low high as (qsort as f low high) := by - apply qsort_sorts_as - apply ITransCompat.mkITransGen + apply qsort_sorts_as + exact ITransCompat.mkITransGen + +/-- +If f is a lawful ≤, i.e. a total order, meaning a transitive total relation, qsort sorts according to f: +- The output is a permutation of the input +- If i < j, then f (qsort as f _ _)[i] ≤ f (qsort as f _ _)[j] +--/ +theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) + (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): + ISortOf (f · ·) low high as (qsort as f low high) := by + apply qsort_sorts_as + exact iTransCompat_of_trans_total f trans total + +/-- +If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetric relation, qsort sorts according to f: +- The output is a permutation of the input +- If i < j, then ¬ f (qsort as f _ _)[j] < f (qsort as f _ _)[i] +--/ +theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) + (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): + ISortOf (λ x y ↦ f y x = false) low high as (qsort as f low high) := by + apply qsort_sorts_as + exact iTransCompat_of_wlinear_asymm f wlinear asymm end Array From e2b39e41e1ed13ce3c956a0b8037115056779917 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 08:22:52 +0000 Subject: [PATCH 40/54] fix indentation --- src/Init/Data/Array/QSort.lean | 86 +++++++++++++++++----------------- 1 file changed, 43 insertions(+), 43 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index e237b32d942c..fdd74a445e8c 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -1117,57 +1117,57 @@ mutual (hhs: low < high → high < as.size) (hrel: ITransCompatCB f r low high as): ISortOf r low high as (qsort.sort f as low high hhs) := by - unfold qsort.sort + unfold qsort.sort - by_cases hlh: high ≤ low - case pos => - simp only [ge_iff_le, hlh, ↓reduceDIte] - exact ISortOf.trivial hlh - case neg => - simp only [hlh] - have hlh: low < high := Nat.gt_of_not_le hlh - have hlh': low ≤ high := Nat.le_of_lt hlh + by_cases hlh: high ≤ low + case pos => + simp only [ge_iff_le, hlh, ↓reduceDIte] + exact ISortOf.trivial hlh + case neg => + simp only [hlh] + have hlh: low < high := Nat.gt_of_not_le hlh + have hlh': low ≤ high := Nat.le_of_lt hlh - apply ISortOf.trans - case hs => - apply qsort.sort_loop_pivot_swap_sorts - - case hlm => exact Nat.left_le_add_div_two.mpr hlh' - case hmh => exact Nat.add_div_two_lt_right.mpr hlh - - case hrel => - apply transport_enclosing hrel ?hp (Nat.le_refl _) (Nat.le_refl _) - - case hp => - repeat' - first - | apply Nat.le_refl - | apply Nat.add_div_two_le_right_of_le - | apply Nat.left_le_add_div_two.mpr - | apply IPerm.refl - | apply IPerm.ite - | apply IPerm.trans_swap - | assumption + apply ISortOf.trans + case hs => + apply qsort.sort_loop_pivot_swap_sorts + + case hlm => exact Nat.left_le_add_div_two.mpr hlh' + case hmh => exact Nat.add_div_two_lt_right.mpr hlh + + case hrel => + apply transport_enclosing hrel ?hp (Nat.le_refl _) (Nat.le_refl _) + + case hp => + repeat' + first + | apply Nat.le_refl + | apply Nat.add_div_two_le_right_of_le + | apply Nat.left_le_add_div_two.mpr + | apply IPerm.refl + | apply IPerm.ite + | apply IPerm.trans_swap + | assumption termination_by ((sizeOf high) - (sizeOf low), 3, 0) end theorem qsort_sorts_as (as: Array α) (f: α → α → Bool) (r: α → α → Prop) (low := 0) (high := as.size - 1) (hrel: ITransCompatCB f r low high as): ISortOf r low high as (qsort as f low high) := by - unfold qsort - split - case isTrue => - apply qsort.sort_sorts - · exact hrel - case isFalse h => - have hsh: as.size - 1 ≤ high := by - apply Nat.sub_le_of_le_add - exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) - apply ISortOf.resize_out_of_bounds - · apply qsort.sort_sorts - case hrel => exact restrict hrel (Nat.le_refl _) hsh - · simp only [qsort.size_sort, Nat.le_refl] - · exact hsh + unfold qsort + split + case isTrue => + apply qsort.sort_sorts + · exact hrel + case isFalse h => + have hsh: as.size - 1 ≤ high := by + apply Nat.sub_le_of_le_add + exact Nat.le_add_right_of_le (Nat.le_of_not_lt h) + apply ISortOf.resize_out_of_bounds + · apply qsort.sort_sorts + case hrel => exact restrict hrel (Nat.le_refl _) hsh + · simp only [qsort.size_sort, Nat.le_refl] + · exact hsh theorem iTransCompat_of_trans_total (f: α → α → Bool) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): From 2f286e4c71b1798d5718274258bc286f2e8a24bf Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 08:28:23 +0000 Subject: [PATCH 41/54] improve doc comments --- src/Init/Data/Array/QSort.lean | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index fdd74a445e8c..b789451f33d3 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -1151,6 +1151,15 @@ mutual termination_by ((sizeOf high) - (sizeOf low), 3, 0) end +/-- +We prove that qsort produces an array that: +- Is a permutation of the input (generated by the input by a finite sequence of swaps) +- Is ordered according to r, where r is any relation that is transitive and such that f is compatible with r + +f is compatible with r means that f x y → r x y and ¬f y x → r x y + +See [qsort_sorts], [qsort_sorts_of_is_lt] and [qsort_sorts_of_is_le] for more specific versions. +--/ theorem qsort_sorts_as (as: Array α) (f: α → α → Bool) (r: α → α → Prop) (low := 0) (high := as.size - 1) (hrel: ITransCompatCB f r low high as): ISortOf r low high as (qsort as f low high) := by @@ -1217,7 +1226,7 @@ The latter means that for any indices i0 < i1 in the range, there is a chain i0 of indices in range, where i ≤~ j means that f(as[i], as[j]) = true or f(as[j], as[i]) = false. If f corresponds to a ≤ or < function on a totally ordered type, this simplifies to i < j → as[i] ≤ as[j]. -See [qsort_sorts_of_is_le] or [qsort_sorts_of_is_lt] for this special case. +See [qsort_sorts_of_is_le] or [qsort_sorts_of_is_lt] for these special cases. --/ theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1): ISortOf (ITransGen (Completion (f · ·)) low high as) low high as (qsort as f low high) := by @@ -1228,6 +1237,8 @@ theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := a If f is a lawful ≤, i.e. a total order, meaning a transitive total relation, qsort sorts according to f: - The output is a permutation of the input - If i < j, then f (qsort as f _ _)[i] ≤ f (qsort as f _ _)[j] + +See [qsort_sorts] for the result for arbitrary f --/ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): @@ -1239,6 +1250,8 @@ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low := 0) ( If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetric relation, qsort sorts according to f: - The output is a permutation of the input - If i < j, then ¬ f (qsort as f _ _)[j] < f (qsort as f _ _)[i] + +See [qsort_sorts] for the result for arbitrary f --/ theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): From 0cf4cd284877d0ee1dc4dfe2359e1d149b9f2790 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 08:29:58 +0000 Subject: [PATCH 42/54] fix doc comments --- src/Init/Data/Array/QSort.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index b789451f33d3..765f2d2e95ee 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -1236,7 +1236,7 @@ theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := a /-- If f is a lawful ≤, i.e. a total order, meaning a transitive total relation, qsort sorts according to f: - The output is a permutation of the input -- If i < j, then f (qsort as f _ _)[i] ≤ f (qsort as f _ _)[j] +- If i < j, then f out[i] out[j] See [qsort_sorts] for the result for arbitrary f --/ @@ -1249,7 +1249,7 @@ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low := 0) ( /-- If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetric relation, qsort sorts according to f: - The output is a permutation of the input -- If i < j, then ¬ f (qsort as f _ _)[j] < f (qsort as f _ _)[i] +- If i < j, then ¬ f out[j] < f out[i] See [qsort_sorts] for the result for arbitrary f --/ From 06e8e5d41b455e03ead95e918f135165d2a8ad80 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 09:00:30 +0000 Subject: [PATCH 43/54] split into multiple files --- src/Init/Data/Array/IntervalPreds.lean | 758 +++++++++++++++++++++++ src/Init/Data/Array/Lemmas.lean | 23 + src/Init/Data/Array/QSort.lean | 802 +------------------------ src/Init/Data/Nat/Lemmas.lean | 32 + 4 files changed, 816 insertions(+), 799 deletions(-) create mode 100644 src/Init/Data/Array/IntervalPreds.lean diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean new file mode 100644 index 000000000000..08b8e6645620 --- /dev/null +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -0,0 +1,758 @@ +prelude +import Init.Data.Array.Basic +import Init.Data.Array.Lemmas + +/-! +## Predicates about intervals of arrays + +This file contains objects that represent predicates holding over an interval of an array. +It is used to prove the correctness of array manipulation algorithms, and in particular sort algorithms. +-/ + +namespace Array.IntervalPreds + +inductive IPerm (low high: Nat): Array α → Array α → Prop where +| refl: IPerm low high as as +| swap (as: Array α) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as (as.swap ⟨i, his⟩ ⟨j, hjs⟩) +| trans {as as' as'': Array α}: IPerm low high as as' → IPerm low high as' as'' → IPerm low high as as'' + +namespace IPerm +theorem ite (p: Prop) [Decidable p] (low high: Nat) (as0 ast asf: Array α) + (hpt: IPerm low high as0 ast) (hpf: IPerm low high as0 asf): + IPerm low high as0 (if p then ast else asf) := by + split + case isTrue => exact hpt + case isFalse => exact hpf + +theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → Array α) (asf: ¬p → Array α) + (hpt: (h: p) → IPerm low high as0 (ast h)) (hpf: (h: ¬p) → IPerm low high as0 (asf h)): + IPerm low high as0 (if h: p then ast h else asf h) := by + split + case isTrue h => exact hpt h + case isFalse h => exact hpf h + +theorem trans_swap (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): + IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by + apply IPerm.trans hp + exact IPerm.swap as i his hli hih j hjs hlj hjh + +theorem expand + {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} + (hp: IPerm low high as as'): IPerm low' high' as as' := by + induction hp with + | refl => exact refl + | trans _ _ ih ih' => exact trans ih ih' + | swap as i his hli hih j hjs hlj hjh => + exact swap as + i his (Nat.le_trans hll hli) (Nat.le_trans hih hhh) + j hjs (Nat.le_trans hll hlj) (Nat.le_trans hjh hhh) + +theorem expand_up (hhh: high ≤ high') + (hp: IPerm low high as as'): IPerm low high' as as' := + hp.expand (Nat.le_refl _) hhh + +theorem expand_down (hll: low' ≤ low) + (hp: IPerm low high as as'): IPerm low' high as as' := + hp.expand hll (Nat.le_refl _) + +theorem size_eq + (hp: IPerm low high as as' ): as.size = as'.size := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap => simp only [size_swap] + +theorem eq_of_singleton (hp: IPerm k k as as' ): as = as' := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rw [ih, ih'] + | swap as i his hli hih j hjs hlj hjh => + have hik: i = k := Nat.le_antisymm hih hli + have hjk: j = k := Nat.le_antisymm hjh hlj + subst i j + rw [swap_def] + apply Array.ext + · simp only [size_set] + · intro k _ _ + repeat rw [getElem_set] + split + all_goals + try subst k + simp only [get_eq_getElem] + +theorem eq_of_trivial (hp: IPerm low high as as' ) (h: high ≤ low): as = as' := by + by_cases h': high = low + · subst high + apply eq_of_singleton hp + · induction hp with + | refl => rfl + | trans _ _ ih ih' => rw [ih, ih'] + | swap as i his hli hih j hjs _ _ => + exfalso + have h: high < low := Nat.lt_of_le_of_ne h h' + exact Nat.not_lt.mpr (Nat.le_trans hli hih) h + +theorem resize_out_of_bounds (hp: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): + IPerm low high' as0 as := by + induction hp with + | refl => exact refl + | trans p' _ ih ih' => exact trans (ih hsh') (ih' (p'.size_eq ▸ hsh')) + | swap as i his hli _ j hjs hlj _ => + have hih': i ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt his) hsh' + have hjh': j ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh' + exact swap as + i his hli hih' + j hjs hlj hjh' + +def getElem?_lower (hp: IPerm low high as as') (hkl: k < low): as[k]? = as'[k]? := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap _ _ _ hli _ _ _ hlj _ => + simp [swap_def] + rw [getElem?_set_ne] + rw [getElem?_set_ne] + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) + · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) + +def getElem?_higher (hp: IPerm low high as as') (hhk: high < k): as[k]? = as'[k]? := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap _ _ _ _ hih _ _ _ hjh => + simp [swap_def] + rw [getElem?_set_ne] + rw [getElem?_set_ne] + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) + +def getElem_lower (hp: IPerm low high as as') (hkl: k < low) + {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by + apply Option.some_inj.mp + simp only [← getElem?_lt] + apply hp.getElem?_lower hkl + +def getElem_higher (hp: IPerm low high as as') (hhk: high < k) + {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by + apply Option.some_inj.mp + simp only [← getElem?_lt] + apply hp.getElem?_higher hhk + +end IPerm + +def IForAllIco (P: α → Prop) (low high: Nat) (as: Array α) := + ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) + +def IForAllIcc (P: α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + P (as[i]'his) + +def IForAllIcc2 (P: α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + P (as[i]'his) (as[j]'hjs) + +def IForAllIcc3 (P: α → α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → + P (as[i]'his) (as[j]'hjs) (as[k]'hks) + +/- +def IForAllIcc2I (P: Nat → Nat → α → α → Prop) (low high: Nat) (as: Array α) := + (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → + (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → + P i j (as[i]'his) (as[j]'hjs) + +-- equivalent IForAllIcc2I (λ i j x y ↦ i < j → r x y) low high as +-/ + +def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := + ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → + r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) + +abbrev IForAllIcoSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat) (P: α → Prop) := + IForAllIco P low high (as.swap ⟨i, his⟩ ⟨j, hjs⟩) + +namespace IForAllIco +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: (a: α) → P a → Q a): + IForAllIco Q low high as := by + intro k hks hlk hkh + specialize ha k hks hlk hkh + exact f (as[k]'hks) ha + +theorem swap_left + (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) + (ha: IForAllIco P low i as): + IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by + intro k hks hlk hki1 + rw [size_swap] at hks + simp only [swap_def] + by_cases hki: k < i + · rw [getElem_set_ne, getElem_set_ne] + exact ha k hks hlk hki + · exact Ne.symm (Nat.ne_of_lt hki) + · have hkj: k < j := Nat.lt_of_lt_of_le hki hij + exact Ne.symm (Nat.ne_of_lt hkj) + · have hki: k = i := Nat.eq_of_lt_succ_of_not_lt hki1 hki + subst k + by_cases hij: i = j + · subst i + simp only [getElem_set_eq] + exact hjp + rw [getElem_set_ne, getElem_set_eq] + exact hjp + · rfl + · intro h + exact hij (Eq.symm h) + +theorem swap_right + (hij: i ≤ j) (hjs: j < as.size) + (hb: IForAllIco P i j as): + IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by + intro k hks hi1x hkj1 + rw [size_swap] at hks + simp only [swap_def] + by_cases hkj: k < j + · rw [getElem_set_ne, getElem_set_ne] + have hik: i ≤ k := Nat.le_of_succ_le hi1x + exact hb k hks hik hkj + · exact Nat.ne_of_lt hi1x + · exact Ne.symm (Nat.ne_of_lt hkj) + · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj + subst k + simp only [getElem_set_eq] + exact hb i (Nat.lt_trans hi1x hjs) (Nat.le_refl i) hi1x + +theorem of_swap + (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} + (h: IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs + low high P): IForAllIco P low high as := by + have his := Nat.lt_of_le_of_lt hij hjs + intro k hks hlk hkh + simp [IForAllIcoSwap, IForAllIco, size_swap, swap_def] at h + by_cases hki: k = i + · subst k + have hlj: low ≤ j := Nat.le_trans hli hij + specialize h j hjs hlj hjh + rwa [getElem_set_eq] at h + · rfl + by_cases hkj: k = j + · subst k + have hih: i < high := Nat.lt_of_le_of_lt hij hjh + specialize h i his hli hih + rw [getElem_set_ne] at h + rwa [getElem_set_eq] at h + · rfl + · exact hki + specialize h k hks hlk hkh + rw [getElem_set_ne] at h + rwa [getElem_set_ne] at h + · exact Ne.symm hki + · exact Ne.symm hkj +end IForAllIco + +abbrev ITrans (r: α → α → Prop) := + IForAllIcc3 (λ x y z ↦ r x y → r y z → r x z) + +abbrev ICompat (hr: α → α → Prop) (r: α → α → Prop) := + IForAllIcc2 (λ x y ↦ hr x y → r x y) + +abbrev ITransCompat (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := + (ICompat hr r low high as) ∧ (ITrans r low high as) + + /-- + Turns a relation into one that behaves like le + If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] + If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] + -/ +abbrev Completion (r: α → α → Prop) := λ x y ↦ r x y ∨ ¬r y x + +namespace Completion + +def pos (h: r x y): Completion r x y := by + left + exact h + +def neg (h: ¬r y x): Completion r x y := by + right + exact h + +def wtotal (h: ¬Completion r x y): Completion r y x := by + right + intro h' + exact h (Or.inl h') + +def refl [DecidableRel r] (x): Completion r x x := by + by_cases h: r x x + · exact pos h + · exact neg h + +def stotal [DecidableRel r]: Completion r x y ∨ Completion r y x := by + by_cases h: Completion r x y + · left + exact h + · right + exact wtotal h + +end Completion + +abbrev ITransCompatC (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := + ITransCompat (Completion hr) r low high as + +abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := + ITransCompatC (f · ·) r low high as + +inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop +| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) + (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) +| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c + +namespace ITransCompat + +def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 +def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 + +def mkITransGen: ITransCompatCB f (ITransGen (Completion (f · ·)) low high as) low high as := by + constructor + · apply ITransGen.base + · intro i his _ _ j hjs _ _ k hks _ _ + apply ITransGen.trans + +end ITransCompat + +namespace ITransCompatCB + +export ITransCompat (compat trans) + +end ITransCompatCB + +local macro "elementwise" + t:term : tactic => +`(tactic| { + intros + constructor + all_goals + apply $t + all_goals assumption +}) + +local macro "elementwise" + t:term "using" h:ident : tactic => +`(tactic| { + intros + constructor + · apply $t + try any_goals assumption + exact $h.1 + · apply $t + try any_goals assumption + exact $h.2 +}) + +class Trivial (α) (T: Nat → Nat → Array α → Prop) (ub': Nat → Nat → Prop) where + trivial (hll: ub' high low): T low high as + +export Trivial (trivial) + +instance [Trivial α T1 ub'] [Trivial α T2 ub']: + Trivial α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub' where + trivial hhl := by elementwise trivial hhl + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k k as) where + default := trivial (Nat.le_refl _) + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k (k - 1) as) where + default := trivial (Nat.sub_le k 1) + +instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T (k + 1) k as) where + default := trivial (Nat.le_add_right k 1) + +instance {k: Nat} {as: Array α} [Trivial α T LT.lt]: Inhabited (T (k + 1) k as) where + default := trivial (Nat.lt_add_one k) + +class Restrictable (α) (T: Nat → Nat → Array α → Prop) where + restrict (ha: T low high as) + (hll: low ≤ low') (hhh: high' ≤ high) + : T low' high' as + +export Restrictable (restrict) + +instance [Restrictable α T1] [Restrictable α T2]: + Restrictable α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) where + restrict h := by elementwise restrict using h + +class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where + restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) + (hsh: ub (as.size - 1) high): T low high' as + +export RestrictableOutOfBounds (restrict_out_of_bounds) + +instance [RestrictableOutOfBounds α T1 ub] [RestrictableOutOfBounds α T2 ub]: + RestrictableOutOfBounds α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + restrict_out_of_bounds h := by elementwise restrict_out_of_bounds using h + +class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where + transport_outside + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): + T low high as' + +export TransportableOutside (transport_outside) + +instance [TransportableOutside α T1 ub] [TransportableOutside α T2 ub]: + TransportableOutside α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + transport_outside h := by elementwise transport_outside using h + +class LteOp (r: Nat → Nat → Prop) where + co: Nat → Nat → Prop + of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z + not: ¬(co a b) ↔ (r b a) + succ: Nat → Nat + r_succ: ∀ x, r x (succ x) + +instance: LteOp (LE.le) where + co := LT.lt + of_le_of xy yz := Nat.le_trans xy yz + not := Nat.not_lt + succ x := x + r_succ x := Nat.le_refl x + +instance: LteOp (LT.lt) where + co := LE.le + of_le_of xy yz := Nat.lt_of_le_of_lt xy yz + not := Nat.not_le + succ x := (x + 1) + r_succ x := Nat.lt_add_one x + +theorem transport_lower {α} {T: Nat → Nat → Array α → Prop} + [TransportableOutside α T r] [LteOp r] + {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: LteOp.co r high plow): + T low high as' := by + apply transport_outside h hp (ub := r) + intro k _ hkh hplk _ + exact LteOp.not.mpr (LteOp.of_le_of hplk hkh) hd + +theorem transport_higher {α} {T: Nat → Nat → Array α → Prop} + [TransportableOutside α T r] [LteOp r] + {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} + (h : T low high as) + (hp : IPerm plow phigh as as') + (hd: phigh < low): + T low high as' := by + apply transport_outside h hp (ub := r) + intro k hlk _ _ hkph + exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd + +class TransportableEnclosing (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) + extends TransportableOutside α T ub where + transport_enclosing + (h : T low high as) + (hp : IPerm plow phigh as as') + (hll: low ≤ plow) + (hhh: ub phigh high) : + T low high as' + +export TransportableEnclosing (transport_enclosing) + +instance [TransportableEnclosing α T1 ub] [TransportableEnclosing α T2 ub]: + TransportableEnclosing α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where + transport_enclosing h := by elementwise transport_enclosing using h + +theorem transport_exact_icc {α} {T: Nat → Nat → Array α → Prop} + [TransportableEnclosing α T LE.le] + {low high: Nat} {as: Array α} {as': Array α} + (h : T low high as) + (hp : IPerm low high as as'): + T low high as' := by + apply transport_enclosing h hp + · exact Nat.le_refl _ + · exact Nat.le_refl high + +theorem transport_exact_ico {α} {T: Nat → Nat → Array α → Prop} + [TransportableEnclosing α T LT.lt] + {low high: Nat} {as: Array α} {as': Array α} + (h : T low (high + 1) as) + (hp : IPerm low high as as'): + T low (high + 1) as' := by + apply transport_enclosing h hp + · exact Nat.le_refl _ + · exact Nat.lt_add_one high + +set_option hygiene false in +scoped macro "impl_trivial" + α:ident + "(" T:term ")" + "(" ub'':term ")" + intros:num : command => +`( + instance: Trivial $α ($T) $ub'' where + trivial hhl := by + iterate $intros intro _ + exfalso + suffices hlh: $ub'' _ _ by + first + | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hlh hhl) + | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hhl hlh) + | done + + try rw [Nat.lt_succ] + first + | exact Nat.lt_of_le_of_lt (by assumption) (by assumption) + | exact Nat.le_trans (by assumption) (by assumption) + | exact Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption)) + | exact Nat.lt_of_le_of_lt (by assumption) (Nat.lt_of_lt_of_le (by assumption) (by assumption)) + | exact Nat.le_trans (by assumption) (Nat.le_trans (Nat.le_of_lt (by assumption)) (by assumption)) + | done +) + +scoped macro "impl_transport_outside" + α:ident + "(" T:term ")" + "(" ub:term ")" + "(" ub':term ")" + intros:num : command => +`( + impl_trivial $α ($T) ($ub') $intros + + instance: Restrictable $α ($T) where + restrict h hll hhh := by + iterate $intros intro _ + apply h + all_goals + try first + | apply Nat.le_trans hll _ + | apply Nat.le_trans _ hhh + assumption + + instance: RestrictableOutOfBounds $α ($T) $ub where + restrict_out_of_bounds h hsh := by + iterate $intros intro _ + apply h + repeat' + first + | assumption + | apply Nat.le_trans _ hsh + | apply Nat.succ_le_succ + | apply Nat.le_sub_one_of_lt + | done + + instance: TransportableOutside $α ($T) $ub where + transport_outside h hp hd := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as i his hli hih j hjs hlj hjh => + iterate $intros intro _ + simp only [swap_def] + repeat rw [getElem_set_ne] + · apply h + all_goals assumption + all_goals + intro he + subst_eqs + first + | apply hd i + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | done + | apply hd j + all_goals + first + | assumption + | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) + | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) + | done +) + +scoped macro "impl_transport" + α:ident + "(" T:term ")" + "(" ub:term ")" + "(" ub':term ")" + intros:num : command => +`( + impl_transport_outside $α ($T) ($ub) ($ub') $intros + + instance: TransportableEnclosing $α ($T) $ub where + transport_enclosing h hp hll hhh := by + induction hp with + | refl => exact h + | trans _ _ ih ih' => exact ih' (ih h) + | swap as a has hpla haph b hbs hplb hbph => + have hla := Nat.le_trans hll hpla + have hlb := Nat.le_trans hll hplb + have hah := LteOp.of_le_of haph hhh + have hbh := LteOp.of_le_of hbph hhh + iterate $intros intro _ + simp [swap_def] + repeat rw [getElem_set] + repeat' split + all_goals + apply h + all_goals assumption +) + +namespace IPairwise +variable {α} {P: α → α → Prop} + +impl_trivial α (IPairwise P) (LE.le) 6 +impl_transport_outside α (IPairwise P) (LE.le) (LT.lt) 6 +end IPairwise + +namespace IForAllIco +variable {α} {P: α → Prop} + +impl_transport α (IForAllIco P) (LT.lt) (LE.le) 4 +end IForAllIco + +namespace IForAllIcc +variable {α} {P: α → Prop} + +impl_transport α (IForAllIcc P) (LE.le) (LT.lt) 4 +end IForAllIcc + +namespace IForAllIcc2 +variable {α} {P: α → α → Prop} + +impl_transport α (IForAllIcc2 P) (LE.le) (LT.lt) 8 +end IForAllIcc2 + +namespace IForAllIcc3 +variable {α} {P: α → α → α → Prop} + +impl_transport α (IForAllIcc3 P) (LE.le) (LT.lt) 12 +end IForAllIcc3 + +/- +namespace IForAllIcc2I +variable {α} {P: Nat → Nat → α → α → Prop} + +impl_transport_outside α (IForAllIcc2I P) (LE.le) 8 +end IForAllIcc2I +-/ + +namespace IPairwise + +theorem glue_with_pivot + {r: α → α → Prop} + {p: Nat} (hps: p < as.size) (hlp: low ≤ p) (hph: p ≤ high) (hp: pivot = as[p]'hps) + (ha : IForAllIco (r · pivot) low (i + 1) as) + (hb : IForAllIco (r pivot ·) (i + 1) (high + 1) as) + (hrel : ITrans r low high as) + (h1 : IPairwise r low i as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + unfold IPairwise + intro a b hla hab hbh hbs + have has := Nat.lt_trans hab hbs + have hlb := Nat.le_trans hla (Nat.le_of_lt hab) + have hah: a ≤ high := Nat.le_trans (Nat.le_of_lt hab) hbh + + by_cases hbi: b ≤ i + · exact h1 a b hla hab hbi hbs + + have hib: i < b := Nat.succ_le_of_lt (Nat.gt_of_not_le hbi) + by_cases hia: i + 1 ≤ a + · exact h2 a b hia hab hbh hbs + + have hai: a < i + 1 := by exact Nat.gt_of_not_le hia + + exact hrel a has hla hah p hps hlp hph b hbs hlb hbh + (hp ▸ (ha a has hla hai)) + (hp ▸ (hb b hbs hib (Nat.lt_add_one_of_le hbh))) + +theorem glue_with_middle + (i : Nat) + (his: i < as.size) {r: α → α → Prop} + (ha : IForAllIco (r · (as[i]'his)) low i as) + (hb : IForAllIco (r (as[i]'his) ·) (i + 1) (high + 1) as) + (hrel : ITrans r low high as) + (h1 : IPairwise r low (i - 1) as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + unfold IPairwise + intro a b hla hab hbh hbs + have has := Nat.lt_trans hab hbs + + by_cases hbi: b < i + · exact h1 a b hla hab (Nat.le_sub_one_of_lt hbi) hbs + + have hib: i ≤ b := Nat.le_of_not_lt hbi + by_cases hia: i < a + · exact h2 a b hia hab hbh hbs + + have hai: a ≤ i := by exact Nat.le_of_not_lt hia + + have ha: a < i → r (as[a]'has) (as[i]'his) := λ hai' ↦ ha a has hla hai' + have hb: i < b → r (as[i]'his) (as[b]'hbs) := λ hib' ↦ hb b hbs hib' (Nat.lt_add_one_of_le hbh) + + have hah := Nat.le_trans (Nat.le_of_lt hab) hbh + have hli := Nat.le_trans hla hai + have hih := Nat.le_trans hib hbh + have hlb := Nat.le_trans hla (Nat.le_of_lt hab) + + by_cases hai': a < i + · by_cases hib': i < b + · exact hrel a has hla hah i his hli hih b hbs hlb hbh (ha hai') (hb hib') + · have hib: i = b := by exact Nat.le_antisymm hib (Nat.le_of_not_lt hib') + subst b + exact (ha hai') + · have hai: a = i := by exact Nat.le_antisymm hai (Nat.le_of_not_lt hai') + subst a + exact (hb hab) + +theorem glue_with_middle_eq_pivot + {r : α → α → Prop} {low high : Nat} {as : Array α} + (i : Nat) (pivot: α) + (his: i < as.size) + (hpi: as[i]'his = pivot) + (ha : IForAllIco (r · pivot) low i as) + (hb : IForAllIco (r pivot ·) (i + 1) (high + 1) as) + (hrel : ITrans r low high as) + (h1 : IPairwise r low (i - 1) as) + (h2 : IPairwise r (i + 1) high as): + IPairwise r low high as := by + subst pivot + apply glue_with_middle i + all_goals assumption + +end IPairwise + +structure ISortOf (r: α → α → Prop) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where + perm: IPerm low high orig sorted + ord: IPairwise r low high sorted + +namespace ISortOf +instance [Trivial α (IPairwise r) ub']: + Trivial α (λ low high as ↦ ISortOf r low high as as) ub' where + trivial hhl := by + constructor + case perm => exact IPerm.refl + case ord => exact trivial hhl + +def trivial {high low: Nat} (hhl: high ≤ low): ISortOf r low high as as := + instTrivialOfIPairwise.trivial hhl + +theorem trans + (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): + (ISortOf r low high as as'') := by + constructor + case perm => exact hp.trans hs.perm + case ord => exact hs.ord + +theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) ≤ high) (hsh': (as0.size - 1) ≤ high'): + ISortOf r low high' as0 as := by + constructor + case perm => exact h.perm.resize_out_of_bounds hsh' + case ord => exact restrict_out_of_bounds h.ord hsh +end ISortOf + +end Array.IntervalPreds diff --git a/src/Init/Data/Array/Lemmas.lean b/src/Init/Data/Array/Lemmas.lean index 89b3716d3d35..735a601683ce 100644 --- a/src/Init/Data/Array/Lemmas.lean +++ b/src/Init/Data/Array/Lemmas.lean @@ -1113,5 +1113,28 @@ theorem swap_comm (a : Array α) {i j : Fin a.size} : a.swap i j = a.swap j i := · split <;> simp_all · split <;> simp_all +@[simp] theorem set_getElem_eq (as: Array α) (his: i < as.size) (his': i < as.size): as.set ⟨i, his⟩ (as[i]'his') = as := by + apply Array.ext + · simp only [size_set] + · intro k _ _ + rw [getElem_set] + split + all_goals + try subst k + simp only + +abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as.size) (hks: k < as.size): α := + (as.swap ⟨i, his⟩ ⟨j, hjs⟩)[k]'( + le_of_le_of_eq hks (Eq.symm (size_swap as ⟨i, his⟩ ⟨j, hjs⟩)) + ) + +theorem getElem_after_swap (as: Array α) (hij: i ≤ j) (hjh: j < high) (hhs: high < as.size): + swap_getElem as i j high (Nat.lt_of_le_of_lt hij (Nat.lt_trans hjh hhs)) (Nat.lt_trans hjh hhs) hhs + = (as[high]'hhs) := by + simp [swap_getElem, swap_def] + rw [getElem_set_ne] + rw [getElem_set_ne] + · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hij hjh) + · exact Nat.ne_of_lt (hjh) end Array diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index 765f2d2e95ee..eb8da909aefe 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -6,52 +6,10 @@ Authors: Leonardo de Moura prelude import Init.Data.Array.Basic import Init.Data.Array.Lemmas +import Init.Data.Array.IntervalPreds +import Init.Data.Nat.Lemmas import Init.Data.Nat.Mod -namespace Array -@[simp] theorem set_getElem_eq (as: Array α) (his: i < as.size) (his': i < as.size): as.set ⟨i, his⟩ (as[i]'his') = as := by - apply Array.ext - · simp only [size_set] - · intro k _ _ - rw [getElem_set] - split - all_goals - try subst k - simp only -end Array - -namespace Nat -@[simp] theorem left_lt_add_div_two: n < (n + m) / 2 ↔ n + 1 < m := by - rw [← succ_le, - Nat.le_div_iff_mul_le Nat.zero_lt_two, - Nat.mul_two, succ_add, succ_le, - Nat.add_lt_add_iff_left] - -@[simp] theorem left_le_add_div_two: n ≤ (n + m) / 2 ↔ n ≤ m := by - rw [ - Nat.le_div_iff_mul_le Nat.zero_lt_two, - Nat.mul_two, - Nat.add_le_add_iff_left] - -@[simp] theorem add_div_two_lt_right: (n + m) / 2 < m ↔ n < m:= by - rw [ - Nat.div_lt_iff_lt_mul Nat.zero_lt_two, - Nat.mul_two, - Nat.add_lt_add_iff_right] - -@[simp] theorem add_div_two_le_right: (n + m) / 2 ≤ m ↔ n ≤ m + 1:= by - rw [← lt_succ, - Nat.div_lt_iff_lt_mul Nat.zero_lt_two, - Nat.mul_two, add_succ, lt_succ, - Nat.add_le_add_iff_right] - -theorem lt_of_left_lt_add_div_two (h: n < (n + m) / 2): n < m := - lt_of_succ_lt (left_lt_add_div_two.mp h) - -theorem add_div_two_le_right_of_le (h: n ≤ m): (n + m) / 2 ≤ m := - add_div_two_le_right.mpr (le_add_right_of_le h) -end Nat - namespace Array @[inline] def qsort (as : Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) : Array α := @@ -157,761 +115,7 @@ namespace Array split all_goals exact (qsort.sort _ _ _ _ _).2 -inductive IPerm (low high: Nat): Array α → Array α → Prop where -| refl: IPerm low high as as -| swap (as: Array α) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as (as.swap ⟨i, his⟩ ⟨j, hjs⟩) -| trans {as as' as'': Array α}: IPerm low high as as' → IPerm low high as' as'' → IPerm low high as as'' - -namespace IPerm -theorem ite (p: Prop) [Decidable p] (low high: Nat) (as0 ast asf: Array α) - (hpt: IPerm low high as0 ast) (hpf: IPerm low high as0 asf): - IPerm low high as0 (if p then ast else asf) := by - split - case isTrue => exact hpt - case isFalse => exact hpf - -theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → Array α) (asf: ¬p → Array α) - (hpt: (h: p) → IPerm low high as0 (ast h)) (hpf: (h: ¬p) → IPerm low high as0 (asf h)): - IPerm low high as0 (if h: p then ast h else asf h) := by - split - case isTrue h => exact hpt h - case isFalse h => exact hpf h - -theorem trans_swap (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): - IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by - apply IPerm.trans hp - exact IPerm.swap as i his hli hih j hjs hlj hjh - -theorem expand - {low' high': Nat} (hll: low' ≤ low) (hhh: high ≤ high') {as: Array α} {as': Array α} - (hp: IPerm low high as as'): IPerm low' high' as as' := by - induction hp with - | refl => exact refl - | trans _ _ ih ih' => exact trans ih ih' - | swap as i his hli hih j hjs hlj hjh => - exact swap as - i his (Nat.le_trans hll hli) (Nat.le_trans hih hhh) - j hjs (Nat.le_trans hll hlj) (Nat.le_trans hjh hhh) - -theorem expand_up (hhh: high ≤ high') - (hp: IPerm low high as as'): IPerm low high' as as' := - hp.expand (Nat.le_refl _) hhh - -theorem expand_down (hll: low' ≤ low) - (hp: IPerm low high as as'): IPerm low' high as as' := - hp.expand hll (Nat.le_refl _) - -theorem size_eq - (hp: IPerm low high as as' ): as.size = as'.size := by - induction hp with - | refl => rfl - | trans _ _ ih ih' => rwa [ih'] at ih - | swap => simp only [size_swap] - -theorem eq_of_singleton (hp: IPerm k k as as' ): as = as' := by - induction hp with - | refl => rfl - | trans _ _ ih ih' => rw [ih, ih'] - | swap as i his hli hih j hjs hlj hjh => - have hik: i = k := Nat.le_antisymm hih hli - have hjk: j = k := Nat.le_antisymm hjh hlj - subst i j - rw [swap_def] - apply Array.ext - · simp only [size_set] - · intro k _ _ - repeat rw [getElem_set] - split - all_goals - try subst k - simp only [get_eq_getElem] - -theorem eq_of_trivial (hp: IPerm low high as as' ) (h: high ≤ low): as = as' := by - by_cases h': high = low - · subst high - apply eq_of_singleton hp - · induction hp with - | refl => rfl - | trans _ _ ih ih' => rw [ih, ih'] - | swap as i his hli hih j hjs _ _ => - exfalso - have h: high < low := Nat.lt_of_le_of_ne h h' - exact Nat.not_lt.mpr (Nat.le_trans hli hih) h - -theorem resize_out_of_bounds (hp: IPerm low high as0 as) (hsh': (as0.size - 1) ≤ high'): - IPerm low high' as0 as := by - induction hp with - | refl => exact refl - | trans p' _ ih ih' => exact trans (ih hsh') (ih' (p'.size_eq ▸ hsh')) - | swap as i his hli _ j hjs hlj _ => - have hih': i ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt his) hsh' - have hjh': j ≤ high' := Nat.le_trans (Nat.le_sub_one_of_lt hjs) hsh' - exact swap as - i his hli hih' - j hjs hlj hjh' - -def getElem?_lower (hp: IPerm low high as as') (hkl: k < low): as[k]? = as'[k]? := by - induction hp with - | refl => rfl - | trans _ _ ih ih' => rwa [ih'] at ih - | swap _ _ _ hli _ _ _ hlj _ => - simp [swap_def] - rw [getElem?_set_ne] - rw [getElem?_set_ne] - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hli)) - · exact Ne.symm (Nat.ne_of_lt (Nat.lt_of_lt_of_le hkl hlj)) - -def getElem?_higher (hp: IPerm low high as as') (hhk: high < k): as[k]? = as'[k]? := by - induction hp with - | refl => rfl - | trans _ _ ih ih' => rwa [ih'] at ih - | swap _ _ _ _ hih _ _ _ hjh => - simp [swap_def] - rw [getElem?_set_ne] - rw [getElem?_set_ne] - · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hih hhk) - · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hjh hhk) - -def getElem_lower (hp: IPerm low high as as') (hkl: k < low) - {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by - apply Option.some_inj.mp - simp only [← getElem?_lt] - apply hp.getElem?_lower hkl - -def getElem_higher (hp: IPerm low high as as') (hhk: high < k) - {hks: k < as.size} {hks': k < as'.size}: as[k]'hks = as'[k]'hks' := by - apply Option.some_inj.mp - simp only [← getElem?_lt] - apply hp.getElem?_higher hhk - -end IPerm - -def IForAllIco (P: α → Prop) (low high: Nat) (as: Array α) := - ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) - -def IForAllIcc (P: α → Prop) (low high: Nat) (as: Array α) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - P (as[i]'his) - -def IForAllIcc2 (P: α → α → Prop) (low high: Nat) (as: Array α) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → - P (as[i]'his) (as[j]'hjs) - -def IForAllIcc3 (P: α → α → α → Prop) (low high: Nat) (as: Array α) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → - (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → - P (as[i]'his) (as[j]'hjs) (as[k]'hks) - -/- -def IForAllIcc2I (P: Nat → Nat → α → α → Prop) (low high: Nat) (as: Array α) := - (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → - (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → - P i j (as[i]'his) (as[j]'hjs) - --- equivalent IForAllIcc2I (λ i j x y ↦ i < j → r x y) low high as --/ - -def IPairwise (r: α → α → Prop) (low high: Nat) (as: Array α) := - ∀ i j, (hli: low ≤ i) → (hij: i < j) → (hjh: j ≤ high) → (hjs: j < as.size) → - r (as[i]'(Nat.lt_trans hij hjs)) (as[j]'hjs) - -abbrev IForAllIcoSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) (low high: Nat) (P: α → Prop) := - IForAllIco P low high (as.swap ⟨i, his⟩ ⟨j, hjs⟩) - -namespace IForAllIco -theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: (a: α) → P a → Q a): - IForAllIco Q low high as := by - intro k hks hlk hkh - specialize ha k hks hlk hkh - exact f as[k] ha - -theorem swap_left - (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) - (ha: IForAllIco P low i as): - IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs low (i + 1) P := by - intro k hks hlk hki1 - rw [size_swap] at hks - simp only [swap_def] - by_cases hki: k < i - · rw [getElem_set_ne, getElem_set_ne] - exact ha k hks hlk hki - · exact Ne.symm (Nat.ne_of_lt hki) - · have hkj: k < j := Nat.lt_of_lt_of_le hki hij - exact Ne.symm (Nat.ne_of_lt hkj) - · have hki: k = i := Nat.eq_of_lt_succ_of_not_lt hki1 hki - subst k - by_cases hij: i = j - · subst i - simp only [getElem_set_eq] - exact hjp - rw [getElem_set_ne, getElem_set_eq] - exact hjp - · rfl - · intro h - exact hij (Eq.symm h) - -theorem swap_right - (hij: i ≤ j) (hjs: j < as.size) - (hb: IForAllIco P i j as): - IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs (i + 1) (j + 1) P := by - intro k hks hi1x hkj1 - rw [size_swap] at hks - simp only [swap_def] - by_cases hkj: k < j - · rw [getElem_set_ne, getElem_set_ne] - have hik: i ≤ k := Nat.le_of_succ_le hi1x - exact hb k hks hik hkj - · exact Nat.ne_of_lt hi1x - · exact Ne.symm (Nat.ne_of_lt hkj) - · have hkj: k = j := Nat.eq_of_lt_succ_of_not_lt hkj1 hkj - subst k - simp only [getElem_set_eq] - exact hb i (Nat.lt_trans hi1x hjs) (Nat.le_refl i) hi1x - -theorem of_swap - (hli: low ≤ i) (hij: i ≤ j) (hjh: j < high) {hjs: j < as.size} - (h: IForAllIcoSwap as i j (Nat.lt_of_le_of_lt hij hjs) hjs - low high P): IForAllIco P low high as := by - have his := Nat.lt_of_le_of_lt hij hjs - intro k hks hlk hkh - simp [IForAllIcoSwap, IForAllIco, size_swap, swap_def] at h - by_cases hki: k = i - · subst k - have hlj: low ≤ j := Nat.le_trans hli hij - specialize h j hjs hlj hjh - rwa [getElem_set_eq] at h - · rfl - by_cases hkj: k = j - · subst k - have hih: i < high := Nat.lt_of_le_of_lt hij hjh - specialize h i his hli hih - rw [getElem_set_ne] at h - rwa [getElem_set_eq] at h - · rfl - · exact hki - specialize h k hks hlk hkh - rw [getElem_set_ne] at h - rwa [getElem_set_ne] at h - · exact Ne.symm hki - · exact Ne.symm hkj -end IForAllIco - -abbrev ITrans (r: α → α → Prop) := - IForAllIcc3 (λ x y z ↦ r x y → r y z → r x z) - - /-- - Turns a relation into one that behaves like le - If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] - If r is <=, then this means a[i] ≤ a[j] or a[j] !≤ a[i] => a[i] ≤ a[j] - -/ -abbrev Completion (r: α → α → Prop) := λ x y ↦ r x y ∨ ¬r y x - -namespace Completion - -def pos (h: r x y): Completion r x y := by - left - exact h - -def neg (h: ¬r y x): Completion r x y := by - right - exact h - -def wtotal (h: ¬Completion r x y): Completion r y x := by - right - intro h' - exact h (Or.inl h') - -def refl [DecidableRel r] (x): Completion r x x := by - by_cases h: r x x - · exact pos h - · exact neg h - -def stotal [DecidableRel r]: Completion r x y ∨ Completion r y x := by - by_cases h: Completion r x y - · left - exact h - · right - exact wtotal h - -end Completion - -abbrev ICompat (hr: α → α → Prop) (r: α → α → Prop) := - IForAllIcc2 (λ x y ↦ hr x y → r x y) - -abbrev ITransCompat (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := - (ICompat hr r low high as) ∧ (ITrans r low high as) - -abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := - ITransCompat (Completion (f · ·)) r low high as - -inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop -| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) - (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) -| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c - -namespace ITransCompat - -def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 -def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 - -def mkITransGen: ITransCompatCB f (ITransGen (Completion (f · ·)) low high as) low high as := by - constructor - · apply ITransGen.base - · intro i his _ _ j hjs _ _ k hks _ _ - apply ITransGen.trans - -end ITransCompat - -namespace ITransCompatCB - -export ITransCompat (compat trans) - -end ITransCompatCB - -local macro "elementwise" - t:term : tactic => -`(tactic| { - intros - constructor - all_goals - apply $t - all_goals assumption -}) - -local macro "elementwise" - t:term "using" h:ident : tactic => -`(tactic| { - intros - constructor - · apply $t - try any_goals assumption - exact $h.1 - · apply $t - try any_goals assumption - exact $h.2 -}) - -class Trivial (α) (T: Nat → Nat → Array α → Prop) (ub': Nat → Nat → Prop) where - trivial (hll: ub' high low): T low high as - -export Trivial (trivial) - -instance [Trivial α T1 ub'] [Trivial α T2 ub']: - Trivial α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub' where - trivial hhl := by elementwise trivial hhl - -instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k k as) where - default := trivial (Nat.le_refl _) - -instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T k (k - 1) as) where - default := trivial (Nat.sub_le k 1) - -instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T (k + 1) k as) where - default := trivial (Nat.le_add_right k 1) - -instance {k: Nat} {as: Array α} [Trivial α T LT.lt]: Inhabited (T (k + 1) k as) where - default := trivial (Nat.lt_add_one k) - -class Restrictable (α) (T: Nat → Nat → Array α → Prop) where - restrict (ha: T low high as) - (hll: low ≤ low') (hhh: high' ≤ high) - : T low' high' as - -export Restrictable (restrict) - -instance [Restrictable α T1] [Restrictable α T2]: - Restrictable α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) where - restrict h := by elementwise restrict using h - -class RestrictableOutOfBounds (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where - restrict_out_of_bounds {low high: Nat} {as: Array α} {high': Nat} (ha: T low high as) - (hsh: ub (as.size - 1) high): T low high' as - -export RestrictableOutOfBounds (restrict_out_of_bounds) - -instance [RestrictableOutOfBounds α T1 ub] [RestrictableOutOfBounds α T2 ub]: - RestrictableOutOfBounds α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - restrict_out_of_bounds h := by elementwise restrict_out_of_bounds using h - -class TransportableOutside (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) where - transport_outside - (h : T low high as) - (hp : IPerm plow phigh as as') - (hd: (k: Nat) → (hlk: low ≤ k) → (hkh: ub k high) → (hplk: plow ≤ k) → (hkph: k ≤ phigh) → False): - T low high as' - -export TransportableOutside (transport_outside) - -instance [TransportableOutside α T1 ub] [TransportableOutside α T2 ub]: - TransportableOutside α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - transport_outside h := by elementwise transport_outside using h - -class LteOp (r: Nat → Nat → Prop) where - co: Nat → Nat → Prop - of_le_of: ∀ {x y z: Nat}, (x ≤ y) → (r y z) → r x z - not: ¬(co a b) ↔ (r b a) - succ: Nat → Nat - r_succ: ∀ x, r x (succ x) - -instance: LteOp (LE.le) where - co := LT.lt - of_le_of xy yz := Nat.le_trans xy yz - not := Nat.not_lt - succ x := x - r_succ x := Nat.le_refl x - -instance: LteOp (LT.lt) where - co := LE.le - of_le_of xy yz := Nat.lt_of_le_of_lt xy yz - not := Nat.not_le - succ x := (x + 1) - r_succ x := Nat.lt_add_one x - -theorem transport_lower {α} {T: Nat → Nat → Array α → Prop} - [TransportableOutside α T r] [LteOp r] - {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} - (h : T low high as) - (hp : IPerm plow phigh as as') - (hd: LteOp.co r high plow): - T low high as' := by - apply transport_outside h hp (ub := r) - intro k _ hkh hplk _ - exact LteOp.not.mpr (LteOp.of_le_of hplk hkh) hd - -theorem transport_higher {α} {T: Nat → Nat → Array α → Prop} - [TransportableOutside α T r] [LteOp r] - {low high: Nat} {as: Array α}{plow phigh: Nat} {as': Array α} - (h : T low high as) - (hp : IPerm plow phigh as as') - (hd: phigh < low): - T low high as' := by - apply transport_outside h hp (ub := r) - intro k hlk _ _ hkph - exact Nat.not_lt.mpr (Nat.le_trans hlk hkph) hd - -class TransportableEnclosing (α) (T: Nat → Nat → Array α → Prop) (ub: outParam (Nat → Nat → Prop)) - extends TransportableOutside α T ub where - transport_enclosing - (h : T low high as) - (hp : IPerm plow phigh as as') - (hll: low ≤ plow) - (hhh: ub phigh high) : - T low high as' - -export TransportableEnclosing (transport_enclosing) - -instance [TransportableEnclosing α T1 ub] [TransportableEnclosing α T2 ub]: - TransportableEnclosing α (λ low high as ↦ (T1 low high as) ∧ (T2 low high as)) ub where - transport_enclosing h := by elementwise transport_enclosing using h - -theorem transport_exact_icc {α} {T: Nat → Nat → Array α → Prop} - [TransportableEnclosing α T LE.le] - {low high: Nat} {as: Array α} {as': Array α} - (h : T low high as) - (hp : IPerm low high as as'): - T low high as' := by - apply transport_enclosing h hp - · exact Nat.le_refl _ - · exact Nat.le_refl high - -theorem transport_exact_ico {α} {T: Nat → Nat → Array α → Prop} - [TransportableEnclosing α T LT.lt] - {low high: Nat} {as: Array α} {as': Array α} - (h : T low (high + 1) as) - (hp : IPerm low high as as'): - T low (high + 1) as' := by - apply transport_enclosing h hp - · exact Nat.le_refl _ - · exact Nat.lt_add_one high - -set_option hygiene false in -scoped macro "impl_trivial" - α:ident - "(" T:term ")" - "(" ub'':term ")" - intros:num : command => -`( - instance: Trivial $α ($T) $ub'' where - trivial hhl := by - iterate $intros intro _ - exfalso - suffices hlh: $ub'' _ _ by - first - | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hlh hhl) - | exact Nat.lt_irrefl _ (Nat.lt_of_le_of_lt hhl hlh) - | done - - try rw [Nat.lt_succ] - first - | exact Nat.lt_of_le_of_lt (by assumption) (by assumption) - | exact Nat.le_trans (by assumption) (by assumption) - | exact Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption)) - | exact Nat.lt_of_le_of_lt (by assumption) (Nat.lt_of_lt_of_le (by assumption) (by assumption)) - | exact Nat.le_trans (by assumption) (Nat.le_trans (Nat.le_of_lt (by assumption)) (by assumption)) - | done -) - -scoped macro "impl_transport_outside" - α:ident - "(" T:term ")" - "(" ub:term ")" - "(" ub':term ")" - intros:num : command => -`( - impl_trivial $α ($T) ($ub') $intros - - instance: Restrictable $α ($T) where - restrict h hll hhh := by - iterate $intros intro _ - apply h - all_goals - try first - | apply Nat.le_trans hll _ - | apply Nat.le_trans _ hhh - assumption - - instance: RestrictableOutOfBounds $α ($T) $ub where - restrict_out_of_bounds h hsh := by - iterate $intros intro _ - apply h - repeat' - first - | assumption - | apply Nat.le_trans _ hsh - | apply Nat.succ_le_succ - | apply Nat.le_sub_one_of_lt - | done - - instance: TransportableOutside $α ($T) $ub where - transport_outside h hp hd := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as i his hli hih j hjs hlj hjh => - iterate $intros intro _ - simp only [swap_def] - repeat rw [getElem_set_ne] - · apply h - all_goals assumption - all_goals - intro he - subst_eqs - first - | apply hd i - all_goals - first - | assumption - | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) - | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) - | done - | apply hd j - all_goals - first - | assumption - | exact (Nat.le_trans (by assumption) (Nat.le_of_lt (by assumption))) - | exact (Nat.le_of_lt (Nat.lt_of_lt_of_le (by assumption) (by assumption))) - | done -) - -scoped macro "impl_transport" - α:ident - "(" T:term ")" - "(" ub:term ")" - "(" ub':term ")" - intros:num : command => -`( - impl_transport_outside $α ($T) ($ub) ($ub') $intros - - instance: TransportableEnclosing $α ($T) $ub where - transport_enclosing h hp hll hhh := by - induction hp with - | refl => exact h - | trans _ _ ih ih' => exact ih' (ih h) - | swap as a has hpla haph b hbs hplb hbph => - have hla := Nat.le_trans hll hpla - have hlb := Nat.le_trans hll hplb - have hah := LteOp.of_le_of haph hhh - have hbh := LteOp.of_le_of hbph hhh - iterate $intros intro _ - simp [swap_def] - repeat rw [getElem_set] - repeat' split - all_goals - apply h - all_goals assumption -) - -namespace IPairwise -variable {α} {P: α → α → Prop} - -impl_trivial α (IPairwise P) (LE.le) 6 -impl_transport_outside α (IPairwise P) (LE.le) (LT.lt) 6 -end IPairwise - -namespace IForAllIco -variable {α} {P: α → Prop} - -impl_transport α (IForAllIco P) (LT.lt) (LE.le) 4 -end IForAllIco - -namespace IForAllIcc -variable {α} {P: α → Prop} - -impl_transport α (IForAllIcc P) (LE.le) (LT.lt) 4 -end IForAllIcc - -namespace IForAllIcc2 -variable {α} {P: α → α → Prop} - -impl_transport α (IForAllIcc2 P) (LE.le) (LT.lt) 8 -end IForAllIcc2 - -namespace IForAllIcc3 -variable {α} {P: α → α → α → Prop} - -impl_transport α (IForAllIcc3 P) (LE.le) (LT.lt) 12 -end IForAllIcc3 - -/- -namespace IForAllIcc2I -variable {α} {P: Nat → Nat → α → α → Prop} - -impl_transport_outside α (IForAllIcc2I P) (LE.le) 8 -end IForAllIcc2I --/ - -namespace IPairwise - -theorem glue_with_pivot - {r: α → α → Prop} - {p: Nat} (hps: p < as.size) (hlp: low ≤ p) (hph: p ≤ high) (hp: pivot = as[p]'hps) - (ha : IForAllIco (r · pivot) low (i + 1) as) - (hb : IForAllIco (r pivot ·) (i + 1) (high + 1) as) - (hrel : ITrans r low high as) - (h1 : IPairwise r low i as) - (h2 : IPairwise r (i + 1) high as): - IPairwise r low high as := by - unfold IPairwise - intro a b hla hab hbh hbs - have has := Nat.lt_trans hab hbs - have hlb := Nat.le_trans hla (Nat.le_of_lt hab) - have hah: a ≤ high := Nat.le_trans (Nat.le_of_lt hab) hbh - - by_cases hbi: b ≤ i - · exact h1 a b hla hab hbi hbs - - have hib: i < b := Nat.succ_le_of_lt (Nat.gt_of_not_le hbi) - by_cases hia: i + 1 ≤ a - · exact h2 a b hia hab hbh hbs - - have hai: a < i + 1 := by exact Nat.gt_of_not_le hia - - exact hrel a has hla hah p hps hlp hph b hbs hlb hbh - (hp ▸ (ha a has hla hai)) - (hp ▸ (hb b hbs hib (Nat.lt_add_one_of_le hbh))) - -theorem glue_with_middle - (i : Nat) - (his: i < as.size) {r: α → α → Prop} - (ha : IForAllIco (r · (as[i]'his)) low i as) - (hb : IForAllIco (r (as[i]'his) ·) (i + 1) (high + 1) as) - (hrel : ITrans r low high as) - (h1 : IPairwise r low (i - 1) as) - (h2 : IPairwise r (i + 1) high as): - IPairwise r low high as := by - unfold IPairwise - intro a b hla hab hbh hbs - have has := Nat.lt_trans hab hbs - - by_cases hbi: b < i - · exact h1 a b hla hab (Nat.le_sub_one_of_lt hbi) hbs - - have hib: i ≤ b := Nat.le_of_not_lt hbi - by_cases hia: i < a - · exact h2 a b hia hab hbh hbs - - have hai: a ≤ i := by exact Nat.le_of_not_lt hia - - have ha: a < i → r (as[a]'has) (as[i]'his) := λ hai' ↦ ha a has hla hai' - have hb: i < b → r (as[i]'his) (as[b]'hbs) := λ hib' ↦ hb b hbs hib' (Nat.lt_add_one_of_le hbh) - - have hah := Nat.le_trans (Nat.le_of_lt hab) hbh - have hli := Nat.le_trans hla hai - have hih := Nat.le_trans hib hbh - have hlb := Nat.le_trans hla (Nat.le_of_lt hab) - - by_cases hai': a < i - · by_cases hib': i < b - · exact hrel a has hla hah i his hli hih b hbs hlb hbh (ha hai') (hb hib') - · have hib: i = b := by exact Nat.le_antisymm hib (Nat.le_of_not_lt hib') - subst b - exact (ha hai') - · have hai: a = i := by exact Nat.le_antisymm hai (Nat.le_of_not_lt hai') - subst a - exact (hb hab) - -theorem glue_with_middle_eq_pivot - {r : α → α → Prop} {low high : Nat} {as : Array α} - (i : Nat) (pivot: α) - (his: i < as.size) - (hpi: as[i]'his = pivot) - (ha : as.IForAllIco (r · pivot) low i) - (hb : as.IForAllIco (r pivot ·) (i + 1) (high + 1)) - (hrel : ITrans r low high as) - (h1 : IPairwise r low (i - 1) as) - (h2 : IPairwise r (i + 1) high as): - IPairwise r low high as := by - subst pivot - apply glue_with_middle i - all_goals assumption - -end IPairwise - -abbrev swap_getElem (as: Array α) (i j k: Nat) (his: i < as.size) (hjs: j < as.size) (hks: k < as.size): α := - (as.swap ⟨i, his⟩ ⟨j, hjs⟩)[k]'( - le_of_le_of_eq hks (Eq.symm (size_swap as ⟨i, his⟩ ⟨j, hjs⟩)) - ) - -theorem getElem_after_swap (as: Array α) (hij: i ≤ j) (hjh: j < high) (hhs: high < as.size): - as.swap_getElem i j high (Nat.lt_of_le_of_lt hij (Nat.lt_trans hjh hhs)) (Nat.lt_trans hjh hhs) hhs - = (as[high]'hhs) := by - simp [swap_getElem, swap_def] - rw [getElem_set_ne] - rw [getElem_set_ne] - · exact Nat.ne_of_lt (Nat.lt_of_le_of_lt hij hjh) - · exact Nat.ne_of_lt (hjh) - -structure ISortOf (r: α → α → Prop) (low high: Nat) (orig: Array α) (sorted: Array α): Prop where - perm: IPerm low high orig sorted - ord: IPairwise r low high sorted - -namespace ISortOf -instance [Trivial α (IPairwise r) ub']: - Trivial α (λ low high as ↦ ISortOf r low high as as) ub' where - trivial hhl := by - constructor - case perm => exact IPerm.refl - case ord => exact trivial hhl - -def trivial {high low: Nat} (hhl: high ≤ low): ISortOf r low high as as := - instTrivialOfIPairwise.trivial hhl - -theorem trans - (hp: IPerm low high as as') (hs: ISortOf r low high as' as''): - (ISortOf r low high as as'') := by - constructor - case perm => exact hp.trans hs.perm - case ord => exact hs.ord - -theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) ≤ high) (hsh': (as0.size - 1) ≤ high'): - ISortOf r low high' as0 as := by - constructor - case perm => exact h.perm.resize_out_of_bounds hsh' - case ord => exact restrict_out_of_bounds h.ord hsh -end ISortOf - +open Array.IntervalPreds mutual theorem qsort.sort_sort_sorts (f: α → α → Bool) (r: α → α → Prop) (low high : Nat) (pivot : α) (i : Nat) (as: Array α) diff --git a/src/Init/Data/Nat/Lemmas.lean b/src/Init/Data/Nat/Lemmas.lean index 2d4908e48e0e..1c64b4efaed2 100644 --- a/src/Init/Data/Nat/Lemmas.lean +++ b/src/Init/Data/Nat/Lemmas.lean @@ -922,3 +922,35 @@ instance decidableExistsLT [h : DecidablePred p] : DecidablePred fun n => ∃ m instance decidableExistsLE [DecidablePred p] : DecidablePred fun n => ∃ m : Nat, m ≤ n ∧ p m := fun n => decidable_of_iff (∃ m, m < n + 1 ∧ p m) (exists_congr fun _ => and_congr_left' Nat.lt_succ_iff) + +/-! ### (n + m) / 2 -/ + +@[simp] theorem left_lt_add_div_two: n < (n + m) / 2 ↔ n + 1 < m := by + rw [← succ_le, + Nat.le_div_iff_mul_le Nat.zero_lt_two, + Nat.mul_two, succ_add, succ_le, + Nat.add_lt_add_iff_left] + +@[simp] theorem left_le_add_div_two: n ≤ (n + m) / 2 ↔ n ≤ m := by + rw [ + Nat.le_div_iff_mul_le Nat.zero_lt_two, + Nat.mul_two, + Nat.add_le_add_iff_left] + +@[simp] theorem add_div_two_lt_right: (n + m) / 2 < m ↔ n < m:= by + rw [ + Nat.div_lt_iff_lt_mul Nat.zero_lt_two, + Nat.mul_two, + Nat.add_lt_add_iff_right] + +@[simp] theorem add_div_two_le_right: (n + m) / 2 ≤ m ↔ n ≤ m + 1:= by + rw [← lt_succ, + Nat.div_lt_iff_lt_mul Nat.zero_lt_two, + Nat.mul_two, add_succ, lt_succ, + Nat.add_le_add_iff_right] + +theorem lt_of_left_lt_add_div_two (h: n < (n + m) / 2): n < m := + lt_of_succ_lt (left_lt_add_div_two.mp h) + +theorem add_div_two_le_right_of_le (h: n ≤ m): (n + m) / 2 ≤ m := + add_div_two_le_right.mpr (le_add_right_of_le h) From 945db5e5d2354cf56b34d128c743fba523ef2063 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 09:12:08 +0000 Subject: [PATCH 44/54] clean up interval preds --- src/Init/Data/Array/IntervalPreds.lean | 45 ++++++++++++-------------- 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index 08b8e6645620..64119d422dea 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -261,6 +261,27 @@ abbrev ICompat (hr: α → α → Prop) (r: α → α → Prop) := abbrev ITransCompat (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := (ICompat hr r low high as) ∧ (ITrans r low high as) +inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop +| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) + (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) +| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c + +namespace ITransCompat + +def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 +def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 + +def mkITransGen: ITransCompat r (ITransGen r low high as) low high as := by + constructor + · unfold ICompat + unfold IForAllIcc2 + simp + apply ITransGen.base + · intro i his _ _ j hjs _ _ k hks _ _ + apply ITransGen.trans + +end ITransCompat + /-- Turns a relation into one that behaves like le If r is <, then this means a[i] < a[j] or a[j] !< a[i] => a[i] ≤ a[j] @@ -303,30 +324,6 @@ abbrev ITransCompatC (hr: α → α → Prop) (r: α → α → Prop) (low high: abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := ITransCompatC (f · ·) r low high as -inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop -| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) - (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) -| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c - -namespace ITransCompat - -def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 -def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 - -def mkITransGen: ITransCompatCB f (ITransGen (Completion (f · ·)) low high as) low high as := by - constructor - · apply ITransGen.base - · intro i his _ _ j hjs _ _ k hks _ _ - apply ITransGen.trans - -end ITransCompat - -namespace ITransCompatCB - -export ITransCompat (compat trans) - -end ITransCompatCB - local macro "elementwise" t:term : tactic => `(tactic| { From bc17d4ca47cbdb62134b102dada65cc80c79bd94 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 09:59:15 +0000 Subject: [PATCH 45/54] Add doc comment for qsort --- src/Init/Data/Array/QSort.lean | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index eb8da909aefe..e9b910e6807d 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -12,6 +12,13 @@ import Init.Data.Nat.Mod namespace Array +/-- +Sorts the array using QuickSort according to function f. + +The function can be a ≤, a <, or in fact an arbitrary function (with weaker guarantees). + +See [qsort_sorts_of_is_le], [qsort_sorts_of_is_lt], [qsort_sorts], [qsort_sorts_as] for proofs. +--/ @[inline] def qsort (as : Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) : Array α := let rec @[specialize] sort (as : Array α) (low high : Nat) (hhs: low < high → high < as.size): {as': Array α // as'.size = as.size} := From eeec6f1480ec2754716d6a3d5bd1aacd260476aa Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 10:24:20 +0000 Subject: [PATCH 46/54] weaken hypotheses on Completion --- src/Init/Data/Array/IntervalPreds.lean | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index 64119d422dea..e0d3be50d4c4 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -304,17 +304,22 @@ def wtotal (h: ¬Completion r x y): Completion r y x := by intro h' exact h (Or.inl h') -def refl [DecidableRel r] (x): Completion r x x := by - by_cases h: r x x - · exact pos h - · exact neg h +def refl (x) [i: Decidable (r x x)]: Completion r x x := by + exact Decidable.em (r x x) -def stotal [DecidableRel r]: Completion r x y ∨ Completion r y x := by - by_cases h: Completion r x y +def stotal [Decidable (r x y)]: Completion r x y ∨ Completion r y x := by + by_cases h: r x y · left - exact h + exact pos h · right - exact wtotal h + exact neg h + +def stotal' [Decidable (r y x)]: Completion r x y ∨ Completion r y x := by + by_cases h: r y x + · right + exact pos h + · left + exact neg h end Completion From d4257e15a10f1c13ed8ec82577197d798cd95f72 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 14:36:16 +0000 Subject: [PATCH 47/54] add proof that ISortOf of TransGen is equal to ISortOf of f in < and <= special cases This guarantees that our TransGen definition is not degenerate --- lean.code-workspace | 5 - src/Init/Data/Array/IntervalPreds.lean | 169 ++++++++++++++++++++++++- src/Init/Data/Array/QSort.lean | 55 ++------ 3 files changed, 173 insertions(+), 56 deletions(-) diff --git a/lean.code-workspace b/lean.code-workspace index 4aae65961a92..6a81f8bf2ac8 100644 --- a/lean.code-workspace +++ b/lean.code-workspace @@ -17,11 +17,6 @@ "cmake.generator": "Unix Makefiles", "[markdown]": { "rewrap.wrappingColumn": 70 - }, - "[lean4]": { - "editor.rulers": [ - 100 - ] } }, "tasks": { diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index e0d3be50d4c4..8491dfaa0ac6 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -252,21 +252,46 @@ theorem of_swap · exact Ne.symm hkj end IForAllIco +inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop +| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) + (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) +| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c + +namespace ITransGen +def exists_left_idx (hr: ITransGen r low high as x y): + ∃ (i: Nat) (his: i < as.size) (_: low ≤ i) (_: i ≤ high), x = as[i]'his := by + induction hr + case base i his hli hih _ _ _ _ _ => + exists i, his, hli, hih + case trans _ _ ih _ => + exact ih + +def exists_right_idx (hr: ITransGen r low high as x y): + ∃ (j: Nat) (hjs: j < as.size) (_: low ≤ j) (_: j ≤ high), y = as[j]'hjs:= by + induction hr + case base _ _ _ _ j hjs hlj hjh _ => + exists j, hjs, hlj, hjh + case trans _ _ _ ih => + exact ih +end ITransGen + abbrev ITrans (r: α → α → Prop) := IForAllIcc3 (λ x y z ↦ r x y → r y z → r x z) abbrev ICompat (hr: α → α → Prop) (r: α → α → Prop) := IForAllIcc2 (λ x y ↦ hr x y → r x y) +namespace ICompat +def refl: ICompat r r low high as := by + repeat intro h + exact h +end ICompat + abbrev ITransCompat (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := (ICompat hr r low high as) ∧ (ITrans r low high as) -inductive ITransGen {α} (r : α → α → Prop) (low high: Nat) (as: Array α) : α → α → Prop -| base (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high) - (h: r (as[i]'his) (as[j]'hjs)): ITransGen r low high as (as[i]'his) (as[j]'hjs) -| trans {a b c} : ITransGen r low high as a b → ITransGen r low high as b c → ITransGen r low high as a c - namespace ITransCompat +def of_trans (h: ITrans r low high as): ITransCompat r r low high as := ⟨ICompat.refl, h⟩ def compat (h: ITransCompat hr r low high as): ICompat hr r low high as := h.1 def trans (h: ITransCompat hr r low high as): ITrans r low high as := h.2 @@ -323,12 +348,100 @@ def stotal' [Decidable (r y x)]: Completion r x y ∨ Completion r y x := by end Completion +abbrev ITransGenC {α} (r : α → α → Prop) (low high: Nat) (as: Array α) := + ITransGen (Completion r) low high as + +abbrev ITransGenCB {α} (f : α → α → Bool) (low high: Nat) (as: Array α) := + ITransGenC (f · ·) low high as + abbrev ITransCompatC (hr: α → α → Prop) (r: α → α → Prop) (low high: Nat) (as: Array α) := ITransCompat (Completion hr) r low high as abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := ITransCompatC (f · ·) r low high as +theorem iTransCompatCB_of_trans_total (f: α → α → Bool) + (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): + ITransCompatCB (f · ·) (f · ·) low high as := by + constructor + case left => + intro i his _ _ j hjs _ _ h + cases h + case inl h => + exact h + case inr h => + apply Or.resolve_right + apply total + exact h + case right => + intro i his _ _ j hjs _ _ k hks _ _ hxy hyz + apply trans hxy hyz + +theorem iTransCompatCB_of_wlinear_asymm (f: α → α → Bool) + (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): + ITransCompatCB (f · ·) (λ x y ↦ ¬f y x) low high as := by + constructor + case left => + intro i his _ _ j hjs _ _ h + cases h + case inl h => + apply asymm + exact h + case inr h => + exact h + case right => + intro i his _ _ j hjs _ _ k hks _ _ hxy hyz + intro hki + apply not_or_intro hyz hxy + apply wlinear + exact hki + +def of_iTransCompat_iTransGen (h: ITransCompat hr r low high as) (htg: ITransGen hr low high as x y): + r x y := by + induction htg + case base i his hli hih j hjs hlj hjh c => + exact h.compat i his hli hih j hjs hlj hjh c + case trans a b c ab bc hab hbc => + obtain ⟨i, his, hli, hih, ha⟩ := ITransGen.exists_left_idx ab + obtain ⟨j, hjs, hlj, hjh, hb⟩ := ITransGen.exists_left_idx bc + obtain ⟨k, hks, hlk, hkh, hc⟩ := ITransGen.exists_right_idx bc + subst a b c + apply h.trans i his hli hih j hjs hlj hjh k hks hlk hkh hab hbc + +def eq_iTransGen_of_iTransCompat_iCompat (h: ITransCompat hr r low high as) (hc: ICompat r hr low high as): + IForAllIcc2 (λ x y ↦ ITransGen hr low high as x y = r x y) low high as := by + intro i his hli hih j hjs hlj hjh + ext + constructor + · intro h' + apply of_iTransCompat_iTransGen ?_ h' + exact h + · intro h' + apply ITransGen.base i his hli hih j hjs hlj hjh + exact hc i his hli hih j hjs hlj hjh h' + +def compat_completion: ICompat r (Completion r) low high as := by + repeat intro h + left + exact h + +def not_compat_completion: ICompat (λ x y ↦ ¬r y x) (Completion r) low high as := by + repeat intro h + right + exact h + +def eq_iTransGenC_of_iTransCompatC_iCompat (h: ITransCompatC r r low high as): + IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y = r x y) low high as := by + apply eq_iTransGen_of_iTransCompat_iCompat + · exact h + · exact compat_completion + +def iTransGenC_eq_not_symm_of_iTransCompatC_iCompat (h: ITransCompatC r (λ x y ↦ ¬r y x) low high as): + IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y = ¬r y x) low high as := by + apply eq_iTransGen_of_iTransCompat_iCompat + · exact h + · exact not_compat_completion + local macro "elementwise" t:term : tactic => `(tactic| { @@ -642,6 +755,20 @@ end IForAllIcc2I -/ namespace IPairwise +def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y = r' x y) low high as): + IPairwise r low high as = IPairwise r' low high as := by + unfold IForAllIcc2 at h + unfold IPairwise + ext + apply forall₂_congr + intro i j + apply forall₄_congr + intro hli hij hjh hjs + have hih: i ≤ high := Nat.le_trans (Nat.le_of_lt hij) hjh + have his: i < as.size := Nat.lt_trans hij hjs + have hlj: low ≤ j := Nat.le_trans hli (Nat.le_of_lt hij) + apply eq_iff_iff.mp + exact h i his hli hih j hjs hlj hjh theorem glue_with_pivot {r: α → α → Prop} @@ -755,6 +882,38 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) constructor case perm => exact h.perm.resize_out_of_bounds hsh' case ord => exact restrict_out_of_bounds h.ord hsh + +theorem congr_rel (h: IPerm low high orig sorted → IPairwise r low high sorted = IPairwise r' low high sorted): + ISortOf r low high orig sorted = ISortOf r' low high orig sorted := by + ext + constructor + all_goals + intro a + constructor + · exact a.perm + · exact (h a.perm) ▸ a.ord + +theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y = r' x y) low high orig): + ISortOf r low high orig sorted = ISortOf r' low high orig sorted := by + apply ISortOf.congr_rel + intro hp + apply IPairwise.congr_rel + apply transport_exact_icc h hp + +theorem eq_of_trans_total {f: α → α → Bool} + (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): + ISortOf (ITransGenCB f low high as) low high as as' = ISortOf (f · · ) low high as as' := by + apply ISortOf.congr_rel' + apply eq_iTransGenC_of_iTransCompatC_iCompat + exact iTransCompatCB_of_trans_total f trans total + +theorem eq_of_wlinear_asymm + (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): + ISortOf (ITransGenCB f low high as) low high as as' = ISortOf (λ x y ↦ ¬f y x) low high as as' := by + apply ISortOf.congr_rel' + apply iTransGenC_eq_not_symm_of_iTransCompatC_iCompat + exact iTransCompatCB_of_wlinear_asymm f wlinear asymm + end ISortOf end Array.IntervalPreds diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index e9b910e6807d..d1d34cb113a3 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -389,45 +389,6 @@ theorem qsort_sorts_as (as: Array α) (f: α → α → Bool) (r: α → α → · simp only [qsort.size_sort, Nat.le_refl] · exact hsh -theorem iTransCompat_of_trans_total (f: α → α → Bool) - (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): - ITransCompatCB (f · ·) (f · · = true) low high as := by - constructor - case left => - intro i his _ _ j hjs _ _ h - cases h - case inl h => - exact h - case inr h => - apply Or.resolve_right - apply total - exact h - case right => - intro i his _ _ j hjs _ _ k hks _ _ hxy hyz - apply trans hxy hyz - -theorem iTransCompat_of_wlinear_asymm (f: α → α → Bool) - (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): - ITransCompatCB (f · ·) (λ x y ↦ f y x = false) low high as := by - constructor - case left => - intro i his _ _ j hjs _ _ h - cases h - case inl h => - apply eq_false_of_ne_true - apply asymm - exact h - case inr h => - apply eq_false_of_ne_true - exact h - case right => - intro i his _ _ j hjs _ _ k hks _ _ hxy hyz - apply eq_false_of_ne_true - intro hki - apply not_or_intro (ne_true_of_eq_false hyz) (ne_true_of_eq_false hxy) - apply wlinear - exact hki - /-- We prove that qsort produces an array that: - Is a permutation of the input (generated by the input by a finite sequence of swaps) @@ -440,7 +401,7 @@ If f corresponds to a ≤ or < function on a totally ordered type, this simplifi See [qsort_sorts_of_is_le] or [qsort_sorts_of_is_lt] for these special cases. --/ theorem qsort_sorts (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1): - ISortOf (ITransGen (Completion (f · ·)) low high as) low high as (qsort as f low high) := by + ISortOf (ITransGenCB f low high as) low high as (qsort as f low high) := by apply qsort_sorts_as exact ITransCompat.mkITransGen @@ -451,11 +412,12 @@ If f is a lawful ≤, i.e. a total order, meaning a transitive total relation, q See [qsort_sorts] for the result for arbitrary f --/ -theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) +theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (f · ·) low high as (qsort as f low high) := by - apply qsort_sorts_as - exact iTransCompat_of_trans_total f trans total + apply Eq.mp + apply ISortOf.eq_of_trans_total trans total (f := f) + exact qsort_sorts as f low high /-- If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetric relation, qsort sorts according to f: @@ -466,8 +428,9 @@ See [qsort_sorts] for the result for arbitrary f --/ theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): - ISortOf (λ x y ↦ f y x = false) low high as (qsort as f low high) := by - apply qsort_sorts_as - exact iTransCompat_of_wlinear_asymm f wlinear asymm + ISortOf (λ x y ↦ ¬(f y x)) low high as (qsort as f low high) := by + apply Eq.mp + exact ISortOf.eq_of_wlinear_asymm wlinear asymm + exact qsort_sorts as f low high end Array From 87917b899ea06cc6e0c084e576da62695f87f557 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 14:43:37 +0000 Subject: [PATCH 48/54] use <-> for props instead of = --- src/Init/Data/Array/IntervalPreds.lean | 21 +++++++++------------ src/Init/Data/Array/QSort.lean | 4 ++-- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index 8491dfaa0ac6..1ffa5030de35 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -409,9 +409,8 @@ def of_iTransCompat_iTransGen (h: ITransCompat hr r low high as) (htg: ITransGen apply h.trans i his hli hih j hjs hlj hjh k hks hlk hkh hab hbc def eq_iTransGen_of_iTransCompat_iCompat (h: ITransCompat hr r low high as) (hc: ICompat r hr low high as): - IForAllIcc2 (λ x y ↦ ITransGen hr low high as x y = r x y) low high as := by + IForAllIcc2 (λ x y ↦ ITransGen hr low high as x y ↔ r x y) low high as := by intro i his hli hih j hjs hlj hjh - ext constructor · intro h' apply of_iTransCompat_iTransGen ?_ h' @@ -431,13 +430,13 @@ def not_compat_completion: ICompat (λ x y ↦ ¬r y x) (Completion r) low high exact h def eq_iTransGenC_of_iTransCompatC_iCompat (h: ITransCompatC r r low high as): - IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y = r x y) low high as := by + IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y ↔ r x y) low high as := by apply eq_iTransGen_of_iTransCompat_iCompat · exact h · exact compat_completion def iTransGenC_eq_not_symm_of_iTransCompatC_iCompat (h: ITransCompatC r (λ x y ↦ ¬r y x) low high as): - IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y = ¬r y x) low high as := by + IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y ↔ ¬r y x) low high as := by apply eq_iTransGen_of_iTransCompat_iCompat · exact h · exact not_compat_completion @@ -755,7 +754,7 @@ end IForAllIcc2I -/ namespace IPairwise -def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y = r' x y) low high as): +def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y ↔ r' x y) low high as): IPairwise r low high as = IPairwise r' low high as := by unfold IForAllIcc2 at h unfold IPairwise @@ -767,7 +766,6 @@ def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y = r' x y) low high as): have hih: i ≤ high := Nat.le_trans (Nat.le_of_lt hij) hjh have his: i < as.size := Nat.lt_trans hij hjs have hlj: low ≤ j := Nat.le_trans hli (Nat.le_of_lt hij) - apply eq_iff_iff.mp exact h i his hli hih j hjs hlj hjh theorem glue_with_pivot @@ -884,8 +882,7 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) case ord => exact restrict_out_of_bounds h.ord hsh theorem congr_rel (h: IPerm low high orig sorted → IPairwise r low high sorted = IPairwise r' low high sorted): - ISortOf r low high orig sorted = ISortOf r' low high orig sorted := by - ext + ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by constructor all_goals intro a @@ -893,8 +890,8 @@ theorem congr_rel (h: IPerm low high orig sorted → IPairwise r low high sorted · exact a.perm · exact (h a.perm) ▸ a.ord -theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y = r' x y) low high orig): - ISortOf r low high orig sorted = ISortOf r' low high orig sorted := by +theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y ↔ r' x y) low high orig): + ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by apply ISortOf.congr_rel intro hp apply IPairwise.congr_rel @@ -902,14 +899,14 @@ theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y = r' x y) low high orig): theorem eq_of_trans_total {f: α → α → Bool} (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): - ISortOf (ITransGenCB f low high as) low high as as' = ISortOf (f · · ) low high as as' := by + ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (f · · ) low high as as' := by apply ISortOf.congr_rel' apply eq_iTransGenC_of_iTransCompatC_iCompat exact iTransCompatCB_of_trans_total f trans total theorem eq_of_wlinear_asymm (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): - ISortOf (ITransGenCB f low high as) low high as as' = ISortOf (λ x y ↦ ¬f y x) low high as as' := by + ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (λ x y ↦ ¬f y x) low high as as' := by apply ISortOf.congr_rel' apply iTransGenC_eq_not_symm_of_iTransCompatC_iCompat exact iTransCompatCB_of_wlinear_asymm f wlinear asymm diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index d1d34cb113a3..a49ef0193598 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -415,7 +415,7 @@ See [qsort_sorts] for the result for arbitrary f theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (f · ·) low high as (qsort as f low high) := by - apply Eq.mp + apply Iff.mp apply ISortOf.eq_of_trans_total trans total (f := f) exact qsort_sorts as f low high @@ -429,7 +429,7 @@ See [qsort_sorts] for the result for arbitrary f theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (λ x y ↦ ¬(f y x)) low high as (qsort as f low high) := by - apply Eq.mp + apply Iff.mp exact ISortOf.eq_of_wlinear_asymm wlinear asymm exact qsort_sorts as f low high From 6bc8d6832c62713ebac8259d44c2ead6710e1ddb Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 14:45:39 +0000 Subject: [PATCH 49/54] style --- src/Init/Data/Array/QSort.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index a49ef0193598..ba434faf87cc 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -416,8 +416,8 @@ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (f · ·) low high as (qsort as f low high) := by apply Iff.mp - apply ISortOf.eq_of_trans_total trans total (f := f) - exact qsort_sorts as f low high + · exact ISortOf.eq_of_trans_total trans total (f := f) + · exact qsort_sorts as f low high /-- If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetric relation, qsort sorts according to f: @@ -430,7 +430,7 @@ theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) ( (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (λ x y ↦ ¬(f y x)) low high as (qsort as f low high) := by apply Iff.mp - exact ISortOf.eq_of_wlinear_asymm wlinear asymm - exact qsort_sorts as f low high + · exact ISortOf.eq_of_wlinear_asymm wlinear asymm + · exact qsort_sorts as f low high end Array From f4a2a24ed506a560415692df9b7abb04ab1bf047 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 14:46:01 +0000 Subject: [PATCH 50/54] style --- src/Init/Data/Array/QSort.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index ba434faf87cc..be3a2e637e3c 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -416,7 +416,7 @@ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (f · ·) low high as (qsort as f low high) := by apply Iff.mp - · exact ISortOf.eq_of_trans_total trans total (f := f) + · exact ISortOf.eq_of_trans_total trans total · exact qsort_sorts as f low high /-- From e8582e4390c0f548650e6667b85ef1608283fefa Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 14:56:25 +0000 Subject: [PATCH 51/54] rename eq to iff --- src/Init/Data/Array/IntervalPreds.lean | 4 ++-- src/Init/Data/Array/QSort.lean | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index 1ffa5030de35..adaeec4b4520 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -897,14 +897,14 @@ theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y ↔ r' x y) low high orig): apply IPairwise.congr_rel apply transport_exact_icc h hp -theorem eq_of_trans_total {f: α → α → Bool} +theorem iff_of_trans_total {f: α → α → Bool} (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (f · · ) low high as as' := by apply ISortOf.congr_rel' apply eq_iTransGenC_of_iTransCompatC_iCompat exact iTransCompatCB_of_trans_total f trans total -theorem eq_of_wlinear_asymm +theorem iff_of_wlinear_asymm (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (λ x y ↦ ¬f y x) low high as as' := by apply ISortOf.congr_rel' diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index be3a2e637e3c..cd8bc76b5d5e 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -416,7 +416,7 @@ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (f · ·) low high as (qsort as f low high) := by apply Iff.mp - · exact ISortOf.eq_of_trans_total trans total + · exact ISortOf.iff_of_trans_total trans total · exact qsort_sorts as f low high /-- @@ -430,7 +430,7 @@ theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) ( (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (λ x y ↦ ¬(f y x)) low high as (qsort as f low high) := by apply Iff.mp - · exact ISortOf.eq_of_wlinear_asymm wlinear asymm + · exact ISortOf.iff_of_wlinear_asymm wlinear asymm · exact qsort_sorts as f low high end Array From 8496bbb4195dab248bdec7c4f562acd48984b97f Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 15:15:10 +0000 Subject: [PATCH 52/54] rename --- src/Init/Data/Array/IntervalPreds.lean | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index adaeec4b4520..f2966d207235 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -360,7 +360,8 @@ abbrev ITransCompatC (hr: α → α → Prop) (r: α → α → Prop) (low high: abbrev ITransCompatCB (f: α → α → Bool) (r: α → α → Prop) (low high: Nat) (as: Array α) := ITransCompatC (f · ·) r low high as -theorem iTransCompatCB_of_trans_total (f: α → α → Bool) +namespace ITransCompatCB +theorem of_trans_total (f: α → α → Bool) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ITransCompatCB (f · ·) (f · ·) low high as := by constructor @@ -377,7 +378,7 @@ theorem iTransCompatCB_of_trans_total (f: α → α → Bool) intro i his _ _ j hjs _ _ k hks _ _ hxy hyz apply trans hxy hyz -theorem iTransCompatCB_of_wlinear_asymm (f: α → α → Bool) +theorem of_wlinear_asymm (f: α → α → Bool) (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ITransCompatCB (f · ·) (λ x y ↦ ¬f y x) low high as := by constructor @@ -395,6 +396,7 @@ theorem iTransCompatCB_of_wlinear_asymm (f: α → α → Bool) apply not_or_intro hyz hxy apply wlinear exact hki +end ITransCompatCB def of_iTransCompat_iTransGen (h: ITransCompat hr r low high as) (htg: ITransGen hr low high as x y): r x y := by @@ -902,14 +904,14 @@ theorem iff_of_trans_total {f: α → α → Bool} ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (f · · ) low high as as' := by apply ISortOf.congr_rel' apply eq_iTransGenC_of_iTransCompatC_iCompat - exact iTransCompatCB_of_trans_total f trans total + exact ITransCompatCB.of_trans_total f trans total theorem iff_of_wlinear_asymm (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (λ x y ↦ ¬f y x) low high as as' := by apply ISortOf.congr_rel' apply iTransGenC_eq_not_symm_of_iTransCompatC_iCompat - exact iTransCompatCB_of_wlinear_asymm f wlinear asymm + exact ITransCompatCB.of_wlinear_asymm f wlinear asymm end ISortOf From ba46fb7384a7f30e7735f01bdebc89fe1d96fd66 Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 15:22:05 +0000 Subject: [PATCH 53/54] more eq to iff --- src/Init/Data/Array/IntervalPreds.lean | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index f2966d207235..fd0ccb33e659 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -757,10 +757,9 @@ end IForAllIcc2I namespace IPairwise def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y ↔ r' x y) low high as): - IPairwise r low high as = IPairwise r' low high as := by + IPairwise r low high as ↔ IPairwise r' low high as := by unfold IForAllIcc2 at h unfold IPairwise - ext apply forall₂_congr intro i j apply forall₄_congr @@ -883,14 +882,17 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) case perm => exact h.perm.resize_out_of_bounds hsh' case ord => exact restrict_out_of_bounds h.ord hsh -theorem congr_rel (h: IPerm low high orig sorted → IPairwise r low high sorted = IPairwise r' low high sorted): +theorem congr_rel (h: IPerm low high orig sorted → (IPairwise r low high sorted ↔ IPairwise r' low high sorted)): ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by constructor - all_goals - intro a + · intro a constructor · exact a.perm - · exact (h a.perm) ▸ a.ord + · exact (h a.perm).mp a.ord + · intro a + constructor + · exact a.perm + · exact (h a.perm).mpr a.ord theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y ↔ r' x y) low high orig): ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by From 4dc21828ffe28f7ebe5295596108a29b6a92ff0d Mon Sep 17 00:00:00 2001 From: lyphyser Date: Wed, 18 Sep 2024 17:46:57 +0000 Subject: [PATCH 54/54] more ISortOf results --- src/Init/Data/Array/IntervalPreds.lean | 168 +++++++++++++++++++------ src/Init/Data/Array/QSort.lean | 4 +- 2 files changed, 130 insertions(+), 42 deletions(-) diff --git a/src/Init/Data/Array/IntervalPreds.lean b/src/Init/Data/Array/IntervalPreds.lean index fd0ccb33e659..8709a56702a9 100644 --- a/src/Init/Data/Array/IntervalPreds.lean +++ b/src/Init/Data/Array/IntervalPreds.lean @@ -31,6 +31,24 @@ theorem dite (p: Prop) [Decidable p] (low high: Nat) (as0: Array α) (ast: p → case isTrue h => exact hpt h case isFalse h => exact hpf h +theorem size_eq + (hp: IPerm low high as as' ): as.size = as'.size := by + induction hp with + | refl => rfl + | trans _ _ ih ih' => rwa [ih'] at ih + | swap => simp only [size_swap] + +theorem symm (hp: IPerm low high as as'): IPerm low high as' as := by + induction hp with + | refl => exact refl + | trans _ _ ih ih' => exact trans ih' ih + | swap as i his hli hih j hjs hlj hjh => + have hs := (size_swap as ⟨i, his⟩ ⟨j, hjs⟩).symm + have := swap _ + i (hs ▸ his) hli hih + j (hs ▸ hjs) hlj hjh + rwa [swap_swap] at this + theorem trans_swap (hp: IPerm low high as0 as) (i: Nat) (his: i < as.size) (hli: low ≤ i) (hih: i ≤ high) (j: Nat) (hjs: j < as.size) (hlj: low ≤ j) (hjh: j ≤ high): IPerm low high as0 (as.swap ⟨i, his⟩ ⟨j, hjs⟩) := by apply IPerm.trans hp @@ -55,13 +73,6 @@ theorem expand_down (hll: low' ≤ low) (hp: IPerm low high as as'): IPerm low' high as as' := hp.expand hll (Nat.le_refl _) -theorem size_eq - (hp: IPerm low high as as' ): as.size = as'.size := by - induction hp with - | refl => rfl - | trans _ _ ih ih' => rwa [ih'] at ih - | swap => simp only [size_swap] - theorem eq_of_singleton (hp: IPerm k k as as' ): as = as' := by induction hp with | refl => rfl @@ -143,21 +154,61 @@ end IPerm def IForAllIco (P: α → Prop) (low high: Nat) (as: Array α) := ∀ k, (hks: k < as.size) → low ≤ k → (hkh: k < high) → P (as[k]'hks) +namespace IForAllIco +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: {a: α} → P a → Q a): + IForAllIco Q low high as := by + iterate 4 + intro x + specialize ha x + apply f + exact ha +end IForAllIco + def IForAllIcc (P: α → Prop) (low high: Nat) (as: Array α) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → P (as[i]'his) +namespace ForAllIcc +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIcc P low high as) (f: {a: α} → P a → Q a): + IForAllIcc Q low high as := by + iterate 4 + intro x + specialize ha x + apply f + exact ha +end ForAllIcc + def IForAllIcc2 (P: α → α → Prop) (low high: Nat) (as: Array α) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → P (as[i]'his) (as[j]'hjs) +namespace IForAllIcc2 +theorem map {P: α → α → Prop} {Q: α → α → Prop} (ha: IForAllIcc2 P low high as) (f: {a: α} → {b: α} → P a b → Q a b): + IForAllIcc2 Q low high as := by + iterate 8 + intro x + specialize ha x + apply f + exact ha +end IForAllIcc2 + def IForAllIcc3 (P: α → α → α → Prop) (low high: Nat) (as: Array α) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → (j: Nat) → (hjs: j < as.size) → low ≤ j → j ≤ high → (k: Nat) → (hks: k < as.size) → low ≤ k → k ≤ high → P (as[i]'his) (as[j]'hjs) (as[k]'hks) +namespace ForAllIcc3 +theorem map {P: α → α → α → Prop} {Q: α → α → α → Prop} (ha: IForAllIcc3 P low high as) (f: (a: α) → (b: α) → (c: α) → P a b c → Q a b c): + IForAllIcc3 Q low high as := by + iterate 12 + intro x + specialize ha x + apply f + exact ha +end ForAllIcc3 + /- def IForAllIcc2I (P: Nat → Nat → α → α → Prop) (low high: Nat) (as: Array α) := (i: Nat) → (his: i < as.size) → low ≤ i → i ≤ high → @@ -175,12 +226,6 @@ abbrev IForAllIcoSwap (as: Array α) (i j) (his: i < as.size) (hjs: j < as.size) IForAllIco P low high (as.swap ⟨i, his⟩ ⟨j, hjs⟩) namespace IForAllIco -theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: (a: α) → P a → Q a): - IForAllIco Q low high as := by - intro k hks hlk hkh - specialize ha k hks hlk hkh - exact f (as[k]'hks) ha - theorem swap_left (hij: i ≤ j) {hjs: j < as.size} (hjp: P (as[j]'hjs)) (ha: IForAllIco P low i as): @@ -410,23 +455,37 @@ def of_iTransCompat_iTransGen (h: ITransCompat hr r low high as) (htg: ITransGen subst a b c apply h.trans i his hli hih j hjs hlj hjh k hks hlk hkh hab hbc +theorem iForAll_of_iTransCompat_iTransGen + (hrel: ITransCompat hr r low high as): + IForAllIcc2 (λ x y ↦ ITransGen hr low high as x y → r x y) low high as:= by + intro i his _ _ + intro j his _ _ + exact of_iTransCompat_iTransGen hrel + +/- +def left_iTransGen_of_iTransCompat_iCompat (hc: ICompat r hr low high as): + IForAllIcc2 (λ x y ↦ r x y → ITransGen hr low high as x y) low high as := by + intro i his hli hih j hjs hlj hjh + intro h' + apply ITransGen.base i his hli hih j hjs hlj hjh + exact hc i his hli hih j hjs hlj hjh h' +-/ + def eq_iTransGen_of_iTransCompat_iCompat (h: ITransCompat hr r low high as) (hc: ICompat r hr low high as): IForAllIcc2 (λ x y ↦ ITransGen hr low high as x y ↔ r x y) low high as := by intro i his hli hih j hjs hlj hjh constructor - · intro h' - apply of_iTransCompat_iTransGen ?_ h' - exact h + · exact iForAll_of_iTransCompat_iTransGen h i his hli hih j hjs hlj hjh · intro h' apply ITransGen.base i his hli hih j hjs hlj hjh exact hc i his hli hih j hjs hlj hjh h' -def compat_completion: ICompat r (Completion r) low high as := by +def iCompat_completion: ICompat r (Completion r) low high as := by repeat intro h left exact h -def not_compat_completion: ICompat (λ x y ↦ ¬r y x) (Completion r) low high as := by +def not_iCompat_completion: ICompat (λ x y ↦ ¬r y x) (Completion r) low high as := by repeat intro h right exact h @@ -435,13 +494,13 @@ def eq_iTransGenC_of_iTransCompatC_iCompat (h: ITransCompatC r r low high as): IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y ↔ r x y) low high as := by apply eq_iTransGen_of_iTransCompat_iCompat · exact h - · exact compat_completion + · exact iCompat_completion def iTransGenC_eq_not_symm_of_iTransCompatC_iCompat (h: ITransCompatC r (λ x y ↦ ¬r y x) low high as): IForAllIcc2 (λ x y ↦ ITransGenC r low high as x y ↔ ¬r y x) low high as := by apply eq_iTransGen_of_iTransCompat_iCompat · exact h - · exact not_compat_completion + · exact not_iCompat_completion local macro "elementwise" t:term : tactic => @@ -487,6 +546,15 @@ instance {k: Nat} {as: Array α} [Trivial α T LE.le]: Inhabited (T (k + 1) k as instance {k: Nat} {as: Array α} [Trivial α T LT.lt]: Inhabited (T (k + 1) k as) where default := trivial (Nat.lt_add_one k) +theorem map {P: α → Prop} {Q: α → Prop} (ha: IForAllIco P low high as) (f: {a: α} → P a → Q a): + IForAllIco Q low high as := by + iterate 4 intro _ + iterate 4 + specialize ha _ + assumption + apply f + exact ha + class Restrictable (α) (T: Nat → Nat → Array α → Prop) where restrict (ha: T low high as) (hll: low ≤ low') (hhh: high' ≤ high) @@ -756,18 +824,23 @@ end IForAllIcc2I -/ namespace IPairwise -def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y ↔ r' x y) low high as): - IPairwise r low high as ↔ IPairwise r' low high as := by - unfold IForAllIcc2 at h - unfold IPairwise - apply forall₂_congr +def imap (h:IPairwise r low high as) (f: IForAllIcc2 (λ x y ↦ r x y → r' x y) low high as): + IPairwise r' low high as := by intro i j - apply forall₄_congr intro hli hij hjh hjs have hih: i ≤ high := Nat.le_trans (Nat.le_of_lt hij) hjh have his: i < as.size := Nat.lt_trans hij hjs have hlj: low ≤ j := Nat.le_trans hli (Nat.le_of_lt hij) - exact h i his hli hih j hjs hlj hjh + apply f i his hli hih j hjs hlj hjh + exact h i j hli hij hjh hjs + +def congr_rel (h: IForAllIcc2 (λ x y ↦ r x y ↔ r' x y) low high as): + IPairwise r low high as ↔ IPairwise r' low high as := by + constructor + · intro h' + exact imap h' (IForAllIcc2.map h Iff.mp) + · intro h' + exact imap h' (IForAllIcc2.map h Iff.mpr) theorem glue_with_pivot {r: α → α → Prop} @@ -882,36 +955,51 @@ theorem resize_out_of_bounds (h: ISortOf r low high as0 as) (hsh: (as.size - 1) case perm => exact h.perm.resize_out_of_bounds hsh' case ord => exact restrict_out_of_bounds h.ord hsh -theorem congr_rel (h: IPerm low high orig sorted → (IPairwise r low high sorted ↔ IPairwise r' low high sorted)): +theorem map_ord (h: ISortOf r low high orig sorted) (f: IPerm low high orig sorted → IPairwise r low high sorted → IPairwise r' low high sorted) + : ISortOf r' low high orig sorted := by + constructor + · exact h.perm + · exact f h.perm h.ord + +theorem congr_ord (h: IPerm low high orig sorted → (IPairwise r low high sorted ↔ IPairwise r' low high sorted)): ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by constructor - · intro a - constructor - · exact a.perm - · exact (h a.perm).mp a.ord - · intro a - constructor - · exact a.perm - · exact (h a.perm).mpr a.ord + · exact (map_ord · (h · |> Iff.mp)) + · exact (map_ord · (h · |> Iff.mpr)) -theorem congr_rel' (h: IForAllIcc2 (fun x y => r x y ↔ r' x y) low high orig): +theorem imap (h: ISortOf r low high orig sorted) (f: IForAllIcc2 (fun x y => r x y → r' x y) low high orig): + ISortOf r' low high orig sorted := by + apply ISortOf.map_ord h + intro hp + intro h' + apply IPairwise.imap + exact h' + apply transport_exact_icc f hp + +theorem congr_rel (h: IForAllIcc2 (fun x y => r x y ↔ r' x y) low high orig): ISortOf r low high orig sorted ↔ ISortOf r' low high orig sorted := by - apply ISortOf.congr_rel + apply ISortOf.congr_ord intro hp apply IPairwise.congr_rel apply transport_exact_icc h hp +theorem of_iSortOf_ITransGen (h: ISortOf (ITransGen hr low high as) low high as as') + (hrel: ITransCompat hr r low high as): + (ISortOf r low high as as'):= by + apply imap h + exact iForAll_of_iTransCompat_iTransGen hrel + theorem iff_of_trans_total {f: α → α → Bool} (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (f · · ) low high as as' := by - apply ISortOf.congr_rel' + apply ISortOf.congr_rel apply eq_iTransGenC_of_iTransCompatC_iCompat exact ITransCompatCB.of_trans_total f trans total theorem iff_of_wlinear_asymm (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x): ISortOf (ITransGenCB f low high as) low high as as' ↔ ISortOf (λ x y ↦ ¬f y x) low high as as' := by - apply ISortOf.congr_rel' + apply ISortOf.congr_rel apply iTransGenC_eq_not_symm_of_iTransCompatC_iCompat exact ITransCompatCB.of_wlinear_asymm f wlinear asymm diff --git a/src/Init/Data/Array/QSort.lean b/src/Init/Data/Array/QSort.lean index cd8bc76b5d5e..bd60b0b86353 100644 --- a/src/Init/Data/Array/QSort.lean +++ b/src/Init/Data/Array/QSort.lean @@ -410,7 +410,7 @@ If f is a lawful ≤, i.e. a total order, meaning a transitive total relation, q - The output is a permutation of the input - If i < j, then f out[i] out[j] -See [qsort_sorts] for the result for arbitrary f +See [qsort_sorts] and [qsort_sorts_as] for the result for arbitrary f --/ theorem qsort_sorts_of_is_le (as: Array α) (f: α → α → Bool) (low) (high) (trans: ∀ {x y z}, f x y → f y z → f x z) (total: ∀ {x y}, f x y ∨ f y x): @@ -424,7 +424,7 @@ If f is a lawful <, i.e. a strict total order, meaning a weakly linear asymmetri - The output is a permutation of the input - If i < j, then ¬ f out[j] < f out[i] -See [qsort_sorts] for the result for arbitrary f +See [qsort_sorts] and [qsort_sorts_as] for the result for arbitrary f --/ theorem qsort_sorts_of_is_lt (as: Array α) (f: α → α → Bool) (low := 0) (high := as.size - 1) (wlinear: ∀ {x y z}, f x z → f x y ∨ f y z) (asymm: ∀ {x y}, f x y → ¬f y x):