/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.ordmap.ordnode
import algebra.order.ring
import data.nat.dist
import tactic.linarith

/-!
# Verification of the `ordnode α` datatype

This file proves the correctness of the operations in `data.ordmap.ordnode`.
The public facing version is the type `ordset α`, which is a wrapper around
`ordnode α` which includes the correctness invariant of the type, and it exposes
parallel operations like `insert` as functions on `ordset` that do the same
thing but bundle the correctness proofs. The advantage is that it is possible
to, for example, prove that the result of `find` on `insert` will actually find
the element, while `ordnode` cannot guarantee this if the input tree did not
satisfy the type invariants.

## Main definitions

* `ordset α`: A well formed set of values of type `α`

## Implementation notes

The majority of this file is actually in the `ordnode` namespace, because we first
have to prove the correctness of all the operations (and defining what correctness
means here is actually somewhat subtle). So all the actual `ordset` operations are
at the very end, once we have all the theorems.

An `ordnode α` is an inductive type which describes a tree which stores the `size` at
internal nodes. The correctness invariant of an `ordnode α` is:

* `ordnode.sized t`: All internal `size` fields must match the actual measured
  size of the tree. (This is not hard to satisfy.)
* `ordnode.balanced t`: Unless the tree has the form `()` or `((a) b)` or `(a (b))`
  (that is, nil or a single singleton subtree), the two subtrees must satisfy
  `size l ≤ δ * size r` and `size r ≤ δ * size l`, where `δ := 3` is a global
  parameter of the data structure (and this property must hold recursively at subtrees).
  This is why we say this is a "size balanced tree" data structure.
* `ordnode.bounded lo hi t`: The members of the tree must be in strictly increasing order,
  meaning that if `a` is in the left subtree and `b` is the root, then `a ≤ b` and
  `¬ (b ≤ a)`. We enforce this using `ordnode.bounded` which includes also a global
  upper and lower bound.

Because the `ordnode` file was ported from Haskell, the correctness invariants of some
of the functions have not been spelled out, and some theorems like
`ordnode.valid'.balance_l_aux` show very intricate assumptions on the sizes,
which may need to be revised if it turns out some operations violate these assumptions,
because there is a decent amount of slop in the actual data structure invariants, so the
theorem will go through with multiple choices of assumption.

**Note:** This file is incomplete, in the sense that the intent is to have verified
versions and lemmas about all the definitions in `ordnode.lean`, but at the moment only
a few operations are verified (the hard part should be out of the way, but still).
Contributors are encouraged to pick this up and finish the job, if it appeals to you.

## Tags

ordered map, ordered set, data structure, verified programming

-/

variable {α : Type*}
namespace ordnode

/-! ### delta and ratio -/

theorem not_le_delta {s} (H : 1 ≤ s) : ¬ s ≤ delta * 0 :=
not_le_of_gt H

theorem delta_lt_false {a b : ℕ}
  (h₁ : delta * a < b) (h₂ : delta * b < a) : false :=
not_le_of_lt (lt_trans ((mul_lt_mul_left dec_trivial).2 h₁) h₂) $
by simpa [mul_assoc] using nat.mul_le_mul_right a (dec_trivial : 1 ≤ delta * delta)

/-! ### `singleton` -/

/-! ### `size` and `empty` -/

/-- O(n). Computes the actual number of elements in the set, ignoring the cached `size` field. -/
def real_size : ordnode α → ℕ
| nil := 0
| (node _ l _ r) := real_size l + real_size r + 1

/-! ### `sized` -/

/-- The `sized` property asserts that all the `size` fields in nodes match the actual size of the
respective subtrees. -/
def sized : ordnode α → Prop
| nil := true
| (node s l _ r) := s = size l + size r + 1 ∧ sized l ∧ sized r

theorem sized.node' {l x r} (hl : @sized α l) (hr : sized r) : sized (node' l x r) :=
⟨rfl, hl, hr⟩

theorem sized.eq_node' {s l x r} (h : @sized α (node s l x r)) : node s l x r = node' l x r :=
by rw h.1; refl

theorem sized.size_eq {s l x r} (H : sized (@node α s l x r)) :
  size (@node α s l x r) = size l + size r + 1 := H.1

@[elab_as_eliminator] theorem sized.induction {t} (hl : @sized α t)
  {C : ordnode α → Prop} (H0 : C nil)
  (H1 : ∀ l x r, C l → C r → C (node' l x r)) : C t :=
begin
  induction t, {exact H0},
  rw hl.eq_node',
  exact H1 _ _ _ (t_ih_l hl.2.1) (t_ih_r hl.2.2)
end

theorem size_eq_real_size : ∀ {t : ordnode α}, sized t → size t = real_size t
| nil _ := rfl
| (node s l x r) ⟨h₁, h₂, h₃⟩ :=
  by rw [size, h₁, size_eq_real_size h₂, size_eq_real_size h₃]; refl

@[simp] theorem sized.size_eq_zero {t : ordnode α} (ht : sized t) : size t = 0 ↔ t = nil :=
by cases t; [simp, simp [ht.1]]

theorem sized.pos {s l x r} (h : sized (@node α s l x r)) : 0 < s :=
by rw h.1; apply nat.le_add_left

/-! `dual` -/

theorem dual_dual : ∀ (t : ordnode α), dual (dual t) = t
| nil := rfl
| (node s l x r) := by rw [dual, dual, dual_dual, dual_dual]

@[simp] theorem size_dual (t : ordnode α) : size (dual t) = size t :=
by cases t; refl

/-! `balanced` -/

/-- The `balanced_sz l r` asserts that a hypothetical tree with children of sizes `l` and `r` is
balanced: either `l ≤ δ * r` and `r ≤ δ * r`, or the tree is trivial with a singleton on one side
and nothing on the other. -/
def balanced_sz (l r : ℕ) : Prop :=
l + r ≤ 1 ∨ (l ≤ delta * r ∧ r ≤ delta * l)

instance balanced_sz.dec : decidable_rel balanced_sz := λ l r, or.decidable

/-- The `balanced t` asserts that the tree `t` satisfies the balance invariants
(at every level). -/
def balanced : ordnode α → Prop
| nil := true
| (node _ l _ r) := balanced_sz (size l) (size r) ∧ balanced l ∧ balanced r

instance balanced.dec : decidable_pred (@balanced α) | t :=
by induction t; unfold balanced; resetI; apply_instance

theorem balanced_sz.symm {l r : ℕ} : balanced_sz l r → balanced_sz r l :=
or.imp (by rw add_comm; exact id) and.symm

theorem balanced_sz_zero {l : ℕ} : balanced_sz l 0 ↔ l ≤ 1 :=
by simp [balanced_sz] { contextual := tt }

theorem balanced_sz_up {l r₁ r₂ : ℕ} (h₁ : r₁ ≤ r₂)
  (h₂ : l + r₂ ≤ 1 ∨ r₂ ≤ delta * l)
  (H : balanced_sz l r₁) : balanced_sz l r₂ :=
begin
  refine or_iff_not_imp_left.2 (λ h, _),
  refine ⟨_, h₂.resolve_left h⟩,
  cases H,
  { cases r₂,
    { cases h (le_trans (nat.add_le_add_left (nat.zero_le _) _) H) },
    { exact le_trans (le_trans (nat.le_add_right _ _) H) (nat.le_add_left 1 _) } },
  { exact le_trans H.1 (nat.mul_le_mul_left _ h₁) }
end

theorem balanced_sz_down {l r₁ r₂ : ℕ} (h₁ : r₁ ≤ r₂)
  (h₂ : l + r₂ ≤ 1 ∨ l ≤ delta * r₁)
  (H : balanced_sz l r₂) : balanced_sz l r₁ :=
have l + r₂ ≤ 1 → balanced_sz l r₁, from
  λ H, or.inl (le_trans (nat.add_le_add_left h₁ _) H),
or.cases_on H this (λ H, or.cases_on h₂ this (λ h₂,
  or.inr ⟨h₂, le_trans h₁ H.2⟩))

theorem balanced.dual : ∀ {t : ordnode α}, balanced t → balanced (dual t)
| nil h := ⟨⟩
| (node s l x r) ⟨b, bl, br⟩ :=
  ⟨by rw [size_dual, size_dual]; exact b.symm, br.dual, bl.dual⟩

/-! ### `rotate` and `balance` -/

/-- Build a tree from three nodes, left associated (ignores the invariants). -/
def node3_l (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) : ordnode α :=
node' (node' l x m) y r

/-- Build a tree from three nodes, right associated (ignores the invariants). -/
def node3_r (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) : ordnode α :=
node' l x (node' m y r)

/-- Build a tree from three nodes, with `a () b -> (a ()) b` and `a (b c) d -> ((a b) (c d))`. -/
def node4_l : ordnode α → α → ordnode α → α → ordnode α → ordnode α
| l x (node _ ml y mr) z r := node' (node' l x ml) y (node' mr z r)
| l x nil z r := node3_l l x nil z r -- should not happen

/-- Build a tree from three nodes, with `a () b -> a (() b)` and `a (b c) d -> ((a b) (c d))`. -/
def node4_r : ordnode α → α → ordnode α → α → ordnode α → ordnode α
| l x (node _ ml y mr) z r := node' (node' l x ml) y (node' mr z r)
| l x nil z r := node3_r l x nil z r -- should not happen

/-- Concatenate two nodes, performing a left rotation `x (y z) -> ((x y) z)`
if balance is upset. -/
def rotate_l : ordnode α → α → ordnode α → ordnode α
| l x (node _ m y r) :=
  if size m < ratio * size r then node3_l l x m y r else node4_l l x m y r
| l x nil := node' l x nil -- should not happen

/-- Concatenate two nodes, performing a right rotation `(x y) z -> (x (y z))`
if balance is upset. -/
def rotate_r : ordnode α → α → ordnode α → ordnode α
| (node _ l x m) y r :=
  if size m < ratio * size l then node3_r l x m y r else node4_r l x m y r
| nil y r :=  node' nil y r -- should not happen

/-- A left balance operation. This will rebalance a concatenation, assuming the original nodes are
not too far from balanced. -/
def balance_l' (l : ordnode α) (x : α) (r : ordnode α) : ordnode α :=
if size l + size r ≤ 1 then node' l x r else
if size l > delta * size r then rotate_r l x r else
node' l x r

/-- A right balance operation. This will rebalance a concatenation, assuming the original nodes are
not too far from balanced. -/
def balance_r' (l : ordnode α) (x : α) (r : ordnode α) : ordnode α :=
if size l + size r ≤ 1 then node' l x r else
if size r > delta * size l then rotate_l l x r else
node' l x r

/-- The full balance operation. This is the same as `balance`, but with less manual inlining.
It is somewhat easier to work with this version in proofs. -/
def balance' (l : ordnode α) (x : α) (r : ordnode α) : ordnode α :=
if size l + size r ≤ 1 then node' l x r else
if size r > delta * size l then rotate_l l x r else
if size l > delta * size r then rotate_r l x r else
node' l x r

theorem dual_node' (l : ordnode α) (x : α) (r : ordnode α) :
  dual (node' l x r) = node' (dual r) x (dual l) := by simp [node', add_comm]

theorem dual_node3_l (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) :
  dual (node3_l l x m y r) = node3_r (dual r) y (dual m) x (dual l) :=
by simp [node3_l, node3_r, dual_node']

theorem dual_node3_r (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) :
  dual (node3_r l x m y r) = node3_l (dual r) y (dual m) x (dual l) :=
by simp [node3_l, node3_r, dual_node']

theorem dual_node4_l (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) :
  dual (node4_l l x m y r) = node4_r (dual r) y (dual m) x (dual l) :=
by cases m; simp [node4_l, node4_r, dual_node3_l, dual_node']

theorem dual_node4_r (l : ordnode α) (x : α) (m : ordnode α) (y : α) (r : ordnode α) :
  dual (node4_r l x m y r) = node4_l (dual r) y (dual m) x (dual l) :=
by cases m; simp [node4_l, node4_r, dual_node3_r, dual_node']

theorem dual_rotate_l (l : ordnode α) (x : α) (r : ordnode α) :
  dual (rotate_l l x r) = rotate_r (dual r) x (dual l) :=
by cases r; simp [rotate_l, rotate_r, dual_node'];
   split_ifs; simp [dual_node3_l, dual_node4_l]

theorem dual_rotate_r (l : ordnode α) (x : α) (r : ordnode α) :
  dual (rotate_r l x r) = rotate_l (dual r) x (dual l) :=
by rw [← dual_dual (rotate_l _ _ _), dual_rotate_l, dual_dual, dual_dual]

theorem dual_balance' (l : ordnode α) (x : α) (r : ordnode α) :
  dual (balance' l x r) = balance' (dual r) x (dual l) :=
begin
  simp [balance', add_comm], split_ifs; simp [dual_node', dual_rotate_l, dual_rotate_r],
  cases delta_lt_false h_1 h_2
end

theorem dual_balance_l (l : ordnode α) (x : α) (r : ordnode α) :
  dual (balance_l l x r) = balance_r (dual r) x (dual l) :=
begin
  unfold balance_l balance_r,
  cases r with rs rl rx rr,
  { cases l with ls ll lx lr, {refl},
    cases ll with lls lll llx llr; cases lr with lrs lrl lrx lrr;
      dsimp only [dual]; try {refl},
    split_ifs; repeat {simp [h, add_comm]} },
  { cases l with ls ll lx lr, {refl},
    dsimp only [dual],
    split_ifs, swap, {simp [add_comm]},
    cases ll with lls lll llx llr; cases lr with lrs lrl lrx lrr; try {refl},
    dsimp only [dual],
    split_ifs; simp [h, add_comm] },
end

theorem dual_balance_r (l : ordnode α) (x : α) (r : ordnode α) :
  dual (balance_r l x r) = balance_l (dual r) x (dual l) :=
by rw [← dual_dual (balance_l _ _ _), dual_balance_l, dual_dual, dual_dual]

theorem sized.node3_l {l x m y r}
  (hl : @sized α l) (hm : sized m) (hr : sized r) : sized (node3_l l x m y r) :=
(hl.node' hm).node' hr

theorem sized.node3_r {l x m y r}
  (hl : @sized α l) (hm : sized m) (hr : sized r) : sized (node3_r l x m y r) :=
hl.node' (hm.node' hr)

theorem sized.node4_l {l x m y r}
  (hl : @sized α l) (hm : sized m) (hr : sized r) : sized (node4_l l x m y r) :=
by cases m; [exact (hl.node' hm).node' hr,
  exact (hl.node' hm.2.1).node' (hm.2.2.node' hr)]

theorem node3_l_size {l x m y r} :
  size (@node3_l α l x m y r) = size l + size m + size r + 2 :=
by dsimp [node3_l, node', size]; rw add_right_comm _ 1

theorem node3_r_size {l x m y r} :
  size (@node3_r α l x m y r) = size l + size m + size r + 2 :=
by dsimp [node3_r, node', size]; rw [← add_assoc, ← add_assoc]

theorem node4_l_size {l x m y r} (hm : sized m) :
  size (@node4_l α l x m y r) = size l + size m + size r + 2 :=
by cases m; simp [node4_l, node3_l, node', add_comm, add_left_comm]; [skip, simp [size, hm.1]];
   rw [← add_assoc, ← bit0]; simp [add_comm, add_left_comm]

theorem sized.dual : ∀ {t : ordnode α} (h : sized t), sized (dual t)
| nil h := ⟨⟩
| (node s l x r) ⟨rfl, sl, sr⟩ := ⟨by simp [size_dual, add_comm], sized.dual sr, sized.dual sl⟩

theorem sized.dual_iff {t : ordnode α} : sized (dual t) ↔ sized t :=
⟨λ h, by rw ← dual_dual t; exact h.dual, sized.dual⟩

theorem sized.rotate_l {l x r} (hl : @sized α l) (hr : sized r) : sized (rotate_l l x r) :=
begin
  cases r, {exact hl.node' hr},
  rw rotate_l, split_ifs,
  { exact hl.node3_l hr.2.1 hr.2.2 },
  { exact hl.node4_l hr.2.1 hr.2.2 }
end

theorem sized.rotate_r {l x r} (hl : @sized α l) (hr : sized r) : sized (rotate_r l x r) :=
sized.dual_iff.1 $ by rw dual_rotate_r; exact hr.dual.rotate_l hl.dual

theorem sized.rotate_l_size {l x r} (hm : sized r) :
  size (@rotate_l α l x r) = size l + size r + 1 :=
begin
  cases r; simp [rotate_l],
  simp [size, hm.1, add_comm, add_left_comm], rw [← add_assoc, ← bit0], simp,
  split_ifs; simp [node3_l_size, node4_l_size hm.2.1, add_comm, add_left_comm]
end

theorem sized.rotate_r_size {l x r} (hl : sized l) :
  size (@rotate_r α l x r) = size l + size r + 1 :=
by rw [← size_dual, dual_rotate_r, hl.dual.rotate_l_size,
  size_dual, size_dual, add_comm (size l)]

theorem sized.balance' {l x r} (hl : @sized α l) (hr : sized r) : sized (balance' l x r) :=
begin
  unfold balance', split_ifs,
  { exact hl.node' hr },
  { exact hl.rotate_l hr },
  { exact hl.rotate_r hr },
  { exact hl.node' hr }
end

theorem size_balance' {l x r} (hl : @sized α l) (hr : sized r) :
  size (@balance' α l x r) = size l + size r + 1 :=
begin
  unfold balance', split_ifs,
  { refl },
  { exact hr.rotate_l_size },
  { exact hl.rotate_r_size },
  { refl }
end

/-! ## `all`, `any`, `emem`, `amem` -/

theorem all.imp {P Q : α → Prop} (H : ∀ a, P a → Q a) : ∀ {t}, all P t → all Q t
| nil h := ⟨⟩
| (node _ l x r) ⟨h₁, h₂, h₃⟩ := ⟨h₁.imp, H _ h₂, h₃.imp⟩

theorem any.imp {P Q : α → Prop} (H : ∀ a, P a → Q a) : ∀ {t}, any P t → any Q t
| nil := id
| (node _ l x r) := or.imp any.imp $ or.imp (H _) any.imp

theorem all_singleton {P : α → Prop} {x : α} : all P (singleton x) ↔ P x :=
⟨λ h, h.2.1, λ h, ⟨⟨⟩, h, ⟨⟩⟩⟩

theorem any_singleton {P : α → Prop} {x : α} : any P (singleton x) ↔ P x :=
⟨by rintro (⟨⟨⟩⟩ | h | ⟨⟨⟩⟩); exact h, λ h, or.inr (or.inl h)⟩

theorem all_dual {P : α → Prop} : ∀ {t : ordnode α},
  all P (dual t) ↔ all P t
| nil := iff.rfl
| (node s l x r) :=
  ⟨λ ⟨hr, hx, hl⟩, ⟨all_dual.1 hl, hx, all_dual.1 hr⟩,
   λ ⟨hl, hx, hr⟩, ⟨all_dual.2 hr, hx, all_dual.2 hl⟩⟩

theorem all_iff_forall {P : α → Prop} : ∀ {t}, all P t ↔ ∀ x, emem x t → P x
| nil := (iff_true_intro $ by rintro _ ⟨⟩).symm
| (node _ l x r) :=
  by simp [all, emem, all_iff_forall, any, or_imp_distrib, forall_and_distrib]

theorem any_iff_exists {P : α → Prop} : ∀ {t}, any P t ↔ ∃ x, emem x t ∧ P x
| nil := ⟨by rintro ⟨⟩, by rintro ⟨_, ⟨⟩, _⟩⟩
| (node _ l x r) :=
  by simp [any, emem, any_iff_exists, or_and_distrib_right, exists_or_distrib]

theorem emem_iff_all {x : α} {t} : emem x t ↔ ∀ P, all P t → P x :=
⟨λ h P al, all_iff_forall.1 al _ h,
 λ H, H _ $ all_iff_forall.2 $ λ _, id⟩

theorem all_node' {P l x r} :
  @all α P (node' l x r) ↔ all P l ∧ P x ∧ all P r := iff.rfl

theorem all_node3_l {P l x m y r} :
  @all α P (node3_l l x m y r) ↔ all P l ∧ P x ∧ all P m ∧ P y ∧ all P r :=
by simp [node3_l, all_node', and_assoc]

theorem all_node3_r {P l x m y r} :
  @all α P (node3_r l x m y r) ↔ all P l ∧ P x ∧ all P m ∧ P y ∧ all P r := iff.rfl

theorem all_node4_l {P l x m y r} :
  @all α P (node4_l l x m y r) ↔ all P l ∧ P x ∧ all P m ∧ P y ∧ all P r :=
by cases m; simp [node4_l, all_node', all, all_node3_l, and_assoc]

theorem all_node4_r {P l x m y r} :
  @all α P (node4_r l x m y r) ↔ all P l ∧ P x ∧ all P m ∧ P y ∧ all P r :=
by cases m; simp [node4_r, all_node', all, all_node3_r, and_assoc]

theorem all_rotate_l {P l x r} :
  @all α P (rotate_l l x r) ↔ all P l ∧ P x ∧ all P r :=
by cases r; simp [rotate_l, all_node'];
   split_ifs; simp [all_node3_l, all_node4_l, all]

theorem all_rotate_r {P l x r} :
  @all α P (rotate_r l x r) ↔ all P l ∧ P x ∧ all P r :=
by rw [← all_dual, dual_rotate_r, all_rotate_l];
   simp [all_dual, and_comm, and.left_comm]

theorem all_balance' {P l x r} :
  @all α P (balance' l x r) ↔ all P l ∧ P x ∧ all P r :=
by rw balance'; split_ifs; simp [all_node', all_rotate_l, all_rotate_r]

/-! ### `to_list` -/

theorem foldr_cons_eq_to_list : ∀ (t : ordnode α) (r : list α),
  t.foldr list.cons r = to_list t ++ r
| nil r := rfl
| (node _ l x r) r' := by rw [foldr, foldr_cons_eq_to_list, foldr_cons_eq_to_list,
  ← list.cons_append, ← list.append_assoc, ← foldr_cons_eq_to_list]; refl

@[simp] theorem to_list_nil : to_list (@nil α) = [] := rfl

@[simp] theorem to_list_node (s l x r) : to_list (@node α s l x r) = to_list l ++ x :: to_list r :=
by rw [to_list, foldr, foldr_cons_eq_to_list]; refl

theorem emem_iff_mem_to_list {x : α} {t} : emem x t ↔ x ∈ to_list t :=
by unfold emem; induction t; simp [any, *, or_assoc]

theorem length_to_list {t : ordnode α} (h : sized t) : (to_list t).length = t.size :=
by rw [length_to_list', size_eq_real_size h]

theorem equiv_iff {t₁ t₂ : ordnode α} (h₁ : sized t₁) (h₂ : sized t₂) :
  equiv t₁ t₂ ↔ to_list t₁ = to_list t₂ :=
and_iff_right_of_imp $ λ h, by rw [← length_to_list h₁, h, length_to_list h₂]

/-! ### `mem` -/

theorem pos_size_of_mem [has_le α] [@decidable_rel α (≤)]
  {x : α} {t : ordnode α} (h : sized t) (h_mem : x ∈ t) : 0 < size t :=
by { cases t, { contradiction }, { simp [h.1] } }

/-! ### `(find/erase/split)_(min/max)` -/

theorem find_min'_dual : ∀ t (x : α), find_min' (dual t) x = find_max' x t
| nil x := rfl
| (node _ l x r) _ := find_min'_dual r x

theorem find_max'_dual (t) (x : α) : find_max' x (dual t) = find_min' t x :=
by rw [← find_min'_dual, dual_dual]

theorem find_min_dual : ∀ t : ordnode α, find_min (dual t) = find_max t
| nil := rfl
| (node _ l x r) := congr_arg some $ find_min'_dual _ _

theorem find_max_dual (t : ordnode α) : find_max (dual t) = find_min t :=
by rw [← find_min_dual, dual_dual]

theorem dual_erase_min : ∀ t : ordnode α, dual (erase_min t) = erase_max (dual t)
| nil := rfl
| (node _ nil x r) := rfl
| (node _ l@(node _ _ _ _) x r) :=
  by rw [erase_min, dual_balance_r, dual_erase_min, dual, dual, dual, erase_max]

theorem dual_erase_max (t : ordnode α) : dual (erase_max t) = erase_min (dual t) :=
by rw [← dual_dual (erase_min _), dual_erase_min, dual_dual]

theorem split_min_eq : ∀ s l (x : α) r,
  split_min' l x r = (find_min' l x, erase_min (node s l x r))
| _ nil x r := rfl
| _ (node ls ll lx lr) x r :=
  by rw [split_min', split_min_eq, split_min', find_min', erase_min]

theorem split_max_eq : ∀ s l (x : α) r,
  split_max' l x r = (erase_max (node s l x r), find_max' x r)
| _ l x nil := rfl
| _ l x (node ls ll lx lr) :=
  by rw [split_max', split_max_eq, split_max', find_max', erase_max]

@[elab_as_eliminator]
theorem find_min'_all {P : α → Prop} : ∀ t (x : α), all P t → P x → P (find_min' t x)
| nil x h hx := hx
| (node _ ll lx lr) x ⟨h₁, h₂, h₃⟩ hx := find_min'_all _ _ h₁ h₂

@[elab_as_eliminator]
theorem find_max'_all {P : α → Prop} : ∀ (x : α) t, P x → all P t → P (find_max' x t)
| x nil hx h := hx
| x (node _ ll lx lr) hx ⟨h₁, h₂, h₃⟩ := find_max'_all _ _ h₂ h₃

/-! ### `glue` -/

/-! ### `merge` -/

@[simp] theorem merge_nil_left (t : ordnode α) : merge t nil = t := by cases t; refl

@[simp] theorem merge_nil_right (t : ordnode α) : merge nil t = t := rfl

@[simp] theorem merge_node {ls ll lx lr rs rl rx rr} :
  merge (@node α ls ll lx lr) (node rs rl rx rr) =
  if delta * ls < rs then
    balance_l (merge (node ls ll lx lr) rl) rx rr
  else if delta * rs < ls then
    balance_r ll lx (merge lr (node rs rl rx rr))
  else glue (node ls ll lx lr) (node rs rl rx rr) := rfl

/-! ### `insert` -/

theorem dual_insert [preorder α] [is_total α (≤)] [@decidable_rel α (≤)] (x : α) :
  ∀ t : ordnode α, dual (ordnode.insert x t) = @ordnode.insert (order_dual α) _ _ x (dual t)
| nil := rfl
| (node _ l y r) := begin
  rw [ordnode.insert, dual, ordnode.insert, order_dual.cmp_le_flip, ← cmp_le_swap x y],
  cases cmp_le x y;
  simp [ordering.swap, ordnode.insert, dual_balance_l, dual_balance_r, dual_insert]
end

/-! ### `balance` properties -/

theorem balance_eq_balance' {l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r) :
  @balance α l x r = balance' l x r :=
begin
  cases l with ls ll lx lr,
  { cases r with rs rl rx rr,
    { refl },
    { rw sr.eq_node' at hr ⊢,
      cases rl with rls rll rlx rlr; cases rr with rrs rrl rrx rrr;
      dsimp [balance, balance'],
      { refl },
      { have : size rrl = 0 ∧ size rrr = 0,
        { have := balanced_sz_zero.1 hr.1.symm,
          rwa [size, sr.2.2.1, nat.succ_le_succ_iff,
            nat.le_zero_iff, add_eq_zero_iff] at this },
        cases sr.2.2.2.1.size_eq_zero.1 this.1,
        cases sr.2.2.2.2.size_eq_zero.1 this.2,
        have : rrs = 1 := sr.2.2.1, subst rrs,
        rw [if_neg, if_pos, rotate_l, if_pos], {refl},
        all_goals {exact dec_trivial} },
      { have : size rll = 0 ∧ size rlr = 0,
        { have := balanced_sz_zero.1 hr.1,
          rwa [size, sr.2.1.1, nat.succ_le_succ_iff,
            nat.le_zero_iff, add_eq_zero_iff] at this },
        cases sr.2.1.2.1.size_eq_zero.1 this.1,
        cases sr.2.1.2.2.size_eq_zero.1 this.2,
        have : rls = 1 := sr.2.1.1, subst rls,
        rw [if_neg, if_pos, rotate_l, if_neg], {refl},
        all_goals {exact dec_trivial} },
      { symmetry, rw [zero_add, if_neg, if_pos, rotate_l],
        { split_ifs,
          { simp [node3_l, node', add_comm, add_left_comm] },
          { simp [node4_l, node', sr.2.1.1, add_comm, add_left_comm] } },
        { exact dec_trivial },
        { exact not_le_of_gt (nat.succ_lt_succ
            (add_pos sr.2.1.pos sr.2.2.pos)) } } } },
  { cases r with rs rl rx rr,
    { rw sl.eq_node' at hl ⊢,
      cases ll with lls lll llx llr; cases lr with lrs lrl lrx lrr;
      dsimp [balance, balance'],
      { refl },
      { have : size lrl = 0 ∧ size lrr = 0,
        { have := balanced_sz_zero.1 hl.1.symm,
          rwa [size, sl.2.2.1, nat.succ_le_succ_iff,
            nat.le_zero_iff, add_eq_zero_iff] at this },
        cases sl.2.2.2.1.size_eq_zero.1 this.1,
        cases sl.2.2.2.2.size_eq_zero.1 this.2,
        have : lrs = 1 := sl.2.2.1, subst lrs,
        rw [if_neg, if_neg, if_pos, rotate_r, if_neg], {refl},
        all_goals {exact dec_trivial} },
      { have : size lll = 0 ∧ size llr = 0,
        { have := balanced_sz_zero.1 hl.1,
          rwa [size, sl.2.1.1, nat.succ_le_succ_iff,
            nat.le_zero_iff, add_eq_zero_iff] at this },
        cases sl.2.1.2.1.size_eq_zero.1 this.1,
        cases sl.2.1.2.2.size_eq_zero.1 this.2,
        have : lls = 1 := sl.2.1.1, subst lls,
        rw [if_neg, if_neg, if_pos, rotate_r, if_pos], {refl},
        all_goals {exact dec_trivial} },
      { symmetry, rw [if_neg, if_neg, if_pos, rotate_r],
        { split_ifs,
          { simp [node3_r, node', add_comm, add_left_comm] },
          { simp [node4_r, node', sl.2.2.1, add_comm, add_left_comm] } },
        { exact dec_trivial },
        { exact dec_trivial },
        { exact not_le_of_gt (nat.succ_lt_succ
            (add_pos sl.2.1.pos sl.2.2.pos)) } } },
    { simp [balance, balance'],
      symmetry, rw [if_neg],
      { split_ifs,
        { have rd : delta ≤ size rl + size rr,
          { have := lt_of_le_of_lt (nat.mul_le_mul_left _ sl.pos) h,
            rwa [sr.1, nat.lt_succ_iff] at this },
          cases rl with rls rll rlx rlr,
          { rw [size, zero_add] at rd,
            exact absurd (le_trans rd (balanced_sz_zero.1 hr.1.symm)) dec_trivial },
          cases rr with rrs rrl rrx rrr,
          { exact absurd (le_trans rd (balanced_sz_zero.1 hr.1)) dec_trivial },
          dsimp [rotate_l], split_ifs,
          { simp [node3_l, node', sr.1, add_comm, add_left_comm] },
          { simp [node4_l, node', sr.1, sr.2.1.1, add_comm, add_left_comm] } },
        { have ld : delta ≤ size ll + size lr,
          { have := lt_of_le_of_lt (nat.mul_le_mul_left _ sr.pos) h_1,
            rwa [sl.1, nat.lt_succ_iff] at this },
          cases ll with lls lll llx llr,
          { rw [size, zero_add] at ld,
            exact absurd (le_trans ld (balanced_sz_zero.1 hl.1.symm)) dec_trivial },
          cases lr with lrs lrl lrx lrr,
          { exact absurd (le_trans ld (balanced_sz_zero.1 hl.1)) dec_trivial },
          dsimp [rotate_r], split_ifs,
          { simp [node3_r, node', sl.1, add_comm, add_left_comm] },
          { simp [node4_r, node', sl.1, sl.2.2.1, add_comm, add_left_comm] } },
        { simp [node'] } },
      { exact not_le_of_gt (add_le_add sl.pos sr.pos : 2 ≤ ls + rs) } } }
end

theorem balance_l_eq_balance {l x r}
  (sl : sized l) (sr : sized r)
  (H1 : size l = 0 → size r ≤ 1)
  (H2 : 1 ≤ size l → 1 ≤ size r → size r ≤ delta * size l) :
  @balance_l α l x r = balance l x r :=
begin
  cases r with rs rl rx rr,
  { refl },
  { cases l with ls ll lx lr,
    { have : size rl = 0 ∧ size rr = 0,
      { have := H1 rfl,
        rwa [size, sr.1, nat.succ_le_succ_iff,
          nat.le_zero_iff, add_eq_zero_iff] at this },
      cases sr.2.1.size_eq_zero.1 this.1,
      cases sr.2.2.size_eq_zero.1 this.2,
      rw sr.eq_node', refl },
    { replace H2 : ¬ rs > delta * ls := not_lt_of_le (H2 sl.pos sr.pos),
      simp [balance_l, balance, H2]; split_ifs; simp [add_comm] } }
end

/-- `raised n m` means `m` is either equal or one up from `n`. -/
def raised (n m : ℕ) : Prop := m = n ∨ m = n + 1

theorem raised_iff {n m} : raised n m ↔ n ≤ m ∧ m ≤ n + 1 :=
begin
  split, rintro (rfl | rfl),
  { exact ⟨le_refl _, nat.le_succ _⟩ },
  { exact ⟨nat.le_succ _, le_refl _⟩ },
  { rintro ⟨h₁, h₂⟩,
    rcases eq_or_lt_of_le h₁ with rfl | h₁,
    { exact or.inl rfl },
    { exact or.inr (le_antisymm h₂ h₁) } }
end

theorem raised.dist_le {n m} (H : raised n m) : nat.dist n m ≤ 1 :=
by cases raised_iff.1 H with H1 H2;
  rwa [nat.dist_eq_sub_of_le H1, tsub_le_iff_left]

theorem raised.dist_le' {n m} (H : raised n m) : nat.dist m n ≤ 1 :=
by rw nat.dist_comm; exact H.dist_le

theorem raised.add_left (k) {n m} (H : raised n m) : raised (k + n) (k + m) :=
begin
  rcases H with rfl | rfl,
  { exact or.inl rfl },
  { exact or.inr rfl }
end

theorem raised.add_right (k) {n m} (H : raised n m) : raised (n + k) (m + k) :=
by rw [add_comm, add_comm m]; exact H.add_left _

theorem raised.right {l x₁ x₂ r₁ r₂} (H : raised (size r₁) (size r₂)) :
  raised (size (@node' α l x₁ r₁)) (size (@node' α l x₂ r₂)) :=
begin
  dsimp [node', size], generalize_hyp : size r₂ = m at H ⊢,
  rcases H with rfl | rfl,
  { exact or.inl rfl },
  { exact or.inr rfl }
end

theorem balance_l_eq_balance' {l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised l' (size l) ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised (size r) r' ∧ balanced_sz (size l) r')) :
  @balance_l α l x r = balance' l x r :=
begin
  rw [← balance_eq_balance' hl hr sl sr, balance_l_eq_balance sl sr],
  { intro l0, rw l0 at H,
    rcases H with ⟨_, ⟨⟨⟩⟩|⟨⟨⟩⟩, H⟩ | ⟨r', e, H⟩,
    { exact balanced_sz_zero.1 H.symm },
    exact le_trans (raised_iff.1 e).1 (balanced_sz_zero.1 H.symm) },
  { intros l1 r1,
    rcases H with ⟨l', e, H | ⟨H₁, H₂⟩⟩ | ⟨r', e, H | ⟨H₁, H₂⟩⟩,
    { exact le_trans (le_trans (nat.le_add_left _ _) H)
        (mul_pos dec_trivial l1 : (0:ℕ)<_) },
    { exact le_trans H₂ (nat.mul_le_mul_left _ (raised_iff.1 e).1) },
    { cases raised_iff.1 e, unfold delta, linarith },
    { exact le_trans (raised_iff.1 e).1 H₂ } }
end

theorem balance_sz_dual {l r}
  (H : (∃ l', raised (@size α l) l' ∧ balanced_sz l' (@size α r)) ∨
    ∃ r', raised r' (size r) ∧ balanced_sz (size l) r') :
  (∃ l', raised l' (size (dual r)) ∧ balanced_sz l' (size (dual l))) ∨
    ∃ r', raised (size (dual l)) r' ∧ balanced_sz (size (dual r)) r' :=
begin
  rw [size_dual, size_dual],
  exact H.symm.imp
    (Exists.imp $ λ _, and.imp_right balanced_sz.symm)
    (Exists.imp $ λ _, and.imp_right balanced_sz.symm)
end

theorem size_balance_l {l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised l' (size l) ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised (size r) r' ∧ balanced_sz (size l) r')) :
  size (@balance_l α l x r) = size l + size r + 1 :=
by rw [balance_l_eq_balance' hl hr sl sr H, size_balance' sl sr]

theorem all_balance_l {P l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised l' (size l) ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised (size r) r' ∧ balanced_sz (size l) r')) :
  all P (@balance_l α l x r) ↔ all P l ∧ P x ∧ all P r :=
by rw [balance_l_eq_balance' hl hr sl sr H, all_balance']

theorem balance_r_eq_balance' {l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised (size l) l' ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised r' (size r) ∧ balanced_sz (size l) r')) :
  @balance_r α l x r = balance' l x r :=
by rw [← dual_dual (balance_r l x r), dual_balance_r,
  balance_l_eq_balance' hr.dual hl.dual sr.dual sl.dual (balance_sz_dual H),
  ← dual_balance', dual_dual]

theorem size_balance_r {l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised (size l) l' ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised r' (size r) ∧ balanced_sz (size l) r')) :
  size (@balance_r α l x r) = size l + size r + 1 :=
by rw [balance_r_eq_balance' hl hr sl sr H, size_balance' sl sr]

theorem all_balance_r {P l x r}
  (hl : balanced l) (hr : balanced r)
  (sl : sized l) (sr : sized r)
  (H : (∃ l', raised (size l) l' ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised r' (size r) ∧ balanced_sz (size l) r')) :
  all P (@balance_r α l x r) ↔ all P l ∧ P x ∧ all P r :=
by rw [balance_r_eq_balance' hl hr sl sr H, all_balance']

/-! ### `bounded` -/

section
variable [preorder α]

/-- `bounded t lo hi` says that every element `x ∈ t` is in the range `lo < x < hi`, and also this
property holds recursively in subtrees, making the full tree a BST. The bounds can be set to
`lo = ⊥` and `hi = ⊤` if we care only about the internal ordering constraints. -/
def bounded : ordnode α → with_bot α → with_top α → Prop
| nil (some a) (some b) := a < b
| nil _ _ := true
| (node _ l x r) o₁ o₂ := bounded l o₁ ↑x ∧ bounded r ↑x o₂

theorem bounded.dual : ∀ {t : ordnode α} {o₁ o₂} (h : bounded t o₁ o₂),
  @bounded (order_dual α) _ (dual t) o₂ o₁
| nil o₁ o₂ h := by cases o₁; cases o₂; try {trivial}; exact h
| (node s l x r) _ _ ⟨ol, or⟩ := ⟨or.dual, ol.dual⟩

theorem bounded.dual_iff {t : ordnode α} {o₁ o₂} : bounded t o₁ o₂ ↔
  @bounded (order_dual α) _ (dual t) o₂ o₁ :=
⟨bounded.dual, λ h, by have := bounded.dual h;
  rwa [dual_dual, order_dual.preorder.dual_dual] at this⟩

theorem bounded.weak_left : ∀ {t : ordnode α} {o₁ o₂}, bounded t o₁ o₂ → bounded t ⊥ o₂
| nil o₁ o₂ h := by cases o₂; try {trivial}; exact h
| (node s l x r) _ _ ⟨ol, or⟩ := ⟨ol.weak_left, or⟩

theorem bounded.weak_right : ∀ {t : ordnode α} {o₁ o₂}, bounded t o₁ o₂ → bounded t o₁ ⊤
| nil o₁ o₂ h := by cases o₁; try {trivial}; exact h
| (node s l x r) _ _ ⟨ol, or⟩ := ⟨ol, or.weak_right⟩

theorem bounded.weak {t : ordnode α} {o₁ o₂} (h : bounded t o₁ o₂) : bounded t ⊥ ⊤ :=
h.weak_left.weak_right

theorem bounded.mono_left {x y : α} (xy : x ≤ y) :
  ∀ {t : ordnode α} {o}, bounded t ↑y o → bounded t ↑x o
| nil none h := ⟨⟩
| nil (some z) h := lt_of_le_of_lt xy h
| (node s l z r) o ⟨ol, or⟩ := ⟨ol.mono_left, or⟩

theorem bounded.mono_right {x y : α} (xy : x ≤ y) :
  ∀ {t : ordnode α} {o}, bounded t o ↑x → bounded t o ↑y
| nil none h := ⟨⟩
| nil (some z) h := lt_of_lt_of_le h xy
| (node s l z r) o ⟨ol, or⟩ := ⟨ol, or.mono_right⟩

theorem bounded.to_lt : ∀ {t : ordnode α} {x y : α}, bounded t x y → x < y
| nil x y h := h
| (node _ l y r) x z ⟨h₁, h₂⟩ := lt_trans h₁.to_lt h₂.to_lt

theorem bounded.to_nil {t : ordnode α} : ∀ {o₁ o₂}, bounded t o₁ o₂ → bounded nil o₁ o₂
| none _ h := ⟨⟩
| (some _) none h := ⟨⟩
| (some x) (some y) h := h.to_lt

theorem bounded.trans_left {t₁ t₂ : ordnode α} {x : α} :
  ∀ {o₁ o₂}, bounded t₁ o₁ ↑x → bounded t₂ ↑x o₂ → bounded t₂ o₁ o₂
| none o₂ h₁ h₂ := h₂.weak_left
| (some y) o₂ h₁ h₂ := h₂.mono_left (le_of_lt h₁.to_lt)

theorem bounded.trans_right {t₁ t₂ : ordnode α} {x : α} :
  ∀ {o₁ o₂}, bounded t₁ o₁ ↑x → bounded t₂ ↑x o₂ → bounded t₁ o₁ o₂
| o₁ none h₁ h₂ := h₁.weak_right
| o₁ (some y) h₁ h₂ := h₁.mono_right (le_of_lt h₂.to_lt)

theorem bounded.mem_lt : ∀ {t o} {x : α}, bounded t o ↑x → all (< x) t
| nil o x _ := ⟨⟩
| (node _ l y r) o x ⟨h₁, h₂⟩ :=
  ⟨h₁.mem_lt.imp (λ z h, lt_trans h h₂.to_lt), h₂.to_lt, h₂.mem_lt⟩

theorem bounded.mem_gt : ∀ {t o} {x : α}, bounded t ↑x o → all (> x) t
| nil o x _ := ⟨⟩
| (node _ l y r) o x ⟨h₁, h₂⟩ :=
  ⟨h₁.mem_gt, h₁.to_lt, h₂.mem_gt.imp (λ z, lt_trans h₁.to_lt)⟩

theorem bounded.of_lt : ∀ {t o₁ o₂} {x : α},
  bounded t o₁ o₂ → bounded nil o₁ ↑x → all (< x) t → bounded t o₁ ↑x
| nil o₁ o₂ x _ hn _ := hn
| (node _ l y r) o₁ o₂ x ⟨h₁, h₂⟩ hn ⟨al₁, al₂, al₃⟩ := ⟨h₁, h₂.of_lt al₂ al₃⟩

theorem bounded.of_gt : ∀ {t o₁ o₂} {x : α},
  bounded t o₁ o₂ → bounded nil ↑x o₂ → all (> x) t → bounded t ↑x o₂
| nil o₁ o₂ x _ hn _ := hn
| (node _ l y r) o₁ o₂ x ⟨h₁, h₂⟩ hn ⟨al₁, al₂, al₃⟩ := ⟨h₁.of_gt al₂ al₁, h₂⟩

theorem bounded.to_sep {t₁ t₂ o₁ o₂} {x : α}
  (h₁ : bounded t₁ o₁ ↑x) (h₂ : bounded t₂ ↑x o₂) : t₁.all (λ y, t₂.all (λ z : α, y < z)) :=
h₁.mem_lt.imp $ λ y yx, h₂.mem_gt.imp $ λ z xz, lt_trans yx xz

end

/-! ### `valid` -/

section
variable [preorder α]

/-- The validity predicate for an `ordnode` subtree. This asserts that the `size` fields are
correct, the tree is balanced, and the elements of the tree are organized according to the
ordering. This version of `valid` also puts all elements in the tree in the interval `(lo, hi)`. -/
structure valid' (lo : with_bot α) (t : ordnode α) (hi : with_top α) : Prop :=
(ord : t.bounded lo hi)
(sz : t.sized)
(bal : t.balanced)

/-- The validity predicate for an `ordnode` subtree. This asserts that the `size` fields are
correct, the tree is balanced, and the elements of the tree are organized according to the
ordering. -/
def valid (t : ordnode α) : Prop := valid' ⊥ t ⊤

theorem valid'.mono_left {x y : α} (xy : x ≤ y)
  {t : ordnode α} {o} (h : valid' ↑y t o) : valid' ↑x t o :=
⟨h.1.mono_left xy, h.2, h.3⟩

theorem valid'.mono_right {x y : α} (xy : x ≤ y)
  {t : ordnode α} {o} (h : valid' o t ↑x) : valid' o t ↑y :=
⟨h.1.mono_right xy, h.2, h.3⟩

theorem valid'.trans_left {t₁ t₂ : ordnode α} {x : α} {o₁ o₂}
  (h : bounded t₁ o₁ ↑x) (H : valid' ↑x t₂ o₂) : valid' o₁ t₂ o₂ :=
⟨h.trans_left H.1, H.2, H.3⟩

theorem valid'.trans_right {t₁ t₂ : ordnode α} {x : α} {o₁ o₂}
  (H : valid' o₁ t₁ ↑x) (h : bounded t₂ ↑x o₂) : valid' o₁ t₁ o₂ :=
⟨H.1.trans_right h, H.2, H.3⟩

theorem valid'.of_lt {t : ordnode α} {x : α} {o₁ o₂}
  (H : valid' o₁ t o₂) (h₁ : bounded nil o₁ ↑x) (h₂ : all (< x) t) : valid' o₁ t ↑x :=
⟨H.1.of_lt h₁ h₂, H.2, H.3⟩

theorem valid'.of_gt {t : ordnode α} {x : α} {o₁ o₂}
  (H : valid' o₁ t o₂) (h₁ : bounded nil ↑x o₂) (h₂ : all (> x) t) : valid' ↑x t o₂ :=
⟨H.1.of_gt h₁ h₂, H.2, H.3⟩

theorem valid'.valid {t o₁ o₂} (h : @valid' α _ o₁ t o₂) : valid t := ⟨h.1.weak, h.2, h.3⟩

theorem valid'_nil {o₁ o₂} (h : bounded nil o₁ o₂) : valid' o₁ (@nil α) o₂ := ⟨h, ⟨⟩, ⟨⟩⟩

theorem valid_nil : valid (@nil α) := valid'_nil ⟨⟩

theorem valid'.node {s l x r o₁ o₂}
  (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : balanced_sz (size l) (size r)) (hs : s = size l + size r + 1) :
  valid' o₁ (@node α s l x r) o₂ :=
⟨⟨hl.1, hr.1⟩, ⟨hs, hl.2, hr.2⟩, ⟨H, hl.3, hr.3⟩⟩

theorem valid'.dual : ∀ {t : ordnode α} {o₁ o₂} (h : valid' o₁ t o₂),
  @valid' (order_dual α) _ o₂ (dual t) o₁
| nil o₁ o₂ h := valid'_nil h.1.dual
| (node s l x r) o₁ o₂ ⟨⟨ol, or⟩, ⟨rfl, sl, sr⟩, ⟨b, bl, br⟩⟩ :=
  let ⟨ol', sl', bl'⟩ := valid'.dual ⟨ol, sl, bl⟩,
      ⟨or', sr', br'⟩ := valid'.dual ⟨or, sr, br⟩ in
  ⟨⟨or', ol'⟩,
   ⟨by simp [size_dual, add_comm], sr', sl'⟩,
   ⟨by rw [size_dual, size_dual]; exact b.symm, br', bl'⟩⟩

theorem valid'.dual_iff {t : ordnode α} {o₁ o₂} : valid' o₁ t o₂ ↔
  @valid' (order_dual α) _ o₂ (dual t) o₁ :=
⟨valid'.dual, λ h, by have := valid'.dual h;
  rwa [dual_dual, order_dual.preorder.dual_dual] at this⟩

theorem valid.dual {t : ordnode α} : valid t →
  @valid (order_dual α) _ (dual t) := valid'.dual

theorem valid.dual_iff {t : ordnode α} : valid t ↔
  @valid (order_dual α) _ (dual t) := valid'.dual_iff

theorem valid'.left {s l x r o₁ o₂} (H : valid' o₁ (@node α s l x r) o₂) : valid' o₁ l x :=
⟨H.1.1, H.2.2.1, H.3.2.1⟩

theorem valid'.right {s l x r o₁ o₂} (H : valid' o₁ (@node α s l x r) o₂) : valid' ↑x r o₂ :=
⟨H.1.2, H.2.2.2, H.3.2.2⟩

theorem valid.left {s l x r} (H : valid (@node α s l x r)) : valid l := H.left.valid

theorem valid.right {s l x r} (H : valid (@node α s l x r)) : valid r := H.right.valid

theorem valid.size_eq {s l x r} (H : valid (@node α s l x r)) :
  size (@node α s l x r) = size l + size r + 1 := H.2.1

theorem valid'.node' {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : balanced_sz (size l) (size r)) : valid' o₁ (@node' α l x r) o₂ :=
hl.node hr H rfl

theorem valid'_singleton {x : α} {o₁ o₂}
  (h₁ : bounded nil o₁ ↑x) (h₂ : bounded nil ↑x o₂) : valid' o₁ (singleton x : ordnode α) o₂ :=
(valid'_nil h₁).node (valid'_nil h₂) (or.inl zero_le_one) rfl

theorem valid_singleton {x : α} : valid (singleton x : ordnode α) := valid'_singleton ⟨⟩ ⟨⟩

theorem valid'.node3_l {l x m y r o₁ o₂}
  (hl : valid' o₁ l ↑x) (hm : valid' ↑x m ↑y) (hr : valid' ↑y r o₂)
  (H1 : balanced_sz (size l) (size m))
  (H2 : balanced_sz (size l + size m + 1) (size r)) :
  valid' o₁ (@node3_l α l x m y r) o₂ :=
(hl.node' hm H1).node' hr H2

theorem valid'.node3_r {l x m y r o₁ o₂}
  (hl : valid' o₁ l ↑x) (hm : valid' ↑x m ↑y) (hr : valid' ↑y r o₂)
  (H1 : balanced_sz (size l) (size m + size r + 1))
  (H2 : balanced_sz (size m) (size r)) :
  valid' o₁ (@node3_r α l x m y r) o₂ :=
hl.node' (hm.node' hr H2) H1

theorem valid'.node4_l_lemma₁ {a b c d : ℕ}
  (lr₂ : 3 * (b + c + 1 + d) ≤ 16 * a + 9)
  (mr₂ : b + c + 1 ≤ 3 * d)
  (mm₁ : b ≤ 3 * c) : b < 3 * a + 1 := by linarith

theorem valid'.node4_l_lemma₂ {b c d : ℕ} (mr₂ : b + c + 1 ≤ 3 * d) : c ≤ 3 * d := by linarith

theorem valid'.node4_l_lemma₃ {b c d : ℕ}
  (mr₁ : 2 * d ≤ b + c + 1)
  (mm₁ : b ≤ 3 * c) : d ≤ 3 * c := by linarith

theorem valid'.node4_l_lemma₄ {a b c d : ℕ}
  (lr₁ : 3 * a ≤ b + c + 1 + d)
  (mr₂ : b + c + 1 ≤ 3 * d)
  (mm₁ : b ≤ 3 * c) : a + b + 1 ≤ 3 * (c + d + 1) := by linarith

theorem valid'.node4_l_lemma₅ {a b c d : ℕ}
  (lr₂ : 3 * (b + c + 1 + d) ≤ 16 * a + 9)
  (mr₁ : 2 * d ≤ b + c + 1)
  (mm₂ : c ≤ 3 * b) : c + d + 1 ≤ 3 * (a + b + 1) := by linarith

theorem valid'.node4_l {l x m y r o₁ o₂}
  (hl : valid' o₁ l ↑x) (hm : valid' ↑x m ↑y) (hr : valid' ↑y r o₂)
  (Hm : 0 < size m)
  (H : (size l = 0 ∧ size m = 1 ∧ size r ≤ 1) ∨
    (0 < size l ∧ ratio * size r ≤ size m ∧
      delta * size l ≤ size m + size r ∧
      3 * (size m + size r) ≤ 16 * size l + 9 ∧
      size m ≤ delta * size r)) :
  valid' o₁ (@node4_l α l x m y r) o₂ :=
begin
  cases m with s ml z mr, {cases Hm},
  suffices : balanced_sz (size l) (size ml) ∧
    balanced_sz (size mr) (size r) ∧
    balanced_sz (size l + size ml + 1) (size mr + size r + 1),
  from (valid'.node' (hl.node' hm.left this.1) (hm.right.node' hr this.2.1) this.2.2),
  rcases H with ⟨l0, m1, r0⟩ | ⟨l0, mr₁, lr₁, lr₂, mr₂⟩,
  { rw [hm.2.size_eq, nat.succ_inj', add_eq_zero_iff] at m1,
    rw [l0, m1.1, m1.2], rcases size r with _|_|_; exact dec_trivial },
  { cases nat.eq_zero_or_pos (size r) with r0 r0,
    { rw r0 at mr₂, cases not_le_of_lt Hm mr₂ },
    rw [hm.2.size_eq] at lr₁ lr₂ mr₁ mr₂,
    by_cases mm : size ml + size mr ≤ 1,
    { have r1 := le_antisymm ((mul_le_mul_left dec_trivial).1
        (le_trans mr₁ (nat.succ_le_succ mm) : _ ≤ ratio * 1)) r0,
      rw [r1, add_assoc] at lr₁,
      have l1 := le_antisymm ((mul_le_mul_left dec_trivial).1
        (le_trans lr₁ (add_le_add_right mm 2) : _ ≤ delta * 1)) l0,
      rw [l1, r1],
      cases size ml; cases size mr,
      { exact dec_trivial },
      { rw zero_add at mm, rcases mm with _|⟨_,⟨⟩⟩,
        exact dec_trivial },
      { rcases mm with _|⟨_,⟨⟩⟩, exact dec_trivial },
      { rw nat.succ_add at mm, rcases mm with _|⟨_,⟨⟩⟩ } },
    rcases hm.3.1.resolve_left mm with ⟨mm₁, mm₂⟩,
    cases nat.eq_zero_or_pos (size ml) with ml0 ml0,
    { rw [ml0, mul_zero, nat.le_zero_iff] at mm₂,
      rw [ml0, mm₂] at mm, cases mm dec_trivial },
    have : 2 * size l ≤ size ml + size mr + 1,
    { have := nat.mul_le_mul_left _ lr₁,
      rw [mul_left_comm, mul_add] at this,
      have := le_trans this (add_le_add_left mr₁ _),
      rw [← nat.succ_mul] at this,
      exact (mul_le_mul_left dec_trivial).1 this },
    refine ⟨or.inr ⟨_, _⟩, or.inr ⟨_, _⟩, or.inr ⟨_, _⟩⟩,
    { refine (mul_le_mul_left dec_trivial).1 (le_trans this _),
      rw [two_mul, nat.succ_le_iff],
      refine add_lt_add_of_lt_of_le _ mm₂,
      simpa using (mul_lt_mul_right ml0).2 (dec_trivial:1<3) },
    { exact nat.le_of_lt_succ (valid'.node4_l_lemma₁ lr₂ mr₂ mm₁) },
    { exact valid'.node4_l_lemma₂ mr₂ },
    { exact valid'.node4_l_lemma₃ mr₁ mm₁ },
    { exact valid'.node4_l_lemma₄ lr₁ mr₂ mm₁ },
    { exact valid'.node4_l_lemma₅ lr₂ mr₁ mm₂ } }
end

theorem valid'.rotate_l_lemma₁ {a b c : ℕ}
  (H2 : 3 * a ≤ b + c) (hb₂ : c ≤ 3 * b) : a ≤ 3 * b := by linarith

theorem valid'.rotate_l_lemma₂ {a b c : ℕ}
  (H3 : 2 * (b + c) ≤ 9 * a + 3) (h : b < 2 * c) : b < 3 * a + 1 := by linarith

theorem valid'.rotate_l_lemma₃ {a b c : ℕ}
  (H2 : 3 * a ≤ b + c) (h : b < 2 * c) : a + b < 3 * c := by linarith

theorem valid'.rotate_l_lemma₄ {a b : ℕ}
  (H3 : 2 * b ≤ 9 * a + 3) : 3 * b ≤ 16 * a + 9 := by linarith

theorem valid'.rotate_l {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H1 : ¬ size l + size r ≤ 1)
  (H2 : delta * size l < size r)
  (H3 : 2 * size r ≤ 9 * size l + 5 ∨ size r ≤ 3) :
  valid' o₁ (@rotate_l α l x r) o₂ :=
begin
  cases r with rs rl rx rr, {cases H2},
  rw [hr.2.size_eq, nat.lt_succ_iff] at H2,
  rw [hr.2.size_eq] at H3,
  replace H3 : 2 * (size rl + size rr) ≤ 9 * size l + 3 ∨ size rl + size rr ≤ 2 :=
    H3.imp (@nat.le_of_add_le_add_right 2 _ _) nat.le_of_succ_le_succ,
  have H3_0 : size l = 0 → size rl + size rr ≤ 2,
  { intro l0, rw l0 at H3,
    exact (or_iff_right_of_imp $ by exact λ h,
      (mul_le_mul_left dec_trivial).1 (le_trans h dec_trivial)).1 H3 },
  have H3p : size l > 0 → 2 * (size rl + size rr) ≤ 9 * size l + 3 :=
    λ l0 : 1 ≤ size l, (or_iff_left_of_imp $ by intro; linarith).1 H3,
  have ablem : ∀ {a b : ℕ}, 1 ≤ a → a + b ≤ 2 → b ≤ 1, {intros, linarith},
  have hlp : size l > 0 → ¬ size rl + size rr ≤ 1 := λ l0 hb, absurd
    (le_trans (le_trans (nat.mul_le_mul_left _ l0) H2) hb) dec_trivial,
  rw rotate_l, split_ifs,
  { have rr0 : size rr > 0 := (mul_lt_mul_left dec_trivial).1
      (lt_of_le_of_lt (nat.zero_le _) h : ratio * 0 < _),
    suffices : balanced_sz (size l) (size rl) ∧ balanced_sz (size l + size rl + 1) (size rr),
    { exact hl.node3_l hr.left hr.right this.1 this.2 },
    cases nat.eq_zero_or_pos (size l) with l0 l0,
    { rw l0, replace H3 := H3_0 l0,
      have := hr.3.1,
      cases nat.eq_zero_or_pos (size rl) with rl0 rl0,
      { rw rl0 at this ⊢,
        rw le_antisymm (balanced_sz_zero.1 this.symm) rr0,
        exact dec_trivial },
      have rr1 : size rr = 1 := le_antisymm (ablem rl0 H3) rr0,
      rw add_comm at H3,
      rw [rr1, show size rl = 1, from le_antisymm (ablem rr0 H3) rl0],
      exact dec_trivial },
    replace H3 := H3p l0,
    rcases hr.3.1.resolve_left (hlp l0) with ⟨hb₁, hb₂⟩,
    cases nat.eq_zero_or_pos (size rl) with rl0 rl0,
    { rw rl0 at hb₂, cases not_le_of_gt rr0 hb₂ },
    refine ⟨or.inr ⟨_, _⟩, or.inr ⟨_, _⟩⟩,
    { exact valid'.rotate_l_lemma₁ H2 hb₂ },
    { exact nat.le_of_lt_succ (valid'.rotate_l_lemma₂ H3 h) },
    { exact valid'.rotate_l_lemma₃ H2 h },
    { exact le_trans hb₂ (nat.mul_le_mul_left _ $
        le_trans (nat.le_add_left _ _) (nat.le_add_right _ _)) } },
  { cases nat.eq_zero_or_pos (size rl) with rl0 rl0,
    { rw [rl0, not_lt, nat.le_zero_iff, nat.mul_eq_zero] at h,
      replace h := h.resolve_left dec_trivial,
      rw [rl0, h, nat.le_zero_iff, nat.mul_eq_zero] at H2,
      rw [hr.2.size_eq, rl0, h, H2.resolve_left dec_trivial] at H1,
      cases H1 dec_trivial },
    refine hl.node4_l hr.left hr.right rl0 _,
    cases nat.eq_zero_or_pos (size l) with l0 l0,
    { replace H3 := H3_0 l0,
      cases nat.eq_zero_or_pos (size rr) with rr0 rr0,
      { have := hr.3.1,
        rw rr0 at this,
        exact or.inl ⟨l0,
          le_antisymm (balanced_sz_zero.1 this) rl0,
          rr0.symm ▸ zero_le_one⟩ },
      exact or.inl ⟨l0,
        le_antisymm (ablem rr0 $ by rwa add_comm) rl0,
        ablem rl0 H3⟩ },
    exact or.inr ⟨l0, not_lt.1 h, H2,
      valid'.rotate_l_lemma₄ (H3p l0),
      (hr.3.1.resolve_left (hlp l0)).1⟩ }
end

theorem valid'.rotate_r {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H1 : ¬ size l + size r ≤ 1)
  (H2 : delta * size r < size l)
  (H3 : 2 * size l ≤ 9 * size r + 5 ∨ size l ≤ 3) :
  valid' o₁ (@rotate_r α l x r) o₂ :=
begin
  refine valid'.dual_iff.2 _,
  rw dual_rotate_r,
  refine hr.dual.rotate_l hl.dual _ _ _,
  { rwa [size_dual, size_dual, add_comm] },
  { rwa [size_dual, size_dual] },
  { rwa [size_dual, size_dual] }
end

theorem valid'.balance'_aux {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H₁ : 2 * @size α r ≤ 9 * size l + 5 ∨ size r ≤ 3)
  (H₂ : 2 * @size α l ≤ 9 * size r + 5 ∨ size l ≤ 3) :
  valid' o₁ (@balance' α l x r) o₂ :=
begin
  rw balance', split_ifs,
  { exact hl.node' hr (or.inl h) },
  { exact hl.rotate_l hr h h_1 H₁ },
  { exact hl.rotate_r hr h h_2 H₂ },
  { exact hl.node' hr (or.inr ⟨not_lt.1 h_2, not_lt.1 h_1⟩) }
end

theorem valid'.balance'_lemma {α l l' r r'}
  (H1 : balanced_sz l' r')
  (H2 : nat.dist (@size α l) l' ≤ 1 ∧ size r = r' ∨
        nat.dist (size r) r' ≤ 1 ∧ size l = l') :
  2 * @size α r ≤ 9 * size l + 5 ∨ size r ≤ 3 :=
begin
  suffices : @size α r ≤ 3 * (size l + 1),
  { cases nat.eq_zero_or_pos (size l) with l0 l0,
    { apply or.inr, rwa l0 at this },
    change 1 ≤ _ at l0, apply or.inl, linarith },
  rcases H2 with ⟨hl, rfl⟩ | ⟨hr, rfl⟩;
  rcases H1 with h | ⟨h₁, h₂⟩,
  { exact le_trans (nat.le_add_left _ _) (le_trans h (nat.le_add_left _ _)) },
  { exact le_trans h₂ (nat.mul_le_mul_left _ $
      le_trans (nat.dist_tri_right _ _) (nat.add_le_add_left hl _)) },
  { exact le_trans (nat.dist_tri_left' _ _)
      (le_trans (add_le_add hr (le_trans (nat.le_add_left _ _) h)) dec_trivial) },
  { rw nat.mul_succ,
    exact le_trans (nat.dist_tri_right' _ _)
      (add_le_add h₂ (le_trans hr dec_trivial)) },
end

theorem valid'.balance' {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : ∃ l' r', balanced_sz l' r' ∧
    (nat.dist (size l) l' ≤ 1 ∧ size r = r' ∨
     nat.dist (size r) r' ≤ 1 ∧ size l = l')) :
  valid' o₁ (@balance' α l x r) o₂ :=
let ⟨l', r', H1, H2⟩ := H in
valid'.balance'_aux hl hr (valid'.balance'_lemma H1 H2) (valid'.balance'_lemma H1.symm H2.symm)

theorem valid'.balance {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : ∃ l' r', balanced_sz l' r' ∧
    (nat.dist (size l) l' ≤ 1 ∧ size r = r' ∨
     nat.dist (size r) r' ≤ 1 ∧ size l = l')) :
  valid' o₁ (@balance α l x r) o₂ :=
by rw balance_eq_balance' hl.3 hr.3 hl.2 hr.2; exact hl.balance' hr H

theorem valid'.balance_l_aux {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H₁ : size l = 0 → size r ≤ 1)
  (H₂ : 1 ≤ size l → 1 ≤ size r → size r ≤ delta * size l)
  (H₃ : 2 * @size α l ≤ 9 * size r + 5 ∨ size l ≤ 3) :
  valid' o₁ (@balance_l α l x r) o₂ :=
begin
  rw [balance_l_eq_balance hl.2 hr.2 H₁ H₂, balance_eq_balance' hl.3 hr.3 hl.2 hr.2],
  refine hl.balance'_aux hr (or.inl _) H₃,
  cases nat.eq_zero_or_pos (size r) with r0 r0,
  { rw r0, exact nat.zero_le _ },
  cases nat.eq_zero_or_pos (size l) with l0 l0,
  { rw l0, exact le_trans (nat.mul_le_mul_left _ (H₁ l0)) dec_trivial },
  replace H₂ : _ ≤ 3 * _ := H₂ l0 r0, linarith
end

theorem valid'.balance_l {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : (∃ l', raised l' (size l) ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised (size r) r' ∧ balanced_sz (size l) r')) :
  valid' o₁ (@balance_l α l x r) o₂ :=
begin
  rw balance_l_eq_balance' hl.3 hr.3 hl.2 hr.2 H,
  refine hl.balance' hr _,
  rcases H with ⟨l', e, H⟩ | ⟨r', e, H⟩,
  { exact ⟨_, _, H, or.inl ⟨e.dist_le', rfl⟩⟩ },
  { exact ⟨_, _, H, or.inr ⟨e.dist_le, rfl⟩⟩ },
end

theorem valid'.balance_r_aux {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H₁ : size r = 0 → size l ≤ 1)
  (H₂ : 1 ≤ size r → 1 ≤ size l → size l ≤ delta * size r)
  (H₃ : 2 * @size α r ≤ 9 * size l + 5 ∨ size r ≤ 3) :
  valid' o₁ (@balance_r α l x r) o₂ :=
begin
  rw [valid'.dual_iff, dual_balance_r],
  have := hr.dual.balance_l_aux hl.dual,
  rw [size_dual, size_dual] at this,
  exact this H₁ H₂ H₃
end

theorem valid'.balance_r {l x r o₁ o₂} (hl : valid' o₁ l ↑x) (hr : valid' ↑x r o₂)
  (H : (∃ l', raised (size l) l' ∧ balanced_sz l' (size r)) ∨
       (∃ r', raised r' (size r) ∧ balanced_sz (size l) r')) :
  valid' o₁ (@balance_r α l x r) o₂ :=
by rw [valid'.dual_iff, dual_balance_r]; exact
hr.dual.balance_l hl.dual (balance_sz_dual H)

theorem valid'.erase_max_aux {s l x r o₁ o₂}
  (H : valid' o₁ (node s l x r) o₂) :
  valid' o₁ (@erase_max α (node' l x r)) ↑(find_max' x r) ∧
  size (node' l x r) = size (erase_max (node' l x r)) + 1 :=
begin
  have := H.2.eq_node', rw this at H, clear this,
  induction r with rs rl rx rr IHrl IHrr generalizing l x o₁,
  { exact ⟨H.left, rfl⟩ },
  have := H.2.2.2.eq_node', rw this at H ⊢,
  rcases IHrr H.right with ⟨h, e⟩,
  refine ⟨valid'.balance_l H.left h (or.inr ⟨_, or.inr e, H.3.1⟩), _⟩,
  rw [erase_max, size_balance_l H.3.2.1 h.3 H.2.2.1 h.2 (or.inr ⟨_, or.inr e, H.3.1⟩)],
  rw [size, e], refl
end

theorem valid'.erase_min_aux {s l x r o₁ o₂}
  (H : valid' o₁ (node s l x r) o₂) :
  valid' ↑(find_min' l x) (@erase_min α (node' l x r)) o₂ ∧
  size (node' l x r) = size (erase_min (node' l x r)) + 1 :=
by have := H.dual.erase_max_aux;
   rwa [← dual_node', size_dual, ← dual_erase_min,
     size_dual, ← valid'.dual_iff, find_max'_dual] at this

theorem erase_min.valid : ∀ {t} (h : @valid α _ t), valid (erase_min t)
| nil _ := valid_nil
| (node _ l x r) h := by rw h.2.eq_node'; exact h.erase_min_aux.1.valid

theorem erase_max.valid {t} (h : @valid α _ t) : valid (erase_max t) :=
by rw [valid.dual_iff, dual_erase_max]; exact erase_min.valid h.dual

theorem valid'.glue_aux {l r o₁ o₂}
  (hl : valid' o₁ l o₂) (hr : valid' o₁ r o₂)
  (sep : l.all (λ x, r.all (λ y, x < y)))
  (bal : balanced_sz (size l) (size r)) :
  valid' o₁ (@glue α l r) o₂ ∧ size (glue l r) = size l + size r :=
begin
  cases l with ls ll lx lr, {exact ⟨hr, (zero_add _).symm⟩ },
  cases r with rs rl rx rr, {exact ⟨hl, rfl⟩ },
  dsimp [glue], split_ifs,
  { rw [split_max_eq, glue],
    cases valid'.erase_max_aux hl with v e,
    suffices H,
    refine ⟨valid'.balance_r v (hr.of_gt _ _) H, _⟩,
    { refine find_max'_all lx lr hl.1.2.to_nil (sep.2.2.imp _),
      exact λ x h, hr.1.2.to_nil.mono_left (le_of_lt h.2.1) },
    { exact @find_max'_all _ (λ a, all (> a) (node rs rl rx rr)) lx lr sep.2.1 sep.2.2 },
    { rw [size_balance_r v.3 hr.3 v.2 hr.2 H, add_right_comm, ← e, hl.2.1], refl },
    { refine or.inl ⟨_, or.inr e, _⟩,
      rwa hl.2.eq_node' at bal } },
  { rw [split_min_eq, glue],
    cases valid'.erase_min_aux hr with v e,
    suffices H,
    refine ⟨valid'.balance_l (hl.of_lt _ _) v H, _⟩,
    { refine @find_min'_all _ (λ a, bounded nil o₁ ↑a) rl rx (sep.2.1.1.imp _) hr.1.1.to_nil,
      exact λ y h, hl.1.1.to_nil.mono_right (le_of_lt h) },
    { exact @find_min'_all _ (λ a, all (< a) (node ls ll lx lr)) rl rx
        (all_iff_forall.2 $ λ x hx, sep.imp $ λ y hy, all_iff_forall.1 hy.1 _ hx)
        (sep.imp $ λ y hy, hy.2.1) },
    { rw [size_balance_l hl.3 v.3 hl.2 v.2 H, add_assoc, ← e, hr.2.1], refl },
    { refine or.inr ⟨_, or.inr e, _⟩,
      rwa hr.2.eq_node' at bal } },
end

theorem valid'.glue {l x r o₁ o₂}
  (hl : valid' o₁ l ↑(x:α)) (hr : valid' ↑x r o₂) :
  balanced_sz (size l) (size r) →
  valid' o₁ (@glue α l r) o₂ ∧ size (@glue α l r) = size l + size r :=
valid'.glue_aux (hl.trans_right hr.1) (hr.trans_left hl.1) (hl.1.to_sep hr.1)

theorem valid'.merge_lemma {a b c : ℕ}
  (h₁ : 3 * a < b + c + 1) (h₂ : b ≤ 3 * c) : 2 * (a + b) ≤ 9 * c + 5 :=
by linarith

theorem valid'.merge_aux₁ {o₁ o₂ ls ll lx lr rs rl rx rr t}
  (hl : valid' o₁ (@node α ls ll lx lr) o₂)
  (hr : valid' o₁ (node rs rl rx rr) o₂)
  (h : delta * ls < rs)
  (v : valid' o₁ t ↑rx)
  (e : size t = ls + size rl) :
  valid' o₁ (balance_l t rx rr) o₂ ∧ size (balance_l t rx rr) = ls + rs :=
begin
  rw hl.2.1 at e,
  rw [hl.2.1, hr.2.1, delta] at h,
  rcases hr.3.1 with H|⟨hr₁, hr₂⟩, {linarith},
  suffices H₂, suffices H₁,
  refine ⟨valid'.balance_l_aux v hr.right H₁ H₂ _, _⟩,
  { rw e, exact or.inl (valid'.merge_lemma h hr₁) },
  { rw [balance_l_eq_balance v.2 hr.2.2.2 H₁ H₂, balance_eq_balance' v.3 hr.3.2.2 v.2 hr.2.2.2,
      size_balance' v.2 hr.2.2.2, e, hl.2.1, hr.2.1], simp [add_comm, add_left_comm] },
  { rw [e, add_right_comm], rintro ⟨⟩ },
  { intros _ h₁, rw e, unfold delta at hr₂ ⊢, linarith }
end

theorem valid'.merge_aux {l r o₁ o₂}
  (hl : valid' o₁ l o₂) (hr : valid' o₁ r o₂)
  (sep : l.all (λ x, r.all (λ y, x < y))) :
  valid' o₁ (@merge α l r) o₂ ∧ size (merge l r) = size l + size r :=
begin
  induction l with ls ll lx lr IHll IHlr generalizing o₁ o₂ r,
  { exact ⟨hr, (zero_add _).symm⟩ },
  induction r with rs rl rx rr IHrl IHrr generalizing o₁ o₂,
  { exact ⟨hl, rfl⟩ },
  rw [merge_node], split_ifs,
  { cases IHrl (sep.imp $ λ x h, h.1)
      (hl.of_lt hr.1.1.to_nil $ sep.imp $ λ x h, h.2.1) hr.left with v e,
    exact valid'.merge_aux₁ hl hr h v e },
  { cases IHlr hl.right (hr.of_gt hl.1.2.to_nil sep.2.1) sep.2.2 with v e,
    have := valid'.merge_aux₁ hr.dual hl.dual h_1 v.dual,
    rw [size_dual, add_comm, size_dual,
      ← dual_balance_r, ← valid'.dual_iff, size_dual, add_comm rs] at this,
    exact this e },
  { refine valid'.glue_aux hl hr sep (or.inr ⟨not_lt.1 h_1, not_lt.1 h⟩) }
end

theorem valid.merge {l r} (hl : valid l) (hr : valid r)
  (sep : l.all (λ x, r.all (λ y, x < y))) : valid (@merge α l r) :=
(valid'.merge_aux hl hr sep).1

theorem insert_with.valid_aux [is_total α (≤)] [@decidable_rel α (≤)]
  (f : α → α) (x : α) (hf : ∀ y, x ≤ y ∧ y ≤ x → x ≤ f y ∧ f y ≤ x) : ∀ {t o₁ o₂},
  valid' o₁ t o₂ → bounded nil o₁ ↑x → bounded nil ↑x o₂ →
  valid' o₁ (insert_with f x t) o₂ ∧
  raised (size t) (size (insert_with f x t))
| nil o₁ o₂ _ bl br := ⟨valid'_singleton bl br, or.inr rfl⟩
| (node sz l y r) o₁ o₂ h bl br := begin
    rw [insert_with, cmp_le],
    split_ifs; rw [insert_with],
    { rcases h with ⟨⟨lx, xr⟩, hs, hb⟩,
      rcases hf _ ⟨h_1, h_2⟩ with ⟨xf, fx⟩,
      refine ⟨⟨⟨lx.mono_right (le_trans h_2 xf),
        xr.mono_left (le_trans fx h_1)⟩, hs, hb⟩, or.inl rfl⟩ },
    { rcases insert_with.valid_aux h.left bl (lt_of_le_not_le h_1 h_2) with ⟨vl, e⟩,
      suffices H,
      { refine ⟨vl.balance_l h.right H, _⟩,
        rw [size_balance_l vl.3 h.3.2.2 vl.2 h.2.2.2 H, h.2.size_eq],
        refine (e.add_right _).add_right _ },
      { exact or.inl ⟨_, e, h.3.1⟩ } },
    { have : y < x := lt_of_le_not_le ((total_of (≤) _ _).resolve_left h_1) h_1,
      rcases insert_with.valid_aux h.right this br with ⟨vr, e⟩,
      suffices H,
      { refine ⟨h.left.balance_r vr H, _⟩,
        rw [size_balance_r h.3.2.1 vr.3 h.2.2.1 vr.2 H, h.2.size_eq],
        refine (e.add_left _).add_right _ },
      { exact or.inr ⟨_, e, h.3.1⟩ } },
  end

theorem insert_with.valid [is_total α (≤)] [@decidable_rel α (≤)]
  (f : α → α) (x : α) (hf : ∀ y, x ≤ y ∧ y ≤ x → x ≤ f y ∧ f y ≤ x)
  {t} (h : valid t) : valid (insert_with f x t) :=
(insert_with.valid_aux _ _ hf h ⟨⟩ ⟨⟩).1

theorem insert_eq_insert_with [@decidable_rel α (≤)]
  (x : α) : ∀ t, ordnode.insert x t = insert_with (λ _, x) x t
| nil := rfl
| (node _ l y r) := by unfold ordnode.insert insert_with;
  cases cmp_le x y; unfold ordnode.insert insert_with; simp [insert_eq_insert_with]

theorem insert.valid [is_total α (≤)] [@decidable_rel α (≤)]
  (x : α) {t} (h : valid t) : valid (ordnode.insert x t) :=
by rw insert_eq_insert_with; exact
insert_with.valid _ _ (λ _ _, ⟨le_refl _, le_refl _⟩) h

theorem insert'_eq_insert_with [@decidable_rel α (≤)]
  (x : α) : ∀ t, insert' x t = insert_with id x t
| nil := rfl
| (node _ l y r) := by unfold insert' insert_with;
  cases cmp_le x y; unfold insert' insert_with; simp [insert'_eq_insert_with]

theorem insert'.valid [is_total α (≤)] [@decidable_rel α (≤)]
  (x : α) {t} (h : valid t) : valid (insert' x t) :=
by rw insert'_eq_insert_with; exact insert_with.valid _ _ (λ _, id) h

theorem valid'.map_aux {β} [preorder β] {f : α → β} (f_strict_mono : strict_mono f)
  {t a₁ a₂} (h : valid' a₁ t a₂) :
  valid' (option.map f a₁) (map f t) (option.map f a₂) ∧ (map f t).size = t.size :=
begin
  induction t generalizing a₁ a₂,
  { simp [map], apply valid'_nil,
    cases a₁, { trivial },
    cases a₂, { trivial },
    simp [bounded],
    exact f_strict_mono h.ord },
  { have t_ih_l' := t_ih_l h.left,
    have t_ih_r' := t_ih_r h.right,
    clear t_ih_l t_ih_r,
    cases t_ih_l' with t_l_valid t_l_size,
    cases t_ih_r' with t_r_valid t_r_size,
    simp [map],
    split,
    { exact and.intro t_l_valid.ord t_r_valid.ord },
    { repeat { split },
      { rw [t_l_size, t_r_size], exact h.sz.1 },
      { exact t_l_valid.sz },
      { exact t_r_valid.sz } },
    { repeat { split },
      { rw [t_l_size, t_r_size], exact h.bal.1 },
      { exact t_l_valid.bal },
      { exact t_r_valid.bal } } },
end

theorem map.valid {β} [preorder β] {f : α → β} (f_strict_mono : strict_mono f)
  {t} (h : valid t) : valid (map f t) :=
(valid'.map_aux f_strict_mono h).1

theorem valid'.erase_aux [@decidable_rel α (≤)] (x : α) {t a₁ a₂} (h : valid' a₁ t a₂) :
  valid' a₁ (erase x t) a₂ ∧ raised (erase x t).size t.size :=
begin
  induction t generalizing a₁ a₂,
  { simp [erase, raised], exact h },
  { simp [erase],
    have t_ih_l' := t_ih_l h.left,
    have t_ih_r' := t_ih_r h.right,
    clear t_ih_l t_ih_r,
    cases t_ih_l' with t_l_valid t_l_size,
    cases t_ih_r' with t_r_valid t_r_size,
    cases (cmp_le x t_x);
      simp [erase._match_1]; rw h.sz.1,
    { suffices h_balanceable,
      split,
      { exact valid'.balance_r t_l_valid h.right h_balanceable },
      { rw size_balance_r t_l_valid.bal h.right.bal t_l_valid.sz h.right.sz h_balanceable,
        repeat { apply raised.add_right },
        exact t_l_size },
      { left, existsi t_l.size, exact (and.intro t_l_size h.bal.1) } },
    { have h_glue := valid'.glue h.left h.right h.bal.1,
      cases h_glue with h_glue_valid h_glue_sized,
      split,
      { exact h_glue_valid },
      { right, rw h_glue_sized } },
    { suffices h_balanceable,
      split,
      { exact valid'.balance_l h.left t_r_valid h_balanceable },
      { rw size_balance_l h.left.bal t_r_valid.bal h.left.sz t_r_valid.sz h_balanceable,
        apply raised.add_right,
        apply raised.add_left,
        exact t_r_size },
      { right, existsi t_r.size, exact (and.intro t_r_size h.bal.1) } } },
end

theorem erase.valid [@decidable_rel α (≤)] (x : α) {t} (h : valid t) : valid (erase x t) :=
(valid'.erase_aux x h).1

theorem size_erase_of_mem [@decidable_rel α (≤)]
  {x : α} {t a₁ a₂} (h : valid' a₁ t a₂) (h_mem : x ∈ t) :
  size (erase x t) = size t - 1 :=
begin
  induction t generalizing a₁ a₂ h h_mem,
  { contradiction },
  { have t_ih_l' := t_ih_l h.left,
    have t_ih_r' := t_ih_r h.right,
    clear t_ih_l t_ih_r,
    unfold has_mem.mem mem at h_mem,
    unfold erase,
    cases (cmp_le x t_x);
      simp [mem._match_1] at h_mem; simp [erase._match_1],
    { have t_ih_l := t_ih_l' h_mem,
      clear t_ih_l' t_ih_r',
      have t_l_h := valid'.erase_aux x h.left,
      cases t_l_h with t_l_valid t_l_size,
      rw size_balance_r t_l_valid.bal h.right.bal t_l_valid.sz h.right.sz
        (or.inl (exists.intro t_l.size (and.intro t_l_size h.bal.1))),
      rw [t_ih_l, h.sz.1],
      have h_pos_t_l_size := pos_size_of_mem h.left.sz h_mem,
      cases t_l.size with t_l_size, { cases h_pos_t_l_size },
      simp [nat.succ_add] },
    { rw [(valid'.glue h.left h.right h.bal.1).2, h.sz.1], refl },
    { have t_ih_r := t_ih_r' h_mem,
      clear t_ih_l' t_ih_r',
      have t_r_h := valid'.erase_aux x h.right,
      cases t_r_h with t_r_valid t_r_size,
      rw size_balance_l h.left.bal t_r_valid.bal h.left.sz t_r_valid.sz
        (or.inr (exists.intro t_r.size (and.intro t_r_size h.bal.1))),
      rw [t_ih_r, h.sz.1],
      have h_pos_t_r_size := pos_size_of_mem h.right.sz h_mem,
      cases t_r.size with t_r_size, { cases h_pos_t_r_size },
      simp [nat.succ_add, nat.add_succ] } },
end

end

end ordnode

/-- An `ordset α` is a finite set of values, represented as a tree. The operations on this type
maintain that the tree is balanced and correctly stores subtree sizes at each level. The
correctness property of the tree is baked into the type, so all operations on this type are correct
by construction. -/
def ordset (α : Type*) [preorder α] := {t : ordnode α // t.valid}

namespace ordset
open ordnode
variable [preorder α]

/-- O(1). The empty set. -/
def nil : ordset α := ⟨nil, ⟨⟩, ⟨⟩, ⟨⟩⟩

/-- O(1). Get the size of the set. -/
def size (s : ordset α) : ℕ := s.1.size

/-- O(1). Construct a singleton set containing value `a`. -/
protected def singleton (a : α) : ordset α := ⟨singleton a, valid_singleton⟩

instance : has_emptyc (ordset α) := ⟨nil⟩
instance : inhabited (ordset α) := ⟨nil⟩
instance : has_singleton α (ordset α) := ⟨ordset.singleton⟩

/-- O(1). Is the set empty? -/
def empty (s : ordset α) : Prop := s = ∅

theorem empty_iff {s : ordset α} : s = ∅ ↔ s.1.empty :=
⟨λ h, by cases h; exact rfl,
 λ h, by cases s; cases s_val; [exact rfl, cases h]⟩

instance : decidable_pred (@empty α _) :=
λ s, decidable_of_iff' _ empty_iff

/-- O(log n). Insert an element into the set, preserving balance and the BST property.
  If an equivalent element is already in the set, this replaces it. -/
protected def insert [is_total α (≤)] [@decidable_rel α (≤)] (x : α) (s : ordset α) : ordset α :=
⟨ordnode.insert x s.1, insert.valid _ s.2⟩

instance [is_total α (≤)] [@decidable_rel α (≤)] : has_insert α (ordset α) := ⟨ordset.insert⟩

/-- O(log n). Insert an element into the set, preserving balance and the BST property.
  If an equivalent element is already in the set, the set is returned as is. -/
def insert' [is_total α (≤)] [@decidable_rel α (≤)] (x : α) (s : ordset α) : ordset α :=
⟨insert' x s.1, insert'.valid _ s.2⟩

section
variables [@decidable_rel α (≤)]

/-- O(log n). Does the set contain the element `x`? That is,
  is there an element that is equivalent to `x` in the order? -/
def mem (x : α) (s : ordset α) : bool := x ∈ s.val

/-- O(log n). Retrieve an element in the set that is equivalent to `x` in the order,
  if it exists. -/
def find (x : α) (s : ordset α) : option α := ordnode.find x s.val

instance : has_mem α (ordset α) := ⟨λ x s, mem x s⟩

instance mem.decidable (x : α) (s : ordset α) : decidable (x ∈ s) := bool.decidable_eq _ _

theorem pos_size_of_mem {x : α} {t : ordset α} (h_mem : x ∈ t) : 0 < size t :=
begin
  simp [has_mem.mem, mem] at h_mem,
  apply ordnode.pos_size_of_mem t.property.sz h_mem,
end

end

/-- O(log n). Remove an element from the set equivalent to `x`. Does nothing if there
is no such element. -/
def erase [@decidable_rel α (≤)] (x : α) (s : ordset α) : ordset α :=
⟨ordnode.erase x s.val, ordnode.erase.valid x s.property⟩

/-- O(n). Map a function across a tree, without changing the structure. -/
def map {β} [preorder β] (f : α → β) (f_strict_mono : strict_mono f) (s : ordset α) : ordset β :=
⟨ordnode.map f s.val, ordnode.map.valid f_strict_mono s.property⟩

end ordset


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.glue_data
import category_theory.concrete_category.elementwise
import topology.category.Top.limits
import topology.category.Top.opens

/-!
# Gluing Topological spaces

Given a family of gluing data (see `category_theory/glue_data`), we can then glue them together.

The construction should be "sealed" and considered as a black box, while only using the API
provided.

## Main definitions

* `Top.glue_data`: A structure containing the family of gluing data.
* `category_theory.glue_data.glued`: The glued topological space.
    This is defined as the multicoequalizer of `∐ V i j ⇉ ∐ U i`, so that the general colimit API
    can be used.
* `category_theory.glue_data.ι`: The immersion `ι i : U i ⟶ glued` for each `i : ι`.
* `Top.glue_data.rel`: A relation on `Σ i, D.U i` defined by `⟨i, x⟩ ~ ⟨j, y⟩` iff
    `⟨i, x⟩ = ⟨j, y⟩` or `t i j x = y`. See `Top.glue_data.ι_eq_iff_rel`.
* `Top.glue_data.mk`: A constructor of `glue_data` whose conditions are stated in terms of
  elements rather than subobjects and pullbacks.
* `Top.glue_data.of_open_subsets`: Given a family of open sets, we may glue them into a new
  topological space. This new space embeds into the original space, and is homeomorphic to it if
  the given family is an open cover (`Top.glue_data.open_cover_glue_homeo`).

## Main results

* `Top.glue_data.is_open_iff`: A set in `glued` is open iff its preimage along each `ι i` is
    open.
* `Top.glue_data.ι_jointly_surjective`: The `ι i`s are jointly surjective.
* `Top.glue_data.rel_equiv`: `rel` is an equivalence relation.
* `Top.glue_data.ι_eq_iff_rel`: `ι i x = ι j y ↔ ⟨i, x⟩ ~ ⟨j, y⟩`.
* `Top.glue_data.image_inter`: The intersection of the images of `U i` and `U j` in `glued` is
    `V i j`.
* `Top.glue_data.preimage_range`: The preimage of the image of `U i` in `U j` is `V i j`.
* `Top.glue_data.preimage_image_eq_preimage_f`: The preimage of the image of some `U ⊆ U i` is
    given by the preimage along `f j i`.
* `Top.glue_data.ι_open_embedding`: Each of the `ι i`s are open embeddings.

-/

noncomputable theory

open topological_space category_theory

universes v u
open category_theory.limits
namespace Top

/--
A family of gluing data consists of
1. An index type `J`
2. An object `U i` for each `i : J`.
3. An object `V i j` for each `i j : J`.
  (Note that this is `J × J → Top` rather than `J → J → Top` to connect to the
  limits library easier.)
4. An open embedding `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
    (This merely means that `V i j ∩ V i k ⊆ t i j ⁻¹' (V j i ∩ V j k)`.)
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the topological spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.

Most of the times it would be easier to use the constructor `Top.glue_data.mk'` where the conditions
are stated in a less categorical way.
-/
@[nolint has_nonempty_instance]
structure glue_data extends glue_data Top :=
  (f_open : ∀ i j, open_embedding (f i j))
  (f_mono := λ i j, (Top.mono_iff_injective _).mpr (f_open i j).to_embedding.inj)

namespace glue_data

variable (D : glue_data.{u})

local notation `𝖣` := D.to_glue_data

lemma π_surjective : function.surjective 𝖣 .π :=
(Top.epi_iff_surjective 𝖣 .π).mp infer_instance

lemma is_open_iff (U : set 𝖣 .glued) : is_open U ↔ ∀ i, is_open (𝖣 .ι i ⁻¹' U) :=
begin
  delta category_theory.glue_data.ι,
  simp_rw ← multicoequalizer.ι_sigma_π 𝖣 .diagram,
  rw ← (homeo_of_iso (multicoequalizer.iso_coequalizer 𝖣 .diagram).symm).is_open_preimage,
  rw [coequalizer_is_open_iff, colimit_is_open_iff.{u}],
  split,
  { intros h j, exact h ⟨j⟩, },
  { intros h j, cases j, exact h j, },
end

lemma ι_jointly_surjective (x : 𝖣 .glued) : ∃ i (y : D.U i), 𝖣 .ι i y = x :=
𝖣 .ι_jointly_surjective (forget Top) x

/--
An equivalence relation on `Σ i, D.U i` that holds iff `𝖣 .ι i x = 𝖣 .ι j y`.
See `Top.glue_data.ι_eq_iff_rel`.
-/
def rel (a b : Σ i, ((D.U i : Top) : Type*)) : Prop :=
  a = b ∨ ∃ (x : D.V (a.1, b.1)) , D.f _ _ x = a.2 ∧ D.f _ _ (D.t _ _ x) = b.2

lemma rel_equiv : equivalence D.rel :=
⟨ λ x, or.inl (refl x),
  begin
    rintros a b (⟨⟨⟩⟩|⟨x,e₁,e₂⟩),
    exacts [or.inl rfl, or.inr ⟨D.t _ _ x, by simp [e₁, e₂]⟩]
  end,
  begin
    rintros ⟨i,a⟩ ⟨j,b⟩ ⟨k,c⟩ (⟨⟨⟩⟩|⟨x,e₁,e₂⟩), exact id,
    rintro (⟨⟨⟩⟩|⟨y,e₃,e₄⟩), exact or.inr ⟨x,e₁,e₂⟩,
    let z := (pullback_iso_prod_subtype (D.f j i) (D.f j k)).inv ⟨⟨_,_⟩, e₂.trans e₃.symm⟩,
    have eq₁ : (D.t j i) ((pullback.fst : _ ⟶ D.V _) z) = x := by simp,
    have eq₂ : (pullback.snd : _ ⟶ D.V _) z = y := pullback_iso_prod_subtype_inv_snd_apply _ _ _,
    clear_value z,
    right,
    use (pullback.fst : _ ⟶ D.V (i, k)) (D.t' _ _ _ z),
    dsimp only at *,
    substs e₁ e₃ e₄ eq₁ eq₂,
    have h₁ : D.t' j i k ≫ pullback.fst ≫ D.f i k = pullback.fst ≫ D.t j i ≫ D.f i j,
    { rw ← 𝖣 .t_fac_assoc, congr' 1, exact pullback.condition },
    have h₂ : D.t' j i k ≫ pullback.fst ≫ D.t i k ≫ D.f k i =
      pullback.snd ≫ D.t j k ≫ D.f k j,
    { rw ← 𝖣 .t_fac_assoc,
      apply @epi.left_cancellation _ _ _ _ (D.t' k j i),
      rw [𝖣 .cocycle_assoc, 𝖣 .t_fac_assoc, 𝖣 .t_inv_assoc],
      exact pullback.condition.symm },
    exact ⟨continuous_map.congr_fun h₁ z, continuous_map.congr_fun h₂ z⟩
  end⟩

open category_theory.limits.walking_parallel_pair

lemma eqv_gen_of_π_eq {x y : ∐ D.U} (h : 𝖣 .π x = 𝖣 .π y) :
  eqv_gen (types.coequalizer_rel 𝖣 .diagram.fst_sigma_map 𝖣 .diagram.snd_sigma_map) x y :=
begin
  delta glue_data.π multicoequalizer.sigma_π at h,
  simp_rw comp_app at h,
  replace h := (Top.mono_iff_injective (multicoequalizer.iso_coequalizer 𝖣 .diagram).inv).mp _ h,
  let diagram := parallel_pair 𝖣 .diagram.fst_sigma_map 𝖣 .diagram.snd_sigma_map ⋙ forget _,
  have : colimit.ι diagram one x = colimit.ι diagram one y,
  { rw ←ι_preserves_colimits_iso_hom,
    simp [h] },
  have :
    (colimit.ι diagram _ ≫ colim.map _ ≫ (colimit.iso_colimit_cocone _).hom) _ =
    (colimit.ι diagram _ ≫ colim.map _ ≫ (colimit.iso_colimit_cocone _).hom) _ :=
    (congr_arg (colim.map (diagram_iso_parallel_pair diagram).hom
    ≫ (colimit.iso_colimit_cocone (types.coequalizer_colimit _ _)).hom) this : _),
  simp only [eq_to_hom_refl, types_comp_apply, colimit.ι_map_assoc,
    diagram_iso_parallel_pair_hom_app, colimit.iso_colimit_cocone_ι_hom, types_id_apply] at this,
  exact quot.eq.1 this,
  apply_instance
end

lemma ι_eq_iff_rel (i j : D.J) (x : D.U i) (y : D.U j) :
  𝖣 .ι i x = 𝖣 .ι j y ↔ D.rel ⟨i, x⟩ ⟨j, y⟩ :=
begin
  split,
  { delta glue_data.ι,
    simp_rw ← multicoequalizer.ι_sigma_π,
    intro h,
    rw ← (show _ = sigma.mk i x,
      from concrete_category.congr_hom (sigma_iso_sigma.{u} D.U).inv_hom_id _),
    rw ← (show _ = sigma.mk j y,
      from concrete_category.congr_hom (sigma_iso_sigma.{u} D.U).inv_hom_id _),
    change inv_image D.rel (sigma_iso_sigma.{u} D.U).hom _ _,
    simp only [Top.sigma_iso_sigma_inv_apply],
    rw ← (inv_image.equivalence _ _ D.rel_equiv).eqv_gen_iff,
    refine eqv_gen.mono _ (D.eqv_gen_of_π_eq h : _),
    rintros _ _ ⟨x⟩,
    rw ← (show (sigma_iso_sigma.{u} _).inv _ = x,
      from concrete_category.congr_hom (sigma_iso_sigma.{u} _).hom_inv_id x),
    generalize : (sigma_iso_sigma.{u} D.V).hom x = x',
    obtain ⟨⟨i,j⟩,y⟩ := x',
    unfold inv_image multispan_index.fst_sigma_map multispan_index.snd_sigma_map,
    simp only [opens.inclusion_apply, Top.comp_app, sigma_iso_sigma_inv_apply,
      category_theory.limits.colimit.ι_desc_apply, cofan.mk_ι_app,
      sigma_iso_sigma_hom_ι_apply, continuous_map.to_fun_eq_coe],
    erw [sigma_iso_sigma_hom_ι_apply, sigma_iso_sigma_hom_ι_apply],
    exact or.inr ⟨y, by { dsimp [glue_data.diagram], simp }⟩ },
  { rintro (⟨⟨⟩⟩|⟨z,e₁,e₂⟩),
    refl, dsimp only at *, subst e₁, subst e₂, simp }
end

lemma ι_injective (i : D.J) : function.injective (𝖣 .ι i) :=
begin
  intros x y h,
  rcases (D.ι_eq_iff_rel _ _ _ _).mp h with (⟨⟨⟩⟩|⟨_,e₁,e₂⟩),
  { refl },
  { dsimp only at *, cases e₁, cases e₂, simp }
end

instance ι_mono (i : D.J) : mono (𝖣 .ι i) :=
(Top.mono_iff_injective _).mpr (D.ι_injective _)

lemma image_inter (i j : D.J) :
  set.range (𝖣 .ι i) ∩ set.range (𝖣 .ι j) = set.range (D.f i j ≫ 𝖣 .ι _) :=
begin
  ext x,
  split,
  { rintro ⟨⟨x₁, eq₁⟩, ⟨x₂, eq₂⟩⟩,
    obtain (⟨⟨⟩⟩|⟨y,e₁,e₂⟩) := (D.ι_eq_iff_rel _ _ _ _).mp (eq₁.trans eq₂.symm),
    { exact ⟨inv (D.f i i) x₁, by simp [eq₁]⟩ },
    { dsimp only at *, substs e₁ eq₁, exact ⟨y, by simp⟩ } },
  { rintro ⟨x, hx⟩,
    exact ⟨⟨D.f i j x, hx⟩, ⟨D.f j i (D.t _ _ x), by simp [← hx]⟩⟩ }
end

lemma preimage_range (i j : D.J) :
  𝖣 .ι j ⁻¹' (set.range (𝖣 .ι i)) = set.range (D.f j i) :=
by rw [← set.preimage_image_eq (set.range (D.f j i)) (D.ι_injective j), ← set.image_univ,
      ← set.image_univ, ←set.image_comp, ←coe_comp, set.image_univ,set.image_univ,
      ← image_inter, set.preimage_range_inter]

lemma preimage_image_eq_image (i j : D.J) (U : set (𝖣 .U i)) :
  𝖣 .ι j ⁻¹' (𝖣 .ι i '' U) = D.f _ _ '' ((D.t j i ≫ D.f _ _) ⁻¹' U) :=
begin
  have : D.f _ _ ⁻¹' (𝖣 .ι j ⁻¹' (𝖣 .ι i '' U)) = (D.t j i ≫ D.f _ _) ⁻¹' U,
  { ext x,
    conv_rhs { rw ← set.preimage_image_eq U (D.ι_injective _) },
    generalize : 𝖣 .ι i '' U = U',
    simp },
  rw [← this, set.image_preimage_eq_inter_range],
  symmetry,
  apply set.inter_eq_self_of_subset_left,
  rw ← D.preimage_range i j,
  exact set.preimage_mono (set.image_subset_range _ _),
end

lemma preimage_image_eq_image' (i j : D.J) (U : set (𝖣 .U i)) :
𝖣 .ι j ⁻¹' (𝖣 .ι i '' U) = (D.t i j ≫ D.f _ _) '' ((D.f _ _) ⁻¹' U) :=
begin
  convert D.preimage_image_eq_image i j U using 1,
  rw [coe_comp, coe_comp, ← set.image_image],
  congr' 1,
  rw [← set.eq_preimage_iff_image_eq, set.preimage_preimage],
  change _ = (D.t i j ≫ D.t j i ≫ _) ⁻¹' _,
  rw 𝖣 .t_inv_assoc,
  rw ← is_iso_iff_bijective,
  apply (forget Top).map_is_iso
end

lemma open_image_open (i : D.J) (U : opens (𝖣 .U i)) : is_open (𝖣 .ι i '' U) :=
begin
  rw is_open_iff,
  intro j,
  rw preimage_image_eq_image,
  apply (D.f_open _ _).is_open_map,
  apply (D.t j i ≫ D.f i j).continuous_to_fun.is_open_preimage,
  exact U.is_open
end

/--
A family of gluing data consists of
1. An index type `J`
2. A bundled topological space `U i` for each `i : J`.
3. An open set `V i j ⊆ U i` for each `i j : J`.
4. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `V i i = U i`.
7. `t i i` is the identity.
8. For each `x ∈ V i j ∩ V i k`, `t i j x ∈ V j k`.
9. `t j k (t i j x) = t i k x`.

We can then glue the topological spaces `U i` together by identifying `V i j` with `V j i`.
-/
@[nolint has_nonempty_instance]
structure mk_core :=
{J : Type u}
(U : J → Top.{u})
(V : Π i, J → opens (U i))
(t : Π i j, (opens.to_Top _).obj (V i j) ⟶ (opens.to_Top _).obj (V j i))
(V_id : ∀ i, V i i = ⊤)
(t_id : ∀ i, ⇑(t i i) = id)
(t_inter : ∀ ⦃i j⦄ k (x : V i j), ↑x ∈ V i k → @coe (V j i) (U j) _ (t i j x) ∈ V j k)
(cocycle : ∀ i j k (x : V i j) (h : ↑x ∈ V i k),
  @coe (V k j) (U k) _ (t j k ⟨↑(t i j x), t_inter k x h⟩) = @coe (V k i) (U k) _ (t i k ⟨x, h⟩))

lemma mk_core.t_inv (h : mk_core) (i j : h.J) (x : h.V j i) : h.t i j ((h.t j i) x) = x :=
begin
  have := h.cocycle j i j x _,
  rw h.t_id at this,
  convert subtype.eq this,
  { ext, refl },
  all_goals { rw h.V_id, trivial }
end

instance (h : mk_core.{u}) (i j : h.J) : is_iso (h.t i j) :=
by { use h.t j i, split; ext1, exacts [h.t_inv _ _ _, h.t_inv _ _ _] }

/-- (Implementation) the restricted transition map to be fed into `glue_data`. -/
def mk_core.t' (h : mk_core.{u}) (i j k : h.J) : pullback (h.V i j).inclusion (h.V i k).inclusion ⟶
  pullback (h.V j k).inclusion (h.V j i).inclusion :=
begin
  refine (pullback_iso_prod_subtype _ _).hom ≫ ⟨_, _⟩ ≫ (pullback_iso_prod_subtype _ _).inv,
  { intro x,
    refine ⟨⟨⟨(h.t i j x.1.1).1, _⟩, h.t i j x.1.1⟩, rfl⟩,
    rcases x with ⟨⟨⟨x, hx⟩, ⟨x', hx'⟩⟩, (rfl : x = x')⟩,
    exact h.t_inter _ ⟨x, hx⟩ hx' },
  continuity,
end

/-- This is a constructor of `Top.glue_data` whose arguments are in terms of elements and
intersections rather than subobjects and pullbacks. Please refer to `Top.glue_data.mk_core` for
details. -/
def mk' (h : mk_core.{u}) : Top.glue_data :=
{ J := h.J,
  U := h.U,
  V := λ i, (opens.to_Top _).obj (h.V i.1 i.2),
  f := λ i j, (h.V i j).inclusion ,
  f_id := λ i, (h.V_id i).symm ▸ is_iso.of_iso (opens.inclusion_top_iso (h.U i)),
  f_open := λ (i j : h.J), (h.V i j).open_embedding,
  t := h.t,
  t_id := λ i, by { ext, rw h.t_id, refl },
  t' := h.t',
  t_fac := λ i j k,
  begin
    delta mk_core.t',
    rw [category.assoc, category.assoc, pullback_iso_prod_subtype_inv_snd, ← iso.eq_inv_comp,
      pullback_iso_prod_subtype_inv_fst_assoc],
    ext ⟨⟨⟨x, hx⟩, ⟨x', hx'⟩⟩, (rfl : x = x')⟩,
    refl,
  end,
  cocycle := λ i j k,
  begin
    delta mk_core.t',
    simp_rw ← category.assoc,
    rw iso.comp_inv_eq,
    simp only [iso.inv_hom_id_assoc, category.assoc, category.id_comp],
    rw [← iso.eq_inv_comp, iso.inv_hom_id],
    ext1 ⟨⟨⟨x, hx⟩, ⟨x', hx'⟩⟩, (rfl : x = x')⟩,
    simp only [Top.comp_app, continuous_map.coe_mk, prod.mk.inj_iff,
      Top.id_app, subtype.mk_eq_mk, subtype.coe_mk],
    rw [← subtype.coe_injective.eq_iff, subtype.val_eq_coe, subtype.coe_mk, and_self],
    convert congr_arg coe (h.t_inv k i ⟨x, hx'⟩) using 3,
    ext,
    exact h.cocycle i j k ⟨x, hx⟩ hx',
  end }
.

variables {α : Type u} [topological_space α] {J : Type u} (U : J → opens α)

include U

/-- We may construct a glue data from a family of open sets. -/
@[simps to_glue_data_J to_glue_data_U to_glue_data_V to_glue_data_t to_glue_data_f]
def of_open_subsets : Top.glue_data.{u} := mk'.{u}
{ J := J,
  U := λ i, (opens.to_Top $ Top.of α).obj (U i),
  V := λ i j, (opens.map $ opens.inclusion _).obj (U j),
  t := λ i j, ⟨λ x, ⟨⟨x.1.1, x.2⟩, x.1.2⟩, by continuity⟩,
  V_id := λ i, by { ext, cases U i, simp },
  t_id := λ i, by { ext, refl },
  t_inter := λ i j k x hx, hx,
  cocycle := λ i j k x h, rfl }

/--
The canonical map from the glue of a family of open subsets `α` into `α`.
This map is an open embedding (`from_open_subsets_glue_open_embedding`),
and its range is `⋃ i, (U i : set α)` (`range_from_open_subsets_glue`).
-/
def from_open_subsets_glue : (of_open_subsets U).to_glue_data.glued ⟶ Top.of α :=
multicoequalizer.desc _ _ (λ x, opens.inclusion _) (by { rintro ⟨i, j⟩, ext x, refl })

@[simp, elementwise]
lemma ι_from_open_subsets_glue (i : J) :
  (of_open_subsets U).to_glue_data.ι i ≫ from_open_subsets_glue U = opens.inclusion _ :=
multicoequalizer.π_desc _ _ _ _ _

lemma from_open_subsets_glue_injective : function.injective (from_open_subsets_glue U) :=
begin
  intros x y e,
  obtain ⟨i, ⟨x, hx⟩, rfl⟩ := (of_open_subsets U).ι_jointly_surjective x,
  obtain ⟨j, ⟨y, hy⟩, rfl⟩ := (of_open_subsets U).ι_jointly_surjective y,
  rw [ι_from_open_subsets_glue_apply, ι_from_open_subsets_glue_apply] at e,
  change x = y at e,
  subst e,
  rw (of_open_subsets U).ι_eq_iff_rel,
  right,
  exact ⟨⟨⟨x, hx⟩, hy⟩, rfl, rfl⟩,
end

lemma from_open_subsets_glue_is_open_map : is_open_map (from_open_subsets_glue U) :=
begin
  intros s hs,
  rw (of_open_subsets U).is_open_iff at hs,
  rw is_open_iff_forall_mem_open,
  rintros _ ⟨x, hx, rfl⟩,
  obtain ⟨i, ⟨x, hx'⟩, rfl⟩ := (of_open_subsets U).ι_jointly_surjective x,
  use from_open_subsets_glue U '' s ∩ set.range (@opens.inclusion (Top.of α) (U i)),
  use set.inter_subset_left _ _,
  split,
  { erw ← set.image_preimage_eq_inter_range,
    apply (@opens.open_embedding (Top.of α) (U i)).is_open_map,
    convert hs i using 1,
    rw [← ι_from_open_subsets_glue, coe_comp, set.preimage_comp],
    congr' 1,
    refine set.preimage_image_eq _ (from_open_subsets_glue_injective U) },
  { refine ⟨set.mem_image_of_mem _ hx, _⟩,
    rw ι_from_open_subsets_glue_apply,
    exact set.mem_range_self _ },
end

lemma from_open_subsets_glue_open_embedding : open_embedding (from_open_subsets_glue U) :=
open_embedding_of_continuous_injective_open (continuous_map.continuous_to_fun _)
  (from_open_subsets_glue_injective U) (from_open_subsets_glue_is_open_map U)

lemma range_from_open_subsets_glue : set.range (from_open_subsets_glue U) = ⋃ i, (U i : set α) :=
begin
  ext,
  split,
  { rintro ⟨x, rfl⟩,
    obtain ⟨i, ⟨x, hx'⟩, rfl⟩ := (of_open_subsets U).ι_jointly_surjective x,
    rw ι_from_open_subsets_glue_apply,
    exact set.subset_Union _ i hx' },
  { rintro ⟨_, ⟨i, rfl⟩, hx⟩,
    refine ⟨(of_open_subsets U).to_glue_data.ι i ⟨x, hx⟩, ι_from_open_subsets_glue_apply _ _ _⟩ }
end

/-- The gluing of an open cover is homeomomorphic to the original space. -/
def open_cover_glue_homeo (h : (⋃ i, (U i : set α)) = set.univ) :
  (of_open_subsets U).to_glue_data.glued ≃ₜ α :=
homeomorph.homeomorph_of_continuous_open
  (equiv.of_bijective (from_open_subsets_glue U)
    ⟨from_open_subsets_glue_injective U,
      set.range_iff_surjective.mp ((range_from_open_subsets_glue U).symm ▸ h)⟩)
  (from_open_subsets_glue U).2 (from_open_subsets_glue_is_open_map U)

end glue_data

end Top


import xenalib.Group_actions data.fintype data.set.finite data.equiv.basic xenalib.Ellen_Arlt_matrix_rings algebra.big_operators data.set.finite group_theory.coset algebra.group
import group_theory.perm
local attribute [instance] classical.prop_decidable

open fintype
set_option pp.proofs true
-- noncomputable instance {n : ℕ} : fintype {f : fin n→ fin n // function.bijective f}  :=
-- set_fintype _
def S (n: ℕ ) := equiv.perm (fin n)
instance (n : ℕ) : has_coe_to_fun (S n) := by unfold S; apply_instance
-- def e {n:ℕ} {R:Type} [comm_ring R] (σ : fin n → fin n) : R:= sorry
-- theorem Sig_eq_inv {n:ℕ} {R:Type} [comm_ring R] (π: S n)  : @e n R _  π.1 = e (π.symm).1 := sorry
-- theorem sig_mul  {n:ℕ} {R:Type} [comm_ring R] (σ π : fin n → fin n) : @e n R _  (σ ∘ π  )= (@e n R _  σ ) *  @e n R _   π  := sorry
-- theorem sig_swap  {n:ℕ} {R:Type} [comm_ring R] (i j : fin n): e (equiv.swap i j).1 = (-1 :R) := sorry
-- noncomputable instance Sn_finite {n:ℕ}: fintype (S n):=
-- fintype.of_surjective
-- (λ (f : {f : fin n → fin n // function.bijective f}), equiv.of_bijective f.2)
-- begin
-- unfold function.surjective,
-- simp,
-- intro b,
-- let f:{f : fin n → fin n // function.bijective f}:=  ⟨ b.1,b.bijective⟩,
-- existsi f.1,
-- existsi  f.2,
-- apply equiv.ext,
-- intro x,
-- rw equiv.of_bijective_to_fun,
-- refl,
-- end
instance g (n : ℕ) : is_group_action (equiv.to_fun : S n → fin n → fin n) :=
{ one := λ _, rfl,
  mul := λ _ _ _, rfl }

open is_group_action
theorem Sn_transitive {n:ℕ}(i:fin n): ∀ (j:fin n), j ∈ is_group_action.orbit equiv.to_fun i:=
begin
intro j,
unfold is_group_action.orbit,
unfold set.range,
simp,
let f := λx, if x=i then j else if x=j then i else x,
refine exists.intro ⟨ f,f, λ _, begin
 simp [f]; split_ifs; simp*,
  end,
  λ _, begin simp [f]; split_ifs; simp*,
  end⟩ _,
simp,
simp[f],
split_ifs,
refl,
refl,
end
variables (n :ℕ) (σ : S n)

open function
def compose: ℕ → (fin n → fin n) → (fin n → fin n)
| 0 σ := σ
| (i + 1) σ  := comp σ (compose i σ )
def cyclic_subtype :Type :=  {x : S n // ∃ (j: ℕ), (compose j σ.1) = x.1}

def Cyclic_Group_generated_by (σ : S n ): group {x : S n // ∃ (j: ℕ), (compose j σ.1) = x.1} :=

def Cycle (σ : S n): Prop:= ∃! (i:fin n), card (is_group_action.orbit equiv.to_fun i) > 1,

def f' {n:ℕ }(f:is_group_action.stabilizer (equiv.to_fun: S (n+1) →
  fin (n+1) → fin (n+1)) ⟨n, nat.lt_succ_self _⟩): fin n → fin n :=
λ x, ⟨(f.1.1 (fin.raise x)).1,
begin
  have : ((f.val).to_fun ⟨n, nat.lt_succ_self n⟩).val = n := fin.veq_of_eq f.2,
  refine lt_of_le_of_ne _ _,
  exact (nat.le_of_lt_succ (f.1.1 (fin.raise x)).2),
  assume h,
  conv at h {to_rhs, rw ← this},
  have h : x.val = n := fin.veq_of_eq (f.1.bijective.1 (fin.eq_of_veq h)),
  have : x.val < n := x.2,
  simpa[lt_irrefl, h] using this,
end⟩
@[simp] lemma fin_thing {n : ℕ} (a : fin n) : (⟨a.1, a.2⟩ : fin n) = a := by cases a;refl
#print is_group_action.mul
theorem f'_bijective {n:ℕ }(f:is_group_action.stabilizer (equiv.to_fun: S (n+1) → fin (n+1) → fin (n+1)) ⟨n, nat.lt_succ_self _⟩): function.bijective(f' f):=
begin
unfold function.bijective,
split,
unfold function.injective,
intros,
rw[f'] at a,
have H1: ((f.val).to_fun (fin.raise a₁)).val =
     ((f.val).to_fun (fin.raise a₂)).val,
rw[ fin.veq_of_eq a],
have H2 : (fin.raise a₁).val = (fin.raise a₂).val,
exact fin.veq_of_eq (f.1.bijective.1 (fin.eq_of_veq H1)),
exact fin.eq_of_veq H2,
unfold function.surjective,
intros,
unfold f',
existsi  (⟨  (f.val⁻¹ .to_fun (fin.raise b)).val,
begin
have H1: f.val⁻¹ ∈  stabilizer
(equiv.to_fun: S (n+1) → fin (n+1) → fin (n+1)) ⟨n, nat.lt_succ_self _⟩,
rw[is_subgroup.inv_mem_iff],
exact f.2,
 have : ((f.val⁻¹).to_fun ⟨n, nat.lt_succ_self n⟩).val = n :=
 fin.veq_of_eq H1,
 refine lt_of_le_of_ne _ _,
  exact (nat.le_of_lt_succ (f.1.2 (fin.raise b)).2),
  assume h,
  conv at h {to_rhs, rw ← this},
  have h : b.val = n := fin.veq_of_eq ((f.val⁻¹).bijective.1 (fin.eq_of_veq h)),
  have : b.val < n := b.2,
  simpa[lt_irrefl, h] using this,

end⟩ : fin n),
simp [fin.raise],
apply fin.eq_of_veq,
simp,
-- (is_group_action.mul (equiv.to_fun : S (n+1) → fin (n+1) → fin (n+1)) _ _ _).symm._,
-- rw mul_inv_self,
-- exact b.2,
rw ← is_group_action.mul (equiv.to_fun : S (n+1) → fin (n+1) → fin (n+1)),
rw mul_inv_self,
refl,
end
open function
noncomputable def F : is_group_action.stabilizer (equiv.to_fun: S (n+1) → fin (n+1) → fin (n+1)) ⟨n, nat.lt_succ_self _⟩ → S n:=
λ f, ⟨ (f' f),surj_inv (f'_bijective f).2 , left_inverse_surj_inv (f'_bijective f), right_inverse_surj_inv(f'_bijective f).2⟩

theorem bijection_form_stab_to_Sn: bijective (F n):=
begin
unfold function.bijective,
split,
unfold injective,
intros,
simp[F] at a,
refine subtype.eq (equiv.ext _ _ _),
have : f' a₁ = f' a₂, by injection a,
simp [f'] at this,

have:= congr_fun this,
dsimp at this,
intro a,
by_cases a.1 < n,
have := (fin.veq_of_eq (this_1 ⟨a.1, h⟩)),
simp [fin.raise] at this,
exact fin.eq_of_veq this,
have H1 : n≤ a.1,
exact le_of_not_lt h,
have H2: a.1 ≤ n,
exact nat.le_of_lt_succ a.2,
have H3: a.1= n,
exact le_antisymm H2 H1,
have H4: a= ⟨n, nat.lt_succ_self _⟩,
exact fin.eq_of_veq H3,
rw[H4],
have H5: (a₁.val) ⟨n, _⟩ =⟨n, _⟩,
exact a₁.2,
have H6: (a₂.val) ⟨n, _⟩ =⟨n, _⟩,
exact a₂.2,
exact eq.trans H5 H6.symm,
unfold surjective,
intro,
simp[F],
let k:= λ(x:fin(n+1)),if hxn : x.1<n then (⟨b.1 ⟨x.1, hxn⟩,
begin
have H1: (b.1 ⟨x.1, hxn⟩).1 < n,
  exact (b.1 ⟨x.1, hxn⟩).2,
  exact lt_trans H1 (nat.lt_succ_self n),
 end ⟩ : fin(n+1)) else n,
existsi( ⟨k ,λ(x:fin(n+1)),if hxn : x.1<n then ⟨b.2 ⟨x.1, hxn⟩,
begin
have H1: (b.2 ⟨x.1, hxn⟩).1 < n,
  exact (b.2 ⟨x.1, hxn⟩).2,
  exact lt_trans H1 (nat.lt_succ_self n),
 end ⟩ else n,
 begin
 unfold left_inverse,
 intro,
 by_cases x.val < n,
 simp [h, dif_pos h],
--have H1:

 end, sorry⟩ :fin (n + 1) ≃ fin (n + 1))
end
#check eq.trans
#check le_antisymm
#check le_of_not_lt
theorem mag_S {n:ℕ}: fintype.card (S n) = nat.fact n := sorry
#check nat.le_of_lt_succ
#check nat.add_one
#check lt_trans


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.set.intervals.ord_connected
import order.filter.small_sets
import order.filter.at_top_bot

/-!
# Convergence of intervals

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

If both `a` and `b` tend to some filter `l₁`, sometimes this implies that `Ixx a b` tends to
`l₂.small_sets`, i.e., for any `s ∈ l₂` eventually `Ixx a b` becomes a subset of `s`.  Here and
below `Ixx` is one of `Icc`, `Ico`, `Ioc`, and `Ioo`. We define `filter.tendsto_Ixx_class Ixx l₁ l₂`
to be a typeclass representing this property.

The instances provide the best `l₂` for a given `l₁`. In many cases `l₁ = l₂` but sometimes we can
drop an endpoint from an interval: e.g., we prove `tendsto_Ixx_class Ico (𝓟 $ Iic a) (𝓟 $ Iio a)`,
i.e., if `u₁ n` and `u₂ n` belong eventually to `Iic a`, then the interval `Ico (u₁ n) (u₂ n)` is
eventually included in `Iio a`.

The next table shows “output” filters `l₂` for different values of `Ixx` and `l₁`. The instances
that need topology are defined in `topology/algebra/ordered`.

| Input filter |  `Ixx = Icc`  |  `Ixx = Ico`  |  `Ixx = Ioc`  |  `Ixx = Ioo`  |
| -----------: | :-----------: | :-----------: | :-----------: | :-----------: |
|     `at_top` |    `at_top`   |    `at_top`   |    `at_top`   |    `at_top`   |
|     `at_bot` |    `at_bot`   |    `at_bot`   |    `at_bot`   |    `at_bot`   |
|     `pure a` |    `pure a`   |      `⊥`      |      `⊥`      |      `⊥`      |
|  `𝓟 (Iic a)` |  `𝓟 (Iic a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iic a)`  |  `𝓟 (Iio a)`  |
|  `𝓟 (Ici a)` |  `𝓟 (Ici a)`  |  `𝓟 (Ici a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |
|  `𝓟 (Ioi a)` |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |
|  `𝓟 (Iio a)` |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |
|        `𝓝 a` |     `𝓝 a`     |     `𝓝 a`     |     `𝓝 a`     |     `𝓝 a`     |
| `𝓝[Iic a] b` |  `𝓝[Iic a] b` |  `𝓝[Iio a] b` |  `𝓝[Iic a] b` |  `𝓝[Iio a] b` |
| `𝓝[Ici a] b` |  `𝓝[Ici a] b` |  `𝓝[Ici a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |
| `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |
| `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |

-/

variables {α β : Type*}

open_locale classical filter interval

open set function

namespace filter

section preorder

variables [preorder α]

/-- A pair of filters `l₁`, `l₂` has `tendsto_Ixx_class Ixx` property if `Ixx a b` tends to
`l₂.small_sets` as `a` and `b` tend to `l₁`. In all instances `Ixx` is one of `Icc`, `Ico`, `Ioc`,
or `Ioo`. The instances provide the best `l₂` for a given `l₁`. In many cases `l₁ = l₂` but
sometimes we can drop an endpoint from an interval: e.g., we prove `tendsto_Ixx_class Ico (𝓟 $ Iic
a) (𝓟 $ Iio a)`, i.e., if `u₁ n` and `u₂ n` belong eventually to `Iic a`, then the interval `Ico (u₁
n) (u₂ n)` is eventually included in `Iio a`.

We mark `l₂` as an `out_param` so that Lean can automatically find an appropriate `l₂` based on
`Ixx` and `l₁`. This way, e.g., `tendsto.Ico h₁ h₂` works without specifying explicitly `l₂`. -/
class tendsto_Ixx_class (Ixx : α → α → set α) (l₁ : filter α) (l₂ : out_param $ filter α) : Prop :=
(tendsto_Ixx : tendsto (λ p : α × α, Ixx p.1 p.2) (l₁ ×ᶠ l₁) l₂.small_sets)

lemma tendsto.Icc {l₁ l₂ : filter α} [tendsto_Ixx_class Icc l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Icc (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ioc {l₁ l₂ : filter α} [tendsto_Ixx_class Ioc l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ioc (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ico {l₁ l₂ : filter α} [tendsto_Ixx_class Ico l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ico (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ioo {l₁ l₂ : filter α} [tendsto_Ixx_class Ioo l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ioo (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto_Ixx_class_principal {s t : set α} {Ixx : α → α → set α} :
  tendsto_Ixx_class Ixx (𝓟 s) (𝓟 t) ↔ ∀ x y ∈ s, Ixx x y ⊆ t :=
iff.trans ⟨λ h, h.1, λ h, ⟨h⟩⟩ $ by simp only [small_sets_principal, prod_principal_principal,
  tendsto_principal_principal, forall_prod_set, mem_powerset_iff, mem_principal]

lemma tendsto_Ixx_class_inf {l₁ l₁' l₂ l₂' : filter α} {Ixx}
  [h : tendsto_Ixx_class Ixx l₁ l₂] [h' : tendsto_Ixx_class Ixx l₁' l₂'] :
  tendsto_Ixx_class Ixx (l₁ ⊓ l₁') (l₂ ⊓ l₂') :=
⟨by simpa only [prod_inf_prod, small_sets_inf] using h.1.inf h'.1⟩

lemma tendsto_Ixx_class_of_subset {l₁ l₂ : filter α} {Ixx Ixx' : α → α → set α}
  (h : ∀ a b, Ixx a b ⊆ Ixx' a b) [h' : tendsto_Ixx_class Ixx' l₁ l₂] :
  tendsto_Ixx_class Ixx l₁ l₂ :=
⟨h'.1.small_sets_mono $ eventually_of_forall $ prod.forall.2 h⟩

lemma has_basis.tendsto_Ixx_class {ι : Type*} {p : ι → Prop} {s} {l : filter α}
  (hl : l.has_basis p s) {Ixx : α → α → set α}
  (H : ∀ i, p i → ∀ (x ∈ s i) (y ∈ s i), Ixx x y ⊆ s i) :
  tendsto_Ixx_class Ixx l l :=
⟨(hl.prod_self.tendsto_iff hl.small_sets).2 $ λ i hi,
  ⟨i, hi, λ x hx, H i hi _ hx.1 _ hx.2⟩⟩

instance tendsto_Icc_at_top_at_top : tendsto_Ixx_class Icc (at_top : filter α) at_top :=
(has_basis_infi_principal_finite _).tendsto_Ixx_class $ λ s hs,
set.ord_connected.out $ ord_connected_bInter $ λ i hi, ord_connected_Ici

instance tendsto_Ico_at_top_at_top : tendsto_Ixx_class Ico (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_at_top_at_top : tendsto_Ixx_class Ioc (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_at_top_at_top : tendsto_Ixx_class Ioo (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Icc_self)

instance tendsto_Icc_at_bot_at_bot : tendsto_Ixx_class Icc (at_bot : filter α) at_bot :=
(has_basis_infi_principal_finite _).tendsto_Ixx_class $ λ s hs,
set.ord_connected.out $ ord_connected_bInter $ λ i hi, ord_connected_Iic

instance tendsto_Ico_at_bot_at_bot : tendsto_Ixx_class Ico (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_at_bot_at_bot : tendsto_Ixx_class Ioc (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_at_bot_at_bot : tendsto_Ixx_class Ioo (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Icc_self)

instance ord_connected.tendsto_Icc {s : set α} [hs : ord_connected s] :
  tendsto_Ixx_class Icc (𝓟 s) (𝓟 s) :=
tendsto_Ixx_class_principal.2 hs.out

instance tendsto_Ico_Ici_Ici {a : α} : tendsto_Ixx_class Ico (𝓟 (Ici a)) (𝓟 (Ici a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ico_Ioi_Ioi {a : α} : tendsto_Ixx_class Ico (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ico_Iic_Iio {a : α} : tendsto_Ixx_class Ico (𝓟 (Iic a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_principal.2 $ λ a ha b hb x hx, lt_of_lt_of_le hx.2 hb

instance tendsto_Ico_Iio_Iio {a : α} : tendsto_Ixx_class Ico (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_Ici_Ioi {a : α} : tendsto_Ixx_class Ioc (𝓟 (Ici a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_principal.2 $ λ x hx y hy t ht, lt_of_le_of_lt hx ht.1

instance tendsto_Ioc_Iic_Iic {a : α} : tendsto_Ixx_class Ioc (𝓟 (Iic a)) (𝓟 (Iic a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioc_Iio_Iio {a : α} : tendsto_Ixx_class Ioc (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioc_Ioi_Ioi {a : α} : tendsto_Ixx_class Ioc (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_Ici_Ioi {a : α} : tendsto_Ixx_class Ioo (𝓟 (Ici a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Ioo_Iic_Iio {a : α} : tendsto_Ixx_class Ioo (𝓟 (Iic a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ico_self)

instance tendsto_Ioo_Ioi_Ioi {a : α} : tendsto_Ixx_class Ioo (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Ioo_Iio_Iio {a : α} : tendsto_Ixx_class Ioo (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Icc_Icc_Icc {a b : α} :
  tendsto_Ixx_class Icc (𝓟 (Icc a b)) (𝓟 (Icc a b)) :=
tendsto_Ixx_class_principal.mpr $ λ x hx y hy, Icc_subset_Icc hx.1 hy.2

instance tendsto_Ioc_Icc_Icc {a b : α} : tendsto_Ixx_class Ioc (𝓟 (Icc a b)) (𝓟 (Icc a b)) :=
tendsto_Ixx_class_of_subset $ λ _ _, Ioc_subset_Icc_self

end preorder

section partial_order

variable [partial_order α]

instance tendsto_Icc_pure_pure {a : α} : tendsto_Ixx_class Icc (pure a) (pure a : filter α) :=
by { rw ← principal_singleton, exact tendsto_Ixx_class_principal.2 ord_connected_singleton.out }

instance tendsto_Ico_pure_bot {a : α} : tendsto_Ixx_class Ico (pure a) ⊥ := ⟨by simp⟩
instance tendsto_Ioc_pure_bot {a : α} : tendsto_Ixx_class Ioc (pure a) ⊥ := ⟨by simp⟩
instance tendsto_Ioo_pure_bot {a : α} : tendsto_Ixx_class Ioo (pure a) ⊥ := ⟨by simp⟩

end partial_order

section linear_order

variables [linear_order α]

instance tendsto_Icc_uIcc_uIcc {a b : α} : tendsto_Ixx_class Icc (𝓟 [a, b]) (𝓟 [a, b]) :=
filter.tendsto_Icc_Icc_Icc

instance tendsto_Ioc_uIcc_uIcc {a b : α} : tendsto_Ixx_class Ioc (𝓟 [a, b]) (𝓟 [a, b]) :=
filter.tendsto_Ioc_Icc_Icc

instance tendsto_uIcc_of_Icc {l : filter α} [tendsto_Ixx_class Icc l l] :
  tendsto_Ixx_class uIcc l l :=
begin
  refine ⟨λ s hs, mem_map.2 $ mem_prod_self_iff.2 _⟩,
  obtain ⟨t, htl, hts⟩ : ∃ t ∈ l, ∀ p ∈ (t : set α) ×ˢ t, Icc (p : α × α).1 p.2 ∈ s,
    from mem_prod_self_iff.1 (mem_map.1 (tendsto_fst.Icc tendsto_snd hs)),
  refine ⟨t, htl, λ p hp, _⟩,
  cases le_total p.1 p.2,
  { rw [mem_preimage, uIcc_of_le h], exact hts p hp },
  { rw [mem_preimage, uIcc_of_ge h], exact hts ⟨p.2, p.1⟩ ⟨hp.2, hp.1⟩ }
end

lemma tendsto.uIcc {l : filter α} [tendsto_Ixx_class Icc l l] {f g : β → α} {lb : filter β}
  (hf : tendsto f lb l) (hg : tendsto g lb l) :
  tendsto (λ x, [f x, g x]) lb l.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ hf.prod_mk hg

end linear_order

end filter