import ia.groups.hom
import data.nat.modeq
import set_theory.cardinal.finite

namespace notes

open group hom

variables {G H K L : Type*}
variables {Φ Ψ Χ : Type*}

-- Direct products of groups

@[to_additive]
instance [semigroup G] [semigroup H] : semigroup (G × H) := {
  mul_assoc := begin
    rintros ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨c₁, c₂⟩,
    dsimp,
    rw mul_assoc,
    rw mul_assoc
  end
}

@[to_additive]
instance [monoid G] [monoid H] : monoid (G × H) := {
  one_mul := begin
    rintro ⟨a₁, a₂⟩,
    rw prod.mul_def,
    dsimp,
    rw one_mul,
    rw one_mul
  end,
  mul_one := begin
    rintro ⟨a₁, a₂⟩,
    rw prod.mul_def,
    dsimp,
    rw mul_one,
    rw mul_one
  end
}

@[to_additive]
instance [group G] [group H] : group (G × H) := {
  mul_left_inv := begin
    rintro ⟨a₁, a₂⟩,
    dsimp,
    rw mul_left_inv,
    rw mul_left_inv,
    refl
  end,
  mul_right_inv := begin
    rintro ⟨a₁, a₂⟩,
    dsimp,
    rw mul_right_inv,
    rw mul_right_inv,
    refl
  end
}

def direct_product_theorem [group G] {H K : subgroup G}
(trivial_intersection : H ⊓ K = subgroup.trivial)
(commute : ∀ h ∈ H, ∀ k ∈ K, h * k = k * h)
(span : ∀ g : G, ∃ h ∈ H, ∃ k ∈ K, g = h * k)
: H.carrier × K.carrier ≅* G :=
begin
  let f : H.carrier × K.carrier → G := λ ⟨h, k⟩, h * k,
  let φ : H.carrier × K.carrier →* G := ⟨f, _⟩, swap,
  { rintros ⟨h₁, k₁⟩ ⟨h₂, k₂⟩,
    simp,
    change (h₁ * h₂ : G) * (k₁ * k₂) = (h₁ * k₁) * (h₂ * k₂),
    rw mul_assoc,
    rw ← mul_assoc ↑h₂,
    rw commute ↑h₂,
    { rw [mul_assoc, mul_assoc] },
    { exact set_like.coe_mem h₂ },
    { exact set_like.coe_mem k₁ } },
  refine ⟨φ, _, _⟩,
  { change function.injective φ,
    rw inj_iff_kernel_trivial,
    rw kernel_trivial,
    rintros ⟨h, k⟩ hk,
    change (h : G) * k = 1 at hk,
    have h_mem_K : ↑h ∈ K.carrier := set.mem_of_eq_of_mem
      (eq_inv_of_mul_eq_one hk)
      (subgroup.inv_mem K (subtype.mem k)),
    have : ↑h ∈ H ⊓ K := ⟨subtype.mem h, h_mem_K⟩,
    rw trivial_intersection at this,
    rw subgroup.mem_trivial at this,
    rw this at hk,
    rw one_mul at hk,
    congr',
    { apply subgroup.coe_eq, exact this },
    { apply subgroup.coe_eq, exact hk } },
  { intro g,
    obtain ⟨h, hh, k, hk, hhk⟩ := span g,
    exact ⟨⟨⟨h, hh⟩, ⟨k, hk⟩⟩, hhk.symm⟩ }
end

-- Finite and infinite cyclic groups

@[ext]
structure cyclic_group (n : ℕ) (n_pos : 0 < n) :=
(val : ℕ)
(property : val < n)

instance {n : ℕ} {n_pos : 0 < n} : has_coe (cyclic_group n n_pos) ℕ := ⟨λ x, x.val⟩

instance {n : ℕ} {n_pos : 0 < n} : has_add (cyclic_group n n_pos) :=
⟨λ a b, ⟨(a + b) % n, nat.mod_lt _ n_pos⟩⟩

lemma cyclic_group.coe_eq_val {n : ℕ} {n_pos : 0 < n} (a : cyclic_group n n_pos) :
↑a = a.val := rfl

lemma cyclic_group.eq_of_modeq {n : ℕ} {n_pos : 0 < n} {a b : cyclic_group n n_pos}
(h : a ≡ b [MOD n]) : a = b :=
begin
  ext,
  unfold nat.modeq at h,
  rw [ cyclic_group.coe_eq_val,
    cyclic_group.coe_eq_val,
    nat.mod_eq_of_lt a.property,
    nat.mod_eq_of_lt b.property ] at h,
  exact h
end

@[simp]
lemma cyclic_group.add_def {n : ℕ} {n_pos : 0 < n} (a b : cyclic_group n n_pos) :
(a + b).val = (a.val + b.val) % n := rfl

lemma cyclic_group.val_eq_mod_of_mod_eq {n : ℕ} {n_pos : 0 < n} {a : cyclic_group n n_pos} {b : ℕ}
(h : a.val ≡ b [MOD n]) : a.val = b % n :=
begin
  unfold nat.modeq at h,
  rw ← h,
  symmetry,
  apply nat.mod_eq_of_lt,
  exact a.property
end

lemma cyclic_group.val_eq_of_lt_of_mod_eq {n : ℕ} {n_pos : 0 < n} {a : cyclic_group n n_pos} {b : ℕ}
(h : a.val ≡ b [MOD n]) (hlt : b < n) : a.val = b :=
begin
  rw ← nat.mod_eq_of_lt hlt,
  exact cyclic_group.val_eq_mod_of_mod_eq h
end

instance {n : ℕ} {n_pos : 0 < n} : add_semigroup (cyclic_group n n_pos) := {
  add_assoc := begin
    intros a b c,
    ext,
    simp,
    rw nat.add_assoc
  end
}

instance {n : ℕ} {n_pos : 0 < n} : has_zero (cyclic_group n n_pos) :=
⟨⟨0, n_pos⟩⟩

@[simp]
lemma cyclic_zero_def {n : ℕ} {n_pos : 0 < n} : (0 : cyclic_group n n_pos).val = 0 := rfl

instance {n : ℕ} {n_pos : 0 < n} : has_one (cyclic_group n n_pos) := ⟨⟨1 % n, nat.mod_lt 1 n_pos⟩⟩

instance {n : ℕ} {n_pos : 0 < n} : add_monoid (cyclic_group n n_pos) := {
  zero_add := begin
    intro a,
    ext,
    simp,
    exact nat.mod_eq_of_lt a.property
  end,
  add_zero := begin
    intro a,
    ext,
    simp,
    exact nat.mod_eq_of_lt a.property
  end
}

instance {n : ℕ} {n_pos : 0 < n} : has_neg (cyclic_group n n_pos) :=
⟨λ x, ⟨(n - x) % n, nat.mod_lt _ n_pos⟩⟩

@[simp]
lemma cyclic_neg_def {n : ℕ} {n_pos : 0 < n} (x : cyclic_group n n_pos) :
(-x).val = (n - x) % n := rfl

instance {n : ℕ} {n_pos : 0 < n} : add_group (cyclic_group n n_pos) := {
  add_left_neg := begin
    intro a,
    ext,
    simp,
    change (n - a.val + a.val) % n = 0,
    rw nat.sub_add_cancel (le_of_lt a.property),
    exact nat.mod_self n
  end,
  add_right_neg := begin
    intro a,
    ext,
    simp,
    change (a.val + (n - a.val)) % n = 0,
    rw ← nat.add_sub_assoc (le_of_lt a.property),
    rw nat.add_sub_cancel_left,
    exact nat.mod_self n
  end
}

@[to_additive]
def is_mul_generator [group G] (x : G) : Prop :=
⟪{x}⟫ = (subgroup.univ : subgroup G)

@[to_additive]
def is_mul_cyclic (G : Type*) [group G] : Type* :=
Σ' (x : G), is_mul_generator x

@[to_additive]
lemma is_mul_generator_def [group G] {x : G} : is_mul_generator x ↔ ⟪{x}⟫ = (subgroup.univ : subgroup G) := iff.rfl

@[simp, to_additive]
lemma mem_of_is_mul_generator [group G] {x : G} (h : is_mul_generator x) (y : G) : y ∈ (⟪{x}⟫ : subgroup G) :=
begin
  rw is_mul_generator_def at h,
  rw h,
  simp
end

@[simp, to_additive]
lemma mem_of_is_mul_cyclic [group G] (h : is_mul_cyclic G) (y : G) : y ∈ (⟪{h.fst}⟫ : subgroup G) :=
begin
  apply mem_of_is_mul_generator,
  exact h.snd
end

-- TODO: cyclic_group.is_cyclic

-- The generated subgroup from one element has elements
-- exactly of the form x ^ n for some integer n.
@[to_additive]
lemma singleton_generated_subgroup_elements [group G] (x y : G) :
y ∈ (⟪{x}⟫ : subgroup G) ↔ ∃ (n : ℤ), y = x ^ n :=
begin
  split,
  { intro h,
    specialize h ((λ n, x ^ n) '' (@set.univ ℤ)),
    simp at h,
    obtain ⟨n, hn⟩ := h 1 (group.pow_one_int x) ⟨_, _, _⟩,
    { exact ⟨n, hn.symm⟩ },
    { rintros a b ⟨c, hc⟩ ⟨d, hd⟩,
      refine ⟨c + d, _⟩,
      rw group.add_int_pow,
      rw hc, rw hd },
    { refine ⟨0, _⟩,
      simp },
    { rintros a ⟨b, hb⟩,
      refine ⟨-b, _⟩,
      rw ← hb,
      rw group.int_pow_neg_eq_inv_pow,
      rw group.inv_int_pow_eq_int_pow_inv } },
  { rintro ⟨n, hn⟩,
    rw hn,
    refine subgroup.int_pow_mem _ _,
    exact subgroup.subseteq_generated_subgroup {x} (set.mem_singleton x) }
end

@[to_additive]
lemma singleton_generated_subgroup_eq [group G] (x : G) :
(⟪{x}⟫ : subgroup G).carrier = set.range (λ (n : ℤ), x ^ n) :=
begin
  ext,
  rw subgroup.mem_carrier,
  rw singleton_generated_subgroup_elements x,
  simp,
  simp_rw eq_comm
end

@[to_additive]
lemma pow_injective_of_order_finite [group G] {x : G} {n : ℕ} (h : group.order x = enat.some n) :
function.injective (λ (m : {k // k < n}), x ^ m.val) :=
begin
  intros a b h₁,
  ext,
  dsimp at h₁,
  rw ← group.pow_int_coe at h₁,
  rw ← group.pow_int_coe at h₁,
  rw ← group.pow_eq_pow_iff_order_dvd_sub h at h₁,
  rw int.dvd_iff_mod_eq_zero at h₁,
  rw ← int.mod_eq_mod_iff_mod_sub_eq_zero at h₁,
  rw int.mod_eq_of_lt at h₁,
  rw int.mod_eq_of_lt at h₁,
  rw ← int.coe_nat_eq_coe_nat_iff,
  exact h₁,
  { rw ← int.of_nat_eq_coe, exact int.zero_le_of_nat _ },
  { exact int.coe_nat_lt_coe_nat_of_lt b.property },
  { rw ← int.of_nat_eq_coe, exact int.zero_le_of_nat _ },
  { exact int.coe_nat_lt_coe_nat_of_lt a.property }
end

@[to_additive]
lemma singleton_generated_subgroup_eq_finite [group G] {x : G} {n : ℕ} (h : group.order x = enat.some n) :
(⟪{x}⟫.carrier : set G) = finset.map ⟨(λ (m : {k : ℕ // k < n}), x ^ m.val), pow_injective_of_order_finite h⟩ (finset.fin_range n) :=
begin
  rw singleton_generated_subgroup_eq,
  ext y,
  simp,
  split,
  { rintro ⟨p, hp⟩,
    refine ⟨int.nat_mod p n, _, _⟩,
    { unfold int.nat_mod,
      rw ← int.to_nat_coe_nat n,
      rw int.to_nat_lt_to_nat,
      simp,
      apply int.mod_lt_of_pos,
      exact group.zero_lt_order_int h,
      exact group.zero_lt_order_int h, },
    { rw ← hp,
      rw ← group.pow_int_coe,
      rw ← group.pow_eq_pow_iff_order_dvd_sub h,
      rw int.dvd_iff_mod_eq_zero,
      rw ← int.mod_eq_mod_iff_mod_sub_eq_zero,
      unfold int.nat_mod,
      rw int.to_nat_of_nonneg _,
      { simp },
      apply int.mod_nonneg,
      exact (group.zero_ne_order_int h).symm } },
  { rintro ⟨p, hp₁, hp₂⟩,
    refine ⟨↑p, _⟩,
    rw ← hp₂,
    simp }
end

@[to_additive]
lemma exists_eq_pow_of_mul_cyclic [group G] (hcyclic : is_mul_cyclic G) (x : G) :
∃ (n : ℤ), x = hcyclic.fst ^ n :=
begin
  rw ← singleton_generated_subgroup_elements hcyclic.fst x,
  simp
end

@[to_additive]
theorem singleton_generated_subgroup_card_eq_order [group G] (x : G) :
enat.card (⟪{x}⟫.carrier : set G) = group.order x :=
begin
  rw singleton_generated_subgroup_eq,
  simp,
  by_cases order x = ⊤,
  { rw h,
    haveI : infinite (set.range (λ (n : ℤ), x ^ n)),
    { rw set.infinite_coe_iff,
      apply set.infinite_range_of_injective,
      intros a b hab,
      simp at hab,
      rw group.pow_eq_pow_iff_eq_of_order_infinite _ _ _ h at hab,
      exact hab },
    apply enat.card_eq_top_of_infinite },
  { unfold order at h,
    have exists_order := mt (enat.find_eq_top_iff _).mpr h,
    push_neg at exists_order,
    have order_dom := enat.find_dom _ exists_order,
    let o := (order x).get order_dom,
    rw ← singleton_generated_subgroup_eq,
    have order_rw : order x = enat.some o := by rw ← enat.get_eq_iff_eq_some,
    rw singleton_generated_subgroup_eq_finite order_rw,
    rw enat.card_eq_coe_fintype_card,
    rw order_rw,
    rw enat.some_eq_coe,
    simp }
end

@[to_additive]
lemma mul_generator_order_eq_card_of_finite [group G] [fintype G] (h : is_mul_cyclic G) :
group.order_of_finite h.fst = nat.card G :=
begin
  unfold group.order_of_finite,
  have := singleton_generated_subgroup_card_eq_order h.fst,
  have h_snd : ⟪{h.fst}⟫ = (subgroup.univ : subgroup G) := h.snd,
  rw h_snd at this,
  simp at this ⊢,
  rw enat.get_eq_iff_eq_coe,
  rw ← this,
  simp,
  rw fintype.card_eq,
  refine ⟨_⟩,
  apply equiv.subtype_univ_equiv,
  simp
end

@[to_additive]
lemma mul_generator_infinite_order_of_infinite [group G] [infinite G] (h : is_mul_cyclic G) :
group.order h.fst = ⊤ :=
begin
  unfold order,
  rw enat.find_eq_top_iff,
  intro n,
  apply nat.case_strong_induction_on n; clear n,
  { simp },
  rintros n hn₁ hn₂,
  have lt_find := enat.lt_find (λ m, 0 < m ∧ h.fst ^ m = 1) n hn₁,
  have find_le := enat.find_le (λ m, 0 < m ∧ h.fst ^ m = 1) n.succ hn₂,
  have eq_order : ↑(n.succ) = enat.find (λ m, 0 < m ∧ h.fst ^ m = 1),
  { have := enat.add_one_le_of_lt lt_find,
    simp at find_le ⊢,
    exact le_antisymm this find_le },
  change ↑(n.succ) = group.order h.fst at eq_order,
  rw ← enat.some_eq_coe at eq_order,
  have := singleton_generated_subgroup_eq_finite eq_order.symm,
  have h_snd : ⟪{h.fst}⟫ = _ := h.snd,
  rw h_snd at this,
  refine @fintype.false G _ (set.fintype_of_univ_finite _),
  rw subgroup.univ_def at this,
  rw this,
  simp,
  refine set.finite.image _ _,
  rw finset.coe_fin_range,
  exact @set.finite_univ _ (fin.fintype _)
end

@[to_additive]
theorem mul_generator_order_eq_group_order [group G] (h : is_mul_cyclic G) :
group.order h.fst = enat.card G :=
begin
  by_cases htop : enat.card G = ⊤,
  { rw htop,
    haveI : infinite G,
    { split, intro h,
      rw @enat.card_eq_coe_fintype_card _ h at htop,
      exact enat.coe_ne_top _ htop },
    apply mul_generator_infinite_order_of_infinite },
  { haveI : fintype G,
    { apply fintype_of_not_infinite,
      intro inf,
      exact htop (@enat.card_eq_top_of_infinite _ inf) },
    change _ ≠ ⊤ at htop,
    rw enat.ne_top_iff at htop,
    obtain ⟨n, hn⟩ := htop,
    rw hn,
    rw enat.card_eq_coe_fintype_card at hn,
    have := mul_generator_order_eq_card_of_finite h,
    rw nat.card_eq_fintype_card at this,
    rw ← this at hn,
    rw ← hn,
    unfold order_of_finite,
    simp }
end

noncomputable def iso_cyclic_of_is_cyclic_of_finite [add_group G] [fintype G] (h : is_add_cyclic G) :
cyclic_group (add_group.order_of_finite h.fst) (add_group.zero_lt_order_finite h.fst) ≅+ G :=
begin
  let x := h.fst,
  let n := add_group.order_of_finite h.fst,
  refine ⟨⟨λ k, k.val • x, _⟩, _, _⟩,
  { intros a b,
    rw cyclic_group.add_def,
    rw ← add_group.add_nat_nsmul,
    rw ← add_group.neg_neg ((a.val + b.val) • x),
    apply add_group.eq_neg_of_add_eq_zero,
    rw ← add_group.nsmul_int_coe,
    rw ← add_group.nsmul_int_coe,
    rw add_group.neg_nsmul_eq_nsmul_neg,
    rw ← add_group.add_int_nsmul,
    have : (n : ℤ) ∣ ↑((a.val + b.val) % n) + -↑(a.val + b.val),
    { apply int.dvd_of_mod_eq_zero,
      simp,
      rw ← int.add_assoc,
      simp },
    obtain ⟨c, hc⟩ := exists_eq_mul_left_of_dvd this,
    rw hc,
    rw int.mul_comm,
    rw ← add_group.nsmul_nsmul,
    rw add_group.nsmul_int_coe,
    rw add_group.eq_zero_of_nsmul_order,
    { apply add_group.nsmul_zero_int },
    { rw add_group.order_eq_some_order_of_finite } },
  { intros a b g,
    dsimp at g,
    refine cyclic_group.eq_of_modeq _,
    apply nat.modeq_of_dvd,
    refine (add_group.eq_zero_iff_int_nsmul_order_dvd (add_group.order_eq_some_order_of_finite x)).mpr _,
    rw add_group.sub_int_nsmul,
    simp,
    rw cyclic_group.coe_eq_val,
    rw cyclic_group.coe_eq_val,
    rw g,
    simp },
  { intro y,
    dsimp,
    obtain ⟨k, hk⟩ := exists_eq_nsmul_of_add_cyclic h y,
    have : y = (int.to_nat (k % n)) • h.fst,
    { rw hk,
      apply add_group.eq_of_add_neg_eq_zero,
      rw ← add_group.nsmul_int_coe,
      rw add_group.neg_nsmul_eq_nsmul_neg,
      rw ← add_group.add_int_nsmul,
      rw ← add_group.eq_zero_iff_int_nsmul_order_dvd (add_group.order_eq_some_order_of_finite x),
      change ↑n ∣ k + -↑((k % ↑n).to_nat),
      rw int.dvd_iff_mod_eq_zero,
      rw ← int.sub_eq_add_neg,
      rw int.sub_mod,
      rw int.to_nat_of_nonneg,
      simp,
      apply int.mod_nonneg,
      exact (add_group.zero_ne_order_finite_int x).symm },
    refine ⟨⟨int.to_nat (k % n), _⟩, _⟩,
    { apply int.lt_of_coe_nat_lt_coe_nat,
      rw int.to_nat_of_nonneg,
      { apply int.mod_lt_of_pos,
        exact add_group.zero_lt_order_finite_int x },
      { apply int.mod_nonneg,
        exact (add_group.zero_ne_order_finite_int x).symm } },
    rw this }
end

-- Infinite cyclic groups

def iso_int_of_is_cyclic_of_infinite [add_group G] [infinite G] (h : is_add_cyclic G) : ℤ ≅+ G :=
begin
  let x := h.fst,
  refine ⟨⟨(• x), _⟩, _, _⟩,
  { intros a b,
    rw add_group.add_int_nsmul },
  { intros a b hab,
    simp at hab,
    have := add_generator_infinite_order_of_infinite h,
    have := add_group.nsmul_eq_nsmul_iff_eq_of_infinite_order this a b,
    exact this.mp hab },
  { intro y,
    simp,
    have := singleton_generated_add_subgroup_elements x y,
    have h_snd : _ = _ := h.snd,
    rw h_snd at this,
    simp at this,
    obtain ⟨n, hn⟩ := this,
    refine ⟨n, hn.symm⟩ }
end

theorem iso_cyclic_or_int_of_is_add_cyclic [add_group G] (h : is_add_cyclic G) :
(∃ n n_pos, cyclic_group n n_pos ∃≅+ G) ∨ (ℤ ∃≅+ G) :=
begin
  rcases fintype_or_infinite G,
  { left,
    haveI := val,
    obtain ⟨x, hx⟩ := h,
    refine ⟨add_group.order_of_finite x, add_group.zero_lt_order_finite _, _⟩,
    split,
    apply iso_cyclic_of_is_cyclic_of_finite ⟨x, hx⟩ },
  { right,
    split,
    apply @iso_int_of_is_cyclic_of_infinite _ _ val h },
end

end notes


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.algebra.tower
import linear_algebra.prod
import linear_algebra.finsupp
import algebra.algebra.operations

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of subalgebras of an R-algebra generated
by a set of elements. A basic interface for `adjoin` is set up.

## Tags

adjoin, algebra

-/

universes u v w

open_locale pointwise
open submodule subsemiring

variables {R : Type u} {A : Type v} {B : Type w}

namespace algebra

section semiring
variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B] {s t : set A}

theorem subset_adjoin : s ⊆ adjoin R s :=
algebra.gc.le_u_l s

theorem adjoin_le {S : subalgebra R A} (H : s ⊆ S) : adjoin R s ≤ S :=
algebra.gc.l_le H

lemma adjoin_eq_Inf : adjoin R s = Inf {p | s ⊆ p} :=
le_antisymm (le_Inf (λ _ h, adjoin_le h)) (Inf_le subset_adjoin)

theorem adjoin_le_iff {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ S:=
algebra.gc _ _

theorem adjoin_mono (H : s ⊆ t) : adjoin R s ≤ adjoin R t :=
algebra.gc.monotone_l H

theorem adjoin_eq_of_le (S : subalgebra R A) (h₁ : s ⊆ S) (h₂ : S ≤ adjoin R s) : adjoin R s = S :=
le_antisymm (adjoin_le h₁) h₂

theorem adjoin_eq (S : subalgebra R A) : adjoin R ↑S = S :=
adjoin_eq_of_le _ (set.subset.refl _) subset_adjoin

lemma adjoin_Union {α : Type*} (s : α → set A) :
  adjoin R (set.Union s) = ⨆ (i : α), adjoin R (s i) :=
(@algebra.gc R A _ _ _).l_supr

lemma adjoin_attach_bUnion [decidable_eq A] {α : Type*} {s : finset α} (f : s → finset A) :
  adjoin R (s.attach.bUnion f : set A) = ⨆ x, adjoin R (f x) :=
by simpa [adjoin_Union]

@[elab_as_eliminator] theorem adjoin_induction {p : A → Prop} {x : A} (h : x ∈ adjoin R s)
  (Hs : ∀ x ∈ s, p x)
  (Halg : ∀ r, p (algebra_map R A r))
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
let S : subalgebra R A :=
{ carrier := p, mul_mem' := Hmul, add_mem' := Hadd, algebra_map_mem' := Halg } in
adjoin_le (show s ≤ S, from Hs) h

/-- Induction principle for the algebra generated by a set `s`: show that `p x y` holds for any
`x y ∈ adjoin R s` given that that it holds for `x y ∈ s` and that it satisfies a number of
natural properties. -/
@[elab_as_eliminator]
lemma adjoin_induction₂ {p : A → A → Prop} {a b : A} (ha : a ∈ adjoin R s) (hb : b ∈ adjoin R s)
  (Hs : ∀ (x ∈ s) (y ∈ s), p x y)
  (Halg : ∀ r₁ r₂, p (algebra_map R A r₁) (algebra_map R A r₂))
  (Halg_left : ∀ r (x ∈ s), p (algebra_map R A r) x)
  (Halg_right : ∀ r (x ∈ s), p x (algebra_map R A r))
  (Hadd_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ + x₂) y)
  (Hadd_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ + y₂))
  (Hmul_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ * x₂) y)
  (Hmul_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ * y₂)) : p a b :=
begin
  refine adjoin_induction hb _ (λ r, _) (Hadd_right a) (Hmul_right a),
  { exact adjoin_induction ha Hs Halg_left (λ x y Hx Hy z hz, Hadd_left x y z (Hx z hz) (Hy z hz))
      (λ x y Hx Hy z hz, Hmul_left x y z (Hx z hz) (Hy z hz)) },
  { exact adjoin_induction ha (Halg_right r) (λ r', Halg r' r)
      (λ x y, Hadd_left x y ((algebra_map R A) r))
      (λ x y, Hmul_left x y ((algebra_map R A) r)) },
end

/-- The difference with `algebra.adjoin_induction` is that this acts on the subtype. -/
lemma adjoin_induction' {p : adjoin R s → Prop} (Hs : ∀ x (h : x ∈ s), p ⟨x, subset_adjoin h⟩)
  (Halg : ∀ r, p (algebra_map R _ r)) (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) (x : adjoin R s) : p x :=
subtype.rec_on x $ λ x hx, begin
  refine exists.elim _ (λ (hx : x ∈ adjoin R s) (hc : p ⟨x, hx⟩), hc),
  exact adjoin_induction hx (λ x hx, ⟨subset_adjoin hx, Hs x hx⟩)
    (λ r, ⟨subalgebra.algebra_map_mem _ r, Halg r⟩)
    (λ x y hx hy, exists.elim hx $ λ hx' hx, exists.elim hy $ λ hy' hy,
    ⟨subalgebra.add_mem _ hx' hy', Hadd _ _ hx hy⟩) (λ x y hx hy, exists.elim hx $ λ hx' hx,
    exists.elim hy $ λ hy' hy, ⟨subalgebra.mul_mem _ hx' hy', Hmul _ _ hx hy⟩),
end

@[simp] lemma adjoin_adjoin_coe_preimage {s : set A} :
  adjoin R ((coe : adjoin R s → A) ⁻¹' s) = ⊤ :=
begin
  refine eq_top_iff.2 (λ x, adjoin_induction' (λ a ha, _) (λ r, _) (λ _ _, _) (λ _ _, _) x),
  { exact subset_adjoin ha },
  { exact subalgebra.algebra_map_mem _ r },
  { exact subalgebra.add_mem _ },
  { exact subalgebra.mul_mem _ }
end

lemma adjoin_union (s t : set A) : adjoin R (s ∪ t) = adjoin R s ⊔ adjoin R t :=
(algebra.gc : galois_connection _ (coe : subalgebra R A → set A)).l_sup

variables (R A)
@[simp] theorem adjoin_empty : adjoin R (∅ : set A) = ⊥ :=
show adjoin R ⊥ = ⊥, by { apply galois_connection.l_bot, exact algebra.gc }

@[simp] theorem adjoin_univ : adjoin R (set.univ : set A) = ⊤ :=
eq_top_iff.2 $ λ x, subset_adjoin $ set.mem_univ _

variables (R) {A} (s)

theorem adjoin_eq_span : (adjoin R s).to_submodule = span R (submonoid.closure s) :=
begin
  apply le_antisymm,
  { intros r hr, rcases subsemiring.mem_closure_iff_exists_list.1 hr with ⟨L, HL, rfl⟩, clear hr,
    induction L with hd tl ih, { exact zero_mem _ },
    rw list.forall_mem_cons at HL,
    rw [list.map_cons, list.sum_cons],
    refine submodule.add_mem _ _ (ih HL.2),
    replace HL := HL.1, clear ih tl,
    suffices : ∃ z r (hr : r ∈ submonoid.closure s), has_smul.smul z r = list.prod hd,
    { rcases this with ⟨z, r, hr, hzr⟩, rw ← hzr,
      exact smul_mem _ _ (subset_span hr) },
    induction hd with hd tl ih, { exact ⟨1, 1, (submonoid.closure s).one_mem', one_smul _ _⟩ },
    rw list.forall_mem_cons at HL,
    rcases (ih HL.2) with ⟨z, r, hr, hzr⟩, rw [list.prod_cons, ← hzr],
    rcases HL.1 with ⟨hd, rfl⟩ | hs,
    { refine ⟨hd * z, r, hr, _⟩,
      rw [algebra.smul_def, algebra.smul_def, (algebra_map _ _).map_mul, _root_.mul_assoc] },
    { exact ⟨z, hd * r, submonoid.mul_mem _ (submonoid.subset_closure hs) hr,
        (mul_smul_comm _ _ _).symm⟩ } },
  refine span_le.2 _,
  change submonoid.closure s ≤ (adjoin R s).to_subsemiring.to_submonoid,
  exact submonoid.closure_le.2 subset_adjoin
end

lemma span_le_adjoin (s : set A) : span R s ≤ (adjoin R s).to_submodule :=
span_le.mpr subset_adjoin

lemma adjoin_to_submodule_le {s : set A} {t : submodule R A} :
  (adjoin R s).to_submodule ≤ t ↔ ↑(submonoid.closure s) ⊆ (t : set A) :=
by rw [adjoin_eq_span, span_le]

lemma adjoin_eq_span_of_subset {s : set A} (hs : ↑(submonoid.closure s) ⊆ (span R s : set A)) :
  (adjoin R s).to_submodule = span R s :=
le_antisymm ((adjoin_to_submodule_le R).mpr hs) (span_le_adjoin R s)

@[simp] lemma adjoin_span {s : set A} :
  adjoin R (submodule.span R s : set A) = adjoin R s :=
le_antisymm (adjoin_le (span_le_adjoin _ _)) (adjoin_mono submodule.subset_span)

lemma adjoin_image (f : A →ₐ[R] B) (s : set A) :
  adjoin R (f '' s) = (adjoin R s).map f :=
le_antisymm (adjoin_le $ set.image_subset _ subset_adjoin) $
subalgebra.map_le.2 $ adjoin_le $ set.image_subset_iff.1 subset_adjoin

@[simp] lemma adjoin_insert_adjoin (x : A) :
  adjoin R (insert x ↑(adjoin R s)) = adjoin R (insert x s) :=
le_antisymm
  (adjoin_le (set.insert_subset.mpr
    ⟨subset_adjoin (set.mem_insert _ _), adjoin_mono (set.subset_insert _ _)⟩))
  (algebra.adjoin_mono (set.insert_subset_insert algebra.subset_adjoin))

lemma adjoin_prod_le (s : set A) (t : set B) :
  adjoin R (s ×ˢ t) ≤ (adjoin R s).prod (adjoin R t) :=
adjoin_le $ set.prod_mono subset_adjoin subset_adjoin

lemma mem_adjoin_of_map_mul {s} {x : A} {f : A →ₗ[R] B} (hf : ∀ a₁ a₂, f(a₁ * a₂) = f a₁ * f a₂)
  (h : x ∈ adjoin R s) : f x ∈ adjoin R (f '' (s ∪ {1})) :=
begin
  refine @adjoin_induction R A _ _ _ _ (λ a, f a ∈ adjoin R (f '' (s ∪ {1}))) x h
    (λ a ha, subset_adjoin ⟨a, ⟨set.subset_union_left _ _ ha, rfl⟩⟩)
    (λ r, _)
    (λ y z hy hz, by simpa [hy, hz] using subalgebra.add_mem _ hy hz)
    (λ y z hy hz, by simpa [hy, hz, hf y z] using subalgebra.mul_mem _ hy hz),
  have : f 1 ∈ adjoin R (f '' (s ∪ {1})) :=
  subset_adjoin ⟨1, ⟨set.subset_union_right _ _ $ set.mem_singleton 1, rfl⟩⟩,
  replace this := subalgebra.smul_mem (adjoin R (f '' (s ∪ {1}))) this r,
  convert this,
  rw algebra_map_eq_smul_one,
  exact f.map_smul _ _
end

lemma adjoin_inl_union_inr_eq_prod (s) (t) :
  adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})) =
    (adjoin R s).prod (adjoin R t) :=
begin
  apply le_antisymm,
  { simp only [adjoin_le_iff, set.insert_subset, subalgebra.zero_mem, subalgebra.one_mem,
      subset_adjoin, -- the rest comes from `squeeze_simp`
      set.union_subset_iff, linear_map.coe_inl, set.mk_preimage_prod_right,
      set.image_subset_iff, set_like.mem_coe, set.mk_preimage_prod_left, linear_map.coe_inr,
      and_self, set.union_singleton, subalgebra.coe_prod] },
  { rintro ⟨a, b⟩ ⟨ha, hb⟩,
    let P := adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})),
    have Ha : (a, (0 : B)) ∈ adjoin R ((linear_map.inl R A B) '' (s ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inl_map_mul) ha,
    have Hb : ((0 : A), b) ∈ adjoin R ((linear_map.inr R A B) '' (t ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inr_map_mul) hb,
    replace Ha : (a, (0 : B)) ∈ P := adjoin_mono (set.subset_union_left _ _) Ha,
    replace Hb : ((0 : A), b) ∈ P := adjoin_mono (set.subset_union_right _ _) Hb,
    simpa using subalgebra.add_mem _ Ha Hb }
end

/-- If all elements of `s : set A` commute pairwise, then `adjoin R s` is a commutative
semiring.  -/
def adjoin_comm_semiring_of_comm {s : set A} (hcomm : ∀ (a ∈ s) (b ∈ s), a * b = b * a) :
  comm_semiring (adjoin R s) :=
{ mul_comm := λ x y,
  begin
    ext,
    simp only [subalgebra.coe_mul],
    exact adjoin_induction₂ x.prop y.prop
      hcomm
      (λ _ _, by rw [commutes])
      (λ r x hx, commutes r x) (λ r x hx, (commutes r x).symm)
      (λ _ _ _ h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
      (λ _ _ _ h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
      (λ x₁ x₂ y₁ h₁ h₂, by rw [mul_assoc, h₂, ←mul_assoc y₁, ←h₁, mul_assoc x₁])
      (λ x₁ x₂ y₁ h₁ h₂, by rw [mul_assoc x₂, ←h₂, ←mul_assoc x₂, ←h₁, ←mul_assoc])
  end,
  ..(adjoin R s).to_semiring }

lemma adjoin_singleton_one : adjoin R ({1} : set A) = ⊥ :=
eq_bot_iff.2 $ adjoin_le $ set.singleton_subset_iff.2 $ set_like.mem_coe.2 $ one_mem _

lemma self_mem_adjoin_singleton (x : A) : x ∈ adjoin R ({x} : set A) :=
algebra.subset_adjoin (set.mem_singleton_iff.mpr rfl)

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A]
variables [algebra R A] {s t : set A}

variables (R s t)
theorem adjoin_union_eq_adjoin_adjoin :
  adjoin R (s ∪ t) = (adjoin (adjoin R s) t).restrict_scalars R :=
le_antisymm
  (closure_mono $ set.union_subset
    (set.range_subset_iff.2 $ λ r, or.inl ⟨algebra_map R (adjoin R s) r, rfl⟩)
    (set.union_subset_union_left _ $ λ x hxs, ⟨⟨_, subset_adjoin hxs⟩, rfl⟩))
  (closure_le.2 $ set.union_subset
    (set.range_subset_iff.2 $ λ x, adjoin_mono (set.subset_union_left _ _) x.2)
    (set.subset.trans (set.subset_union_right _ _) subset_adjoin))

theorem adjoin_union_coe_submodule : (adjoin R (s ∪ t)).to_submodule =
  (adjoin R s).to_submodule * (adjoin R t).to_submodule :=
begin
  rw [adjoin_eq_span, adjoin_eq_span, adjoin_eq_span, span_mul_span],
  congr' 1 with z, simp [submonoid.closure_union, submonoid.mem_sup, set.mem_mul]
end

lemma pow_smul_mem_adjoin_smul (r : R) (s : set A) {x : A} (hx : x ∈ adjoin R s) :
  ∃ n₀ : ℕ, ∀ n ≥ n₀, r ^ n • x ∈ adjoin R (r • s) :=
begin
  change x ∈ (adjoin R s).to_submodule at hx,
  rw [adjoin_eq_span, finsupp.mem_span_iff_total] at hx,
  rcases hx with ⟨l, rfl : l.sum (λ (i : submonoid.closure s) (c : R), c • ↑i) = x⟩,
  choose n₁ n₂ using (λ x : submonoid.closure s, submonoid.pow_smul_mem_closure_smul r s x.prop),
  use l.support.sup n₁,
  intros n hn,
  rw finsupp.smul_sum,
  refine (adjoin R (r • s)).to_submodule.sum_mem _,
  intros a ha,
  have : n ≥ n₁ a := le_trans (finset.le_sup ha) hn,
  dsimp only,
  rw [← tsub_add_cancel_of_le this, pow_add, ← smul_smul, smul_smul _ (l a), mul_comm,
    ← smul_smul, adjoin_eq_span],
  refine submodule.smul_mem _ _ _,
  exact submodule.smul_mem _ _ (submodule.subset_span (n₂ a))
end

end comm_semiring

section ring
variables [comm_ring R] [ring A]
variables [algebra R A] {s t : set A}
variables {R s t}

theorem adjoin_int (s : set R) : adjoin ℤ s = subalgebra_of_subring (subring.closure s) :=
le_antisymm (adjoin_le subring.subset_closure)
  (subring.closure_le.2 subset_adjoin : subring.closure s ≤ (adjoin ℤ s).to_subring)

theorem mem_adjoin_iff {s : set A} {x : A} :
  x ∈ adjoin R s ↔ x ∈ subring.closure (set.range (algebra_map R A) ∪ s) :=
⟨λ hx, subsemiring.closure_induction hx subring.subset_closure (subring.zero_mem _)
  (subring.one_mem _) (λ _ _, subring.add_mem _) ( λ _ _, subring.mul_mem _),
  suffices subring.closure (set.range ⇑(algebra_map R A) ∪ s) ≤ (adjoin R s).to_subring,
    from @this x, subring.closure_le.2 subsemiring.subset_closure⟩

theorem adjoin_eq_ring_closure (s : set A) :
  (adjoin R s).to_subring = subring.closure (set.range (algebra_map R A) ∪ s) :=
subring.ext $ λ x, mem_adjoin_iff

variables (R)

/-- If all elements of `s : set A` commute pairwise, then `adjoin R s` is a commutative
ring.  -/
def adjoin_comm_ring_of_comm {s : set A} (hcomm : ∀ (a ∈ s) (b ∈ s), a * b = b * a) :
  comm_ring (adjoin R s) :=
{ ..(adjoin R s).to_ring,
  ..adjoin_comm_semiring_of_comm R hcomm }

end ring

end algebra

open algebra subalgebra

namespace alg_hom

variables [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]

lemma map_adjoin (φ : A →ₐ[R] B) (s : set A) :
  (adjoin R s).map φ = adjoin R (φ '' s) :=
(adjoin_image _ _ _).symm

lemma adjoin_le_equalizer (φ₁ φ₂ : A →ₐ[R] B) {s : set A} (h : s.eq_on φ₁ φ₂) :
  adjoin R s ≤ φ₁.equalizer φ₂ :=
adjoin_le h

lemma ext_of_adjoin_eq_top {s : set A} (h : adjoin R s = ⊤) ⦃φ₁ φ₂ : A →ₐ[R] B⦄
  (hs : s.eq_on φ₁ φ₂) : φ₁ = φ₂ :=
ext $ λ x, adjoin_le_equalizer φ₁ φ₂ hs $ h.symm ▸ trivial

end alg_hom


import ground_zero.HITs.ntrunc
open ground_zero.types.eq (pointed)
open ground_zero.structures (hset)

hott theory

namespace ground_zero.algebra

universes u v
class magma (α : Type u) :=
(m : α → α → α)

class pointed_magma (α : Type u) extends magma α :=
(e : α)

class monoid (α : Type u) :=
(truncation : hset α)
(mul : α → α → α) (e : α)
(left_unit : Π (x : α), mul x e = x)
(right_unit : Π (x : α), mul e x = x)
(assoc : Π (x y z : α), mul x (mul y z) = mul (mul x y) z)

infix ` · `:70 := monoid.mul

class group (α : Type u) extends monoid α :=
(inv : α → α)
(left_inv : Π (x : α), x · (inv x) = e)
(right_inv : Π (x : α), (inv x) · x = e)

def e {α : Type u} [group α] : α := monoid.e α

theorem group_unit_is_unique {α : Type u} [group α] (e' : α)
  (left_unit' : Π x, x · e' = x)
  (right_unit' : Π x, e' · x = x)
  (H : e = e' → empty) : empty := begin
  have p := monoid.left_unit e',
  have q := right_unit' e,
  exact H (q⁻¹ ⬝ p)
end

section
  variables {α : Type u} {β : Type v} [group α] [group β]

  def is_homo (φ : α → β) :=
  Π a b, φ (a · b) = φ a · φ b

  def Ker (φ : α → β) (H : is_homo φ) := Σ g, φ g = e
  def Im (φ : α → β) (H : is_homo φ) := Σ g f, φ g = f
end

prefix ⁻¹ := group.inv

--def homotopy_group (X : pointed) (n : ℕ) := ∥Ω[n], X∥₀
--notation `π[` n `]` `, ` X := homotopy_group X n

end ground_zero.algebra


import Mathlib.Data.Nat.Basic
import Mathlib.Tactic.GeneralizeProofs
import Std.Tactic.GuardExpr
import Mathlib.Tactic.LibrarySearch

def List.nthLe (l : List α) (n) (h : n < l.length) : α := sorry

example : List.nthLe [1, 2] 1 (by simp) = 2 := by
  -- ⊢ [1 2].nth_le 1 _ = 2
  generalize_proofs h
  -- h : 1 < [1 2].length
  -- ⊢ [1 2].nth_le 1 h = 2
  sorry

example (x : ℕ) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2 :=
by
  generalize_proofs a
  guard_hyp a : ∃ x, x < 2
  guard_target = Classical.choose a < 2
  exact Classical.choose_spec a

example (x : ℕ) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, h⟩ : ∃ x, x < 2) :=
by
  generalize_proofs a
  guard_hyp a : ∃ x, x < 2
  guard_target = Classical.choose a = Classical.choose a
  rfl

example (x : ℕ) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) =
  Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) :=
by
  generalize_proofs a
  guard_hyp a : ∃ x, x < 2
  guard_target = Classical.choose a = Classical.choose _
  sorry

example (x : ℕ) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) =
  Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) :=
by
  generalize_proofs
  guard_target = Classical.choose _ = Classical.choose _
  sorry

example (x : ℕ) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) =
  Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) :=
by
  generalize_proofs _ a
  guard_hyp a : ∃ x, x < 3
  guard_target = Classical.choose _ = Classical.choose a
  sorry

example (a : ∃ x, x < 2) : Classical.choose a < 2 :=
by
  generalize_proofs
  guard_target = Classical.choose a < 2
  exact Classical.choose_spec a

example (a : ∃ x, x < 2) : Classical.choose a < 2 :=
by
  generalize_proofs t
  guard_target = Classical.choose a < 2
  exact Classical.choose_spec a

example (x : ℕ) (h : x < 2) (H : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2) :
  Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2 :=
by
  generalize_proofs a at H ⊢
  guard_hyp a : ∃ x, x < 2
  guard_hyp H : Classical.choose a < 2
  guard_target = Classical.choose a < 2
  exact H

-- FIXME: result is not type correct
-- example (H : ∀ y, ∃ (x : ℕ) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y) :
--   ∀ y, ∃ (x : ℕ) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y := by
--   generalize_proofs a at H ⊢

attribute [local instance] Classical.propDecidable

example (H : ∀ x, x = 1) : (if h : ∃ (k : ℕ), k = 1 then Classical.choose h else 0) = 1 :=
by
  rw [dif_pos]
  rotate_left
  { exact ⟨1, rfl⟩ }
  generalize_proofs h g
  guard_target = Classical.choose h = 1
  apply H


import analysis.real
import data.nat.prime data.int.modeq data.complex.basic algebra.euclidean_domain number_theory.pell data.pnat

open nat
-- Questions:
 -- Find the continued fraction expansions of the following rational numbers:
-- 69/40

--theorem q1a:
 -- 233/144

--theorem q1b:
 -- 507/414

--theorem q1c:
 -- Define the Fibonacci numbers F(n) by F₁ = F₂ = 1, F(n+1) = F(n) + F(n-1) for i ≥ 2. Describe, for all n > 1, the continued fraction expansion of F(n)/F(n-1).

--theorem q2a:
 -- Find the continued fraction expansion of (1+sqrt(5))/2.

--theorem q2b:
 -- Show that the limit, as n goes to infinity, of F(n)/F(n-1) is (1+sqrt(5))/2.

--theorem q2c:
 -- Show that a positive integer n is expressible as x^2 - xy + y^2, with x and y integers, if and only if for every prime p congruent to 2 mod 3, the exponent of p in the prime factorization of n is even.
-- [Hint: Use unique factorization in the Eisenstein integers.]

theorem q3a (n p k : ℕ) (x y : ℤ) (hq: prime p) (hp: p ≡ 2 [MOD 3]): n = x^2 -x*y + y^2 ↔ ((p ∣ n ∧ p^k ∣ n) → k ≡ 0 [MOD 2]) := sorry
 -- Find x and y such that x^2 - xy + y^2 = 91.

--theorem q3b:
 -- Find all solutions to the equation x^2 - 10 y^2 = 1. Explicitly list all the solutions with x < 200 and x,y > 0.

--theorem q4a:
 -- Find all solutions to the equation x^2 - 10 y^2 = -1.

--theorem q4b:
 -- Find the value of the continued fraction [1;2,2,2,...].

--theorem q5a:
 -- Find the value of the continued fraction [1;3,5,1,3,5,...].

--theorem q5b:
 -- Show that, for n an integer, we have sqrt(n^2+1) = [n;2n,2n,2n,...].

--theorem q6a:
 -- Show that, for n an integer, we have sqrt(n^2+2) = [n;n,2n,n,2n,...].

--theorem q6b:


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri, Yury Kudryashov
-/

import geometry.manifold.cont_mdiff_map

/-!
# Diffeomorphisms
This file implements diffeomorphisms.

## Definitions

* `diffeomorph I I' M M' n`:  `n`-times continuously differentiable diffeomorphism between
  `M` and `M'` with respect to I and I'; we do not introduce a separate definition for the case
  `n = ∞`; we use notation instead.
* `diffeomorph.to_homeomorph`: reinterpret a diffeomorphism as a homeomorphism.
* `continuous_linear_equiv.to_diffeomorph`: reinterpret a continuous equivalence as
  a diffeomorphism.
* `model_with_corners.trans_diffeomorph`: compose a given `model_with_corners` with a diffeomorphism
  between the old and the new target spaces. Useful, e.g, to turn any finite dimensional manifold
  into a manifold modelled on a Euclidean space.
* `diffeomorph.to_trans_diffeomorph`: the identity diffeomorphism between `M` with model `I` and `M`
  with model `I.trans_diffeomorph e`.

## Notations

* `M ≃ₘ^n⟮I, I'⟯ M'`  := `diffeomorph I J M N n`
* `M ≃ₘ⟮I, I'⟯ M'`    := `diffeomorph I J M N ⊤`
* `E ≃ₘ^n[𝕜] E'`      := `E ≃ₘ^n⟮𝓘(𝕜, E), 𝓘(𝕜, E')⟯ E'`
* `E ≃ₘ[𝕜] E'`        := `E ≃ₘ⟮𝓘(𝕜, E), 𝓘(𝕜, E')⟯ E'`

## Implementation notes

This notion of diffeomorphism is needed although there is already a notion of structomorphism
because structomorphisms do not allow the model spaces `H` and `H'` of the two manifolds to be
different, i.e. for a structomorphism one has to impose `H = H'` which is often not the case in
practice.

## Keywords

diffeomorphism, manifold
-/

open_locale manifold topology
open function set

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
{E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
{E' : Type*} [normed_add_comm_group E'] [normed_space 𝕜 E']
{F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
{H : Type*} [topological_space H]
{H' : Type*} [topological_space H']
{G : Type*} [topological_space G]
{G' : Type*} [topological_space G']
{I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'}
{J : model_with_corners 𝕜 F G} {J' : model_with_corners 𝕜 F G'}

variables {M : Type*} [topological_space M] [charted_space H M]
{M' : Type*} [topological_space M'] [charted_space H' M']
{N : Type*} [topological_space N] [charted_space G N]
{N' : Type*} [topological_space N'] [charted_space G' N']
{n : ℕ∞}

section defs

variables (I I' M M' n)

/--
`n`-times continuously differentiable diffeomorphism between `M` and `M'` with respect to I and I'
-/
@[protect_proj, nolint has_nonempty_instance]
structure diffeomorph extends M ≃ M' :=
(cont_mdiff_to_fun  : cont_mdiff I I' n to_equiv)
(cont_mdiff_inv_fun : cont_mdiff I' I n to_equiv.symm)

end defs

localized "notation (name := diffeomorph) M ` ≃ₘ^` n:1000 `⟮`:50 I `, ` J `⟯ ` N :=
  diffeomorph I J M N n" in manifold
localized "notation (name := diffeomorph.top) M ` ≃ₘ⟮` I `, ` J `⟯ ` N :=
  diffeomorph I J M N ⊤" in manifold
localized "notation (name := diffeomorph.self) E ` ≃ₘ^` n:1000 `[`:50 𝕜 `] ` E' :=
  diffeomorph (model_with_corners_self 𝕜 E) (model_with_corners_self 𝕜 E') E E' n" in manifold
localized "notation (name := diffeomorph.self.top) E ` ≃ₘ[` 𝕜 `] ` E' :=
  diffeomorph (model_with_corners_self 𝕜 E) (model_with_corners_self 𝕜 E') E E' ⊤" in manifold

namespace diffeomorph
instance : has_coe_to_fun (M ≃ₘ^n⟮I, I'⟯ M') (λ _, M → M') := ⟨λe, e.to_equiv⟩

instance : has_coe (M ≃ₘ^n⟮I, I'⟯ M') C^n⟮I, M; I', M'⟯ := ⟨λ Φ, ⟨Φ, Φ.cont_mdiff_to_fun⟩⟩

@[continuity] protected lemma continuous (h : M ≃ₘ^n⟮I, I'⟯ M') : continuous h :=
h.cont_mdiff_to_fun.continuous
protected lemma cont_mdiff (h : M ≃ₘ^n⟮I, I'⟯ M') : cont_mdiff I I' n h :=
h.cont_mdiff_to_fun
protected lemma cont_mdiff_at (h : M ≃ₘ^n⟮I, I'⟯ M') {x} : cont_mdiff_at I I' n h x :=
h.cont_mdiff.cont_mdiff_at
protected lemma cont_mdiff_within_at (h : M ≃ₘ^n⟮I, I'⟯ M') {s x} :
  cont_mdiff_within_at I I' n h s x :=
h.cont_mdiff_at.cont_mdiff_within_at
protected lemma cont_diff (h : E ≃ₘ^n[𝕜] E') : cont_diff 𝕜 n h :=
h.cont_mdiff.cont_diff
protected lemma smooth (h : M ≃ₘ⟮I, I'⟯ M') : smooth I I' h := h.cont_mdiff_to_fun
protected lemma mdifferentiable (h : M ≃ₘ^n⟮I, I'⟯ M') (hn : 1 ≤ n) : mdifferentiable I I' h :=
h.cont_mdiff.mdifferentiable hn
protected lemma mdifferentiable_on (h : M ≃ₘ^n⟮I, I'⟯ M') (s : set M) (hn : 1 ≤ n) :
  mdifferentiable_on I I' h s :=
(h.mdifferentiable hn).mdifferentiable_on

@[simp] lemma coe_to_equiv (h : M ≃ₘ^n⟮I, I'⟯ M') : ⇑h.to_equiv = h := rfl
@[simp, norm_cast] lemma coe_coe (h : M ≃ₘ^n⟮I, I'⟯ M') : ⇑(h : C^n⟮I, M; I', M'⟯) = h := rfl

lemma to_equiv_injective : injective (diffeomorph.to_equiv : (M ≃ₘ^n⟮I, I'⟯ M') → (M ≃ M'))
| ⟨e, _, _⟩ ⟨e', _, _⟩ rfl := rfl

@[simp] lemma to_equiv_inj {h h' : M ≃ₘ^n⟮I, I'⟯ M'} : h.to_equiv = h'.to_equiv ↔ h = h' :=
to_equiv_injective.eq_iff

/-- Coercion to function `λ h : M ≃ₘ^n⟮I, I'⟯ M', (h : M → M')` is injective. -/
lemma coe_fn_injective : injective (λ (h : M ≃ₘ^n⟮I, I'⟯ M') (x : M), h x) :=
equiv.coe_fn_injective.comp to_equiv_injective

@[ext] lemma ext {h h' : M ≃ₘ^n⟮I, I'⟯ M'} (Heq : ∀ x, h x = h' x) : h = h' :=
coe_fn_injective $ funext Heq

section

variables (M I n)

/-- Identity map as a diffeomorphism. -/
protected def refl : M ≃ₘ^n⟮I, I⟯ M :=
{ cont_mdiff_to_fun := cont_mdiff_id,
  cont_mdiff_inv_fun := cont_mdiff_id,
  to_equiv := equiv.refl M }

@[simp] lemma refl_to_equiv : (diffeomorph.refl I M n).to_equiv = equiv.refl _ := rfl
@[simp] lemma coe_refl : ⇑(diffeomorph.refl I M n) = id := rfl

end

/-- Composition of two diffeomorphisms. -/
protected def trans (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) :
  M ≃ₘ^n⟮I, J⟯ N :=
{ cont_mdiff_to_fun  := h₂.cont_mdiff_to_fun.comp h₁.cont_mdiff_to_fun,
  cont_mdiff_inv_fun := h₁.cont_mdiff_inv_fun.comp h₂.cont_mdiff_inv_fun,
  to_equiv := h₁.to_equiv.trans h₂.to_equiv }

@[simp] lemma trans_refl (h : M ≃ₘ^n⟮I, I'⟯ M') : h.trans (diffeomorph.refl I' M' n) = h :=
ext $ λ _, rfl
@[simp] lemma refl_trans (h : M ≃ₘ^n⟮I, I'⟯ M') : (diffeomorph.refl I M n).trans h = h :=
ext $ λ _, rfl
@[simp] lemma coe_trans (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) :
  ⇑(h₁.trans h₂) = h₂ ∘ h₁ := rfl

/-- Inverse of a diffeomorphism. -/
protected def symm (h : M ≃ₘ^n⟮I, J⟯ N) : N ≃ₘ^n⟮J, I⟯ M :=
{ cont_mdiff_to_fun  := h.cont_mdiff_inv_fun,
  cont_mdiff_inv_fun := h.cont_mdiff_to_fun,
  to_equiv := h.to_equiv.symm }

@[simp] lemma apply_symm_apply (h : M ≃ₘ^n⟮I, J⟯ N) (x : N) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x
@[simp] lemma symm_apply_apply (h : M ≃ₘ^n⟮I, J⟯ N) (x : M) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

@[simp] lemma symm_refl : (diffeomorph.refl I M n).symm = diffeomorph.refl I M n :=
ext $ λ _, rfl
@[simp] lemma self_trans_symm (h : M ≃ₘ^n⟮I, J⟯ N) : h.trans h.symm = diffeomorph.refl I M n :=
ext h.symm_apply_apply
@[simp] lemma symm_trans_self (h : M ≃ₘ^n⟮I, J⟯ N) : h.symm.trans h = diffeomorph.refl J N n :=
ext h.apply_symm_apply
@[simp] lemma symm_trans' (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : M' ≃ₘ^n⟮I', J⟯ N) :
  (h₁.trans h₂).symm = h₂.symm.trans h₁.symm := rfl
@[simp] lemma symm_to_equiv (h : M ≃ₘ^n⟮I, J⟯ N) : h.symm.to_equiv = h.to_equiv.symm := rfl
@[simp, mfld_simps] lemma to_equiv_coe_symm (h : M ≃ₘ^n⟮I, J⟯ N) : ⇑h.to_equiv.symm = h.symm := rfl

lemma image_eq_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (s : set M) : h '' s = h.symm ⁻¹' s :=
h.to_equiv.image_eq_preimage s
lemma symm_image_eq_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (s : set N) : h.symm '' s = h ⁻¹' s :=
h.symm.image_eq_preimage s

@[simp, mfld_simps] lemma range_comp {α} (h : M ≃ₘ^n⟮I, J⟯ N) (f : α → M) :
  range (h ∘ f) = h.symm ⁻¹' (range f) :=
by rw [range_comp, image_eq_preimage]

@[simp] lemma image_symm_image (h : M ≃ₘ^n⟮I, J⟯ N) (s : set N) : h '' (h.symm '' s) = s :=
h.to_equiv.image_symm_image s
@[simp] lemma symm_image_image (h : M ≃ₘ^n⟮I, J⟯ N) (s : set M) : h.symm '' (h '' s) = s :=
h.to_equiv.symm_image_image s

/-- A diffeomorphism is a homeomorphism. -/
def to_homeomorph (h : M ≃ₘ^n⟮I, J⟯ N) : M ≃ₜ N :=
⟨h.to_equiv, h.continuous, h.symm.continuous⟩

@[simp] lemma to_homeomorph_to_equiv (h : M ≃ₘ^n⟮I, J⟯ N) :
  h.to_homeomorph.to_equiv = h.to_equiv :=
rfl
@[simp] lemma symm_to_homeomorph (h : M ≃ₘ^n⟮I, J⟯ N) :
  h.symm.to_homeomorph = h.to_homeomorph.symm :=
rfl

@[simp] lemma coe_to_homeomorph (h : M ≃ₘ^n⟮I, J⟯ N) : ⇑h.to_homeomorph = h := rfl
@[simp] lemma coe_to_homeomorph_symm (h : M ≃ₘ^n⟮I, J⟯ N) :
  ⇑h.to_homeomorph.symm = h.symm := rfl

@[simp] lemma cont_mdiff_within_at_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'}
  {s x} (hm : m ≤ n) :
  cont_mdiff_within_at I I' m (f ∘ h) s x ↔
    cont_mdiff_within_at J I' m f (h.symm ⁻¹' s) (h x) :=
begin
  split,
  { intro Hfh,
    rw [← h.symm_apply_apply x] at Hfh,
    simpa only [(∘), h.apply_symm_apply]
      using Hfh.comp (h x) (h.symm.cont_mdiff_within_at.of_le hm) (maps_to_preimage _ _) },
  { rw ← h.image_eq_preimage,
    exact λ hf, hf.comp x (h.cont_mdiff_within_at.of_le hm) (maps_to_image _ _) }
end

@[simp] lemma cont_mdiff_on_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'}
  {s} (hm : m ≤ n) :
  cont_mdiff_on I I' m (f ∘ h) s ↔ cont_mdiff_on J I' m f (h.symm ⁻¹' s) :=
h.to_equiv.forall_congr $ λ x, by simp only [hm, coe_to_equiv, symm_apply_apply,
  cont_mdiff_within_at_comp_diffeomorph_iff, mem_preimage]

@[simp] lemma cont_mdiff_at_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'} {x}
  (hm : m ≤ n) :
  cont_mdiff_at I I' m (f ∘ h) x ↔ cont_mdiff_at J I' m f (h x) :=
h.cont_mdiff_within_at_comp_diffeomorph_iff hm

@[simp] lemma cont_mdiff_comp_diffeomorph_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : N → M'}
  (hm : m ≤ n) :
  cont_mdiff I I' m (f ∘ h) ↔ cont_mdiff J I' m f :=
h.to_equiv.forall_congr $ λ x, (h.cont_mdiff_at_comp_diffeomorph_iff hm)

@[simp] lemma cont_mdiff_within_at_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M}
  (hm : m ≤ n) {s x} :
  cont_mdiff_within_at I' J m (h ∘ f) s x ↔ cont_mdiff_within_at I' I m f s x :=
⟨λ Hhf, by simpa only [(∘), h.symm_apply_apply]
  using (h.symm.cont_mdiff_at.of_le hm).comp_cont_mdiff_within_at _ Hhf,
  λ Hf, (h.cont_mdiff_at.of_le hm).comp_cont_mdiff_within_at _ Hf⟩

@[simp] lemma cont_mdiff_at_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M}
  (hm : m ≤ n) {x} :
  cont_mdiff_at I' J m (h ∘ f) x ↔ cont_mdiff_at I' I m f x :=
h.cont_mdiff_within_at_diffeomorph_comp_iff hm

@[simp] lemma cont_mdiff_on_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M}
  (hm : m ≤ n) {s} :
  cont_mdiff_on I' J m (h ∘ f) s ↔ cont_mdiff_on I' I m f s :=
forall₂_congr $ λ x hx, h.cont_mdiff_within_at_diffeomorph_comp_iff hm

@[simp] lemma cont_mdiff_diffeomorph_comp_iff {m} (h : M ≃ₘ^n⟮I, J⟯ N) {f : M' → M}
  (hm : m ≤ n) :
  cont_mdiff I' J m (h ∘ f) ↔ cont_mdiff I' I m f :=
forall_congr $ λ x, h.cont_mdiff_within_at_diffeomorph_comp_iff hm

lemma to_local_homeomorph_mdifferentiable (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) :
  h.to_homeomorph.to_local_homeomorph.mdifferentiable I J :=
⟨h.mdifferentiable_on _ hn, h.symm.mdifferentiable_on _ hn⟩

section constructions

/-- Product of two diffeomorphisms. -/
def prod_congr (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
  M × N ≃ₘ^n⟮I.prod J, I'.prod J'⟯ M' × N' :=
{ cont_mdiff_to_fun  := (h₁.cont_mdiff.comp cont_mdiff_fst).prod_mk
    (h₂.cont_mdiff.comp cont_mdiff_snd),
  cont_mdiff_inv_fun := (h₁.symm.cont_mdiff.comp cont_mdiff_fst).prod_mk
    (h₂.symm.cont_mdiff.comp cont_mdiff_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : M ≃ₘ^n⟮I, I'⟯ M') (h₂ : N ≃ₘ^n⟮J, J'⟯ N') :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (I J J' M N N' n)

/-- `M × N` is diffeomorphic to `N × M`. -/
def prod_comm : M × N ≃ₘ^n⟮I.prod J, J.prod I⟯ N × M :=
{ cont_mdiff_to_fun  := cont_mdiff_snd.prod_mk cont_mdiff_fst,
  cont_mdiff_inv_fun := cont_mdiff_snd.prod_mk cont_mdiff_fst,
  to_equiv := equiv.prod_comm M N }

@[simp] lemma prod_comm_symm : (prod_comm I J M N n).symm = prod_comm J I N M n := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm I J M N n) = prod.swap := rfl

/-- `(M × N) × N'` is diffeomorphic to `M × (N × N')`. -/
def prod_assoc : (M × N) × N' ≃ₘ^n⟮(I.prod J).prod J', I.prod (J.prod J')⟯ M × (N × N') :=
{ cont_mdiff_to_fun  := (cont_mdiff_fst.comp cont_mdiff_fst).prod_mk
    ((cont_mdiff_snd.comp cont_mdiff_fst).prod_mk cont_mdiff_snd),
  cont_mdiff_inv_fun := (cont_mdiff_fst.prod_mk (cont_mdiff_fst.comp cont_mdiff_snd)).prod_mk
    (cont_mdiff_snd.comp cont_mdiff_snd),
  to_equiv := equiv.prod_assoc M N N' }

end
end constructions

variables [smooth_manifold_with_corners I M] [smooth_manifold_with_corners J N]

lemma unique_mdiff_on_image_aux (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n)
  {s : set M} (hs : unique_mdiff_on I s) :
  unique_mdiff_on J (h '' s) :=
begin
  convert hs.unique_mdiff_on_preimage (h.to_local_homeomorph_mdifferentiable hn),
  simp [h.image_eq_preimage]
end

@[simp] lemma unique_mdiff_on_image (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) {s : set M} :
  unique_mdiff_on J (h '' s) ↔ unique_mdiff_on I s :=
⟨λ hs, h.symm_image_image s ▸ h.symm.unique_mdiff_on_image_aux hn hs,
  h.unique_mdiff_on_image_aux hn⟩

@[simp] lemma unique_mdiff_on_preimage (h : M ≃ₘ^n⟮I, J⟯ N) (hn : 1 ≤ n) {s : set N} :
  unique_mdiff_on I (h ⁻¹' s) ↔ unique_mdiff_on J s :=
h.symm_image_eq_preimage s ▸ h.symm.unique_mdiff_on_image hn

@[simp] lemma unique_diff_on_image (h : E ≃ₘ^n[𝕜] F) (hn : 1 ≤ n) {s : set E} :
  unique_diff_on 𝕜 (h '' s) ↔ unique_diff_on 𝕜 s :=
by simp only [← unique_mdiff_on_iff_unique_diff_on, unique_mdiff_on_image, hn]

@[simp] lemma unique_diff_on_preimage (h : E ≃ₘ^n[𝕜] F) (hn : 1 ≤ n) {s : set F} :
  unique_diff_on 𝕜 (h ⁻¹' s) ↔ unique_diff_on 𝕜 s :=
h.symm_image_eq_preimage s ▸ h.symm.unique_diff_on_image hn

end diffeomorph

namespace continuous_linear_equiv

variable (e : E ≃L[𝕜] E')

/-- A continuous linear equivalence between normed spaces is a diffeomorphism. -/
def to_diffeomorph : E ≃ₘ[𝕜] E' :=
{ cont_mdiff_to_fun := e.cont_diff.cont_mdiff,
  cont_mdiff_inv_fun := e.symm.cont_diff.cont_mdiff,
  to_equiv := e.to_linear_equiv.to_equiv }

@[simp] lemma coe_to_diffeomorph : ⇑e.to_diffeomorph = e := rfl
@[simp] lemma symm_to_diffeomorph : e.symm.to_diffeomorph = e.to_diffeomorph.symm := rfl
@[simp] lemma coe_to_diffeomorph_symm : ⇑e.to_diffeomorph.symm = e.symm := rfl

end continuous_linear_equiv

namespace model_with_corners

variables (I) (e : E ≃ₘ[𝕜] E')

/-- Apply a diffeomorphism (e.g., a continuous linear equivalence) to the model vector space. -/
def trans_diffeomorph (I : model_with_corners 𝕜 E H) (e : E ≃ₘ[𝕜] E') :
  model_with_corners 𝕜 E' H :=
{ to_local_equiv := I.to_local_equiv.trans e.to_equiv.to_local_equiv,
  source_eq := by simp,
  unique_diff' := by simp [range_comp e, I.unique_diff],
  continuous_to_fun := e.continuous.comp I.continuous,
  continuous_inv_fun := I.continuous_symm.comp e.symm.continuous }

@[simp, mfld_simps] lemma coe_trans_diffeomorph : ⇑(I.trans_diffeomorph e) = e ∘ I := rfl
@[simp, mfld_simps] lemma coe_trans_diffeomorph_symm :
  ⇑(I.trans_diffeomorph e).symm = I.symm ∘ e.symm := rfl

lemma trans_diffeomorph_range : range (I.trans_diffeomorph e) = e '' (range I) :=
range_comp e I

lemma coe_ext_chart_at_trans_diffeomorph (x : M) :
  ⇑(ext_chart_at (I.trans_diffeomorph e) x) = e ∘ ext_chart_at I x := rfl

lemma coe_ext_chart_at_trans_diffeomorph_symm (x : M) :
  ⇑(ext_chart_at (I.trans_diffeomorph e) x).symm = (ext_chart_at I x).symm ∘ e.symm := rfl

lemma ext_chart_at_trans_diffeomorph_target (x : M) :
  (ext_chart_at (I.trans_diffeomorph e) x).target = e.symm ⁻¹' (ext_chart_at I x).target :=
by simp only [range_comp e, e.image_eq_preimage, preimage_preimage] with mfld_simps

end model_with_corners

namespace diffeomorph

variables (e : E ≃ₘ[𝕜] F)

instance smooth_manifold_with_corners_trans_diffeomorph [smooth_manifold_with_corners I M] :
  smooth_manifold_with_corners (I.trans_diffeomorph e) M :=
begin
  refine smooth_manifold_with_corners_of_cont_diff_on  _ _ (λ e₁ e₂ h₁ h₂, _),
  refine e.cont_diff.comp_cont_diff_on
    (((cont_diff_groupoid ⊤ I).compatible h₁ h₂).1.comp
      e.symm.cont_diff.cont_diff_on _),
  mfld_set_tac
end

variables (I M)

/-- The identity diffeomorphism between a manifold with model `I` and the same manifold
with model `I.trans_diffeomorph e`. -/
def to_trans_diffeomorph (e : E ≃ₘ[𝕜] F) : M ≃ₘ⟮I, I.trans_diffeomorph e⟯ M :=
{ to_equiv := equiv.refl M,
  cont_mdiff_to_fun := λ x,
    begin
      refine cont_mdiff_within_at_iff'.2 ⟨continuous_within_at_id, _⟩,
      refine e.cont_diff.cont_diff_within_at.congr' (λ y hy, _) _,
      { simp only [equiv.coe_refl, id, (∘), I.coe_ext_chart_at_trans_diffeomorph,
          (ext_chart_at I x).right_inv hy.1] },
      exact ⟨(ext_chart_at I x).map_source (mem_ext_chart_source I x), trivial,
        by simp only with mfld_simps⟩
    end,
  cont_mdiff_inv_fun := λ x,
    begin
      refine cont_mdiff_within_at_iff'.2 ⟨continuous_within_at_id, _⟩,
      refine e.symm.cont_diff.cont_diff_within_at.congr' (λ y hy, _) _,
      { simp only [mem_inter_iff, I.ext_chart_at_trans_diffeomorph_target] at hy,
        simp only [equiv.coe_refl, equiv.refl_symm, id, (∘),
          I.coe_ext_chart_at_trans_diffeomorph_symm, (ext_chart_at I x).right_inv hy.1] },
      exact ⟨(ext_chart_at _ x).map_source (mem_ext_chart_source _ x), trivial,
        by simp only [e.symm_apply_apply, equiv.refl_symm, equiv.coe_refl] with mfld_simps⟩
    end }

variables {I M}

@[simp] lemma cont_mdiff_within_at_trans_diffeomorph_right {f : M' → M} {x s} :
  cont_mdiff_within_at I' (I.trans_diffeomorph e) n f s x ↔
    cont_mdiff_within_at I' I n f s x :=
(to_trans_diffeomorph I M e).cont_mdiff_within_at_diffeomorph_comp_iff le_top

@[simp] lemma cont_mdiff_at_trans_diffeomorph_right {f : M' → M} {x} :
  cont_mdiff_at I' (I.trans_diffeomorph e) n f x ↔ cont_mdiff_at I' I n f x :=
(to_trans_diffeomorph I M e).cont_mdiff_at_diffeomorph_comp_iff le_top

@[simp] lemma cont_mdiff_on_trans_diffeomorph_right {f : M' → M} {s} :
  cont_mdiff_on I' (I.trans_diffeomorph e) n f s ↔ cont_mdiff_on I' I n f s :=
(to_trans_diffeomorph I M e).cont_mdiff_on_diffeomorph_comp_iff le_top

@[simp] lemma cont_mdiff_trans_diffeomorph_right {f : M' → M} :
  cont_mdiff I' (I.trans_diffeomorph e) n f ↔ cont_mdiff I' I n f :=
(to_trans_diffeomorph I M e).cont_mdiff_diffeomorph_comp_iff le_top

@[simp] lemma smooth_trans_diffeomorph_right {f : M' → M} :
  smooth I' (I.trans_diffeomorph e) f ↔ smooth I' I f :=
cont_mdiff_trans_diffeomorph_right e

@[simp]

@[simp] lemma cont_mdiff_at_trans_diffeomorph_left {f : M → M'} {x} :
  cont_mdiff_at (I.trans_diffeomorph e) I' n f x ↔ cont_mdiff_at I I' n f x :=
((to_trans_diffeomorph I M e).cont_mdiff_at_comp_diffeomorph_iff le_top).symm

@[simp] lemma cont_mdiff_on_trans_diffeomorph_left {f : M → M'} {s} :
  cont_mdiff_on (I.trans_diffeomorph e) I' n f s ↔ cont_mdiff_on I I' n f s :=
((to_trans_diffeomorph I M e).cont_mdiff_on_comp_diffeomorph_iff le_top).symm

@[simp] lemma cont_mdiff_trans_diffeomorph_left {f : M → M'} :
  cont_mdiff (I.trans_diffeomorph e) I' n f ↔ cont_mdiff I I' n f :=
((to_trans_diffeomorph I M e).cont_mdiff_comp_diffeomorph_iff le_top).symm

@[simp] lemma smooth_trans_diffeomorph_left {f : M → M'} :
  smooth (I.trans_diffeomorph e) I' f ↔ smooth I I' f :=
e.cont_mdiff_trans_diffeomorph_left

end diffeomorph


import .definitions
import data.bool
import data.int.gcd
import tactic
import .main

-- Theory of Single Integer Equations

-- `eq.has_solution` correctly computes if an equation has a solution
theorem has_solution_iff (eq: Eq) : eq.has_solution ↔ ∃ xs, xs ∈ eq
:= Eq.has_solution_iff eq

-- If `eq.get_solution` computes a solution `s`, s is indeed a solution.
theorem get_solution_mem { eq: Eq } { s: list ℤ } (h: s ∈ eq.get_solution): s ∈ eq
:= Eq.get_solution_mem h

-- Only if there is no solution, `eq.get_solution` returns `none`.
theorem get_solution_neq_none_iff (eq: Eq): eq.get_solution ≠ none ↔ eq.has_solution
:= Eq.get_solution_neq_none_iff eq


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

import set_theory.ordinal.principal

/-!
# Ordinal notation

Constructive ordinal arithmetic for ordinals below `ε₀`.

We define a type `onote`, with constructors `0 : onote` and `onote.oadd e n a` representing
`ω ^ e * n + a`.
We say that `o` is in Cantor normal form - `onote.NF o` - if either `o = 0` or
`o = ω ^ e * n + a` with `a < ω ^ e` and `a` in Cantor normal form.

The type `nonote` is the type of ordinals below `ε₀` in Cantor normal form.
Various operations (addition, subtraction, multiplication, power function)
are defined on `onote` and `nonote`.
-/

open ordinal order
open_locale ordinal -- get notation for `ω`

/-- Recursive definition of an ordinal notation. `zero` denotes the
  ordinal 0, and `oadd e n a` is intended to refer to `ω^e * n + a`.
  For this to be valid Cantor normal form, we must have the exponents
  decrease to the right, but we can't state this condition until we've
  defined `repr`, so it is a separate definition `NF`. -/
@[derive decidable_eq]
inductive onote : Type
| zero : onote
| oadd : onote → ℕ+ → onote → onote

namespace onote

/-- Notation for 0 -/
instance : has_zero onote := ⟨zero⟩
@[simp] theorem zero_def : zero = 0 := rfl

instance : inhabited onote := ⟨0⟩

/-- Notation for 1 -/
instance : has_one onote := ⟨oadd 0 1 0⟩

/-- Notation for ω -/
def omega : onote := oadd 1 1 0

/-- The ordinal denoted by a notation -/
@[simp] noncomputable def repr : onote → ordinal.{0}
| 0 := 0
| (oadd e n a) := ω ^ repr e * n + repr a

/-- Auxiliary definition to print an ordinal notation -/
def to_string_aux1 (e : onote) (n : ℕ) (s : string) : string :=
if e = 0 then _root_.to_string n else
(if e = 1 then "ω" else "ω^(" ++ s ++ ")") ++
if n = 1 then "" else "*" ++ _root_.to_string n

/-- Print an ordinal notation -/
def to_string : onote → string
| zero := "0"
| (oadd e n 0) := to_string_aux1 e n (to_string e)
| (oadd e n a) := to_string_aux1 e n (to_string e) ++ " + " ++ to_string a

/-- Print an ordinal notation -/
def repr' : onote → string
| zero := "0"
| (oadd e n a) := "(oadd " ++ repr' e ++ " " ++ _root_.to_string (n:ℕ) ++ " " ++ repr' a ++ ")"

instance : has_to_string onote := ⟨to_string⟩
instance : has_repr onote := ⟨repr'⟩

instance : preorder onote :=
{ le       := λ x y, repr x ≤ repr y,
  lt       := λ x y, repr x < repr y,
  le_refl  := λ a, @le_refl ordinal _ _,
  le_trans := λ a b c, @le_trans ordinal _ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le ordinal _ _ _ }

theorem lt_def {x y : onote} : x < y ↔ repr x < repr y := iff.rfl
theorem le_def {x y : onote} : x ≤ y ↔ repr x ≤ repr y := iff.rfl

/-- Convert a `nat` into an ordinal -/
@[simp] def of_nat : ℕ → onote
| 0            := 0
| (nat.succ n) := oadd 0 n.succ_pnat 0

@[simp] theorem of_nat_one : of_nat 1 = 1 := rfl

@[simp] theorem repr_of_nat (n : ℕ) : repr (of_nat n) = n :=
by cases n; simp

@[simp] theorem repr_one : repr 1 = 1 :=
by simpa using repr_of_nat 1

theorem omega_le_oadd (e n a) : ω ^ repr e ≤ repr (oadd e n a) :=
begin
  unfold repr,
  refine le_trans _ (le_add_right _ _),
  simpa using (mul_le_mul_iff_left $ opow_pos (repr e) omega_pos).2 (nat_cast_le.2 n.2)
end

theorem oadd_pos (e n a) : 0 < oadd e n a :=
@lt_of_lt_of_le _ _ _ _ _ (opow_pos _ omega_pos)
  (omega_le_oadd _ _ _)

/-- Compare ordinal notations -/
def cmp : onote → onote → ordering
| 0 0 := ordering.eq
| _ 0 := ordering.gt
| 0 _ := ordering.lt
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) :=
  (cmp e₁ e₂).or_else $ (_root_.cmp (n₁:ℕ) n₂).or_else (cmp a₁ a₂)

theorem eq_of_cmp_eq : ∀ {o₁ o₂}, cmp o₁ o₂ = ordering.eq → o₁ = o₂
| 0            0 h := rfl
| (oadd e n a) 0 h := by injection h
| 0 (oadd e n a) h := by injection h
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) h := begin
  revert h, simp only [cmp],
  cases h₁ : cmp e₁ e₂; intro h; try {cases h},
  obtain rfl := eq_of_cmp_eq h₁,
  revert h, cases h₂ : _root_.cmp (n₁:ℕ) n₂; intro h; try {cases h},
  obtain rfl := eq_of_cmp_eq h,
  rw [_root_.cmp, cmp_using_eq_eq] at h₂,
  obtain rfl := subtype.eq (eq_of_incomp h₂),
  simp
end

protected theorem zero_lt_one : (0 : onote) < 1 :=
by rw [lt_def, repr, repr_one]; exact zero_lt_one

/-- `NF_below o b` says that `o` is a normal form ordinal notation
  satisfying `repr o < ω ^ b`. -/
inductive NF_below : onote → ordinal.{0} → Prop
| zero {b} : NF_below 0 b
| oadd' {e n a eb b} : NF_below e eb →
  NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b

/-- A normal form ordinal notation has the form

     ω ^ a₁ * n₁ + ω ^ a₂ * n₂ + ... ω ^ aₖ * nₖ
  where `a₁ > a₂ > ... > aₖ` and all the `aᵢ` are
  also in normal form.

  We will essentially only be interested in normal form
  ordinal notations, but to avoid complicating the algorithms
  we define everything over general ordinal notations and
  only prove correctness with normal form as an invariant. -/
class NF (o : onote) : Prop := (out : Exists (NF_below o))
attribute [pp_nodot] NF

instance NF.zero : NF 0 := ⟨⟨0, NF_below.zero⟩⟩

theorem NF_below.oadd {e n a b} : NF e →
  NF_below a (repr e) → repr e < b → NF_below (oadd e n a) b
| ⟨⟨eb, h⟩⟩ := NF_below.oadd' h

theorem NF_below.fst {e n a b} (h : NF_below (oadd e n a) b) : NF e :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact ⟨⟨_, h₁⟩⟩

theorem NF.fst {e n a} : NF (oadd e n a) → NF e
| ⟨⟨b, h⟩⟩ := h.fst

theorem NF_below.snd {e n a b} (h : NF_below (oadd e n a) b) : NF_below a (repr e) :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact h₂

theorem NF.snd' {e n a} : NF (oadd e n a) → NF_below a (repr e)
| ⟨⟨b, h⟩⟩ := h.snd

theorem NF.snd {e n a} (h : NF (oadd e n a)) : NF a :=
⟨⟨_, h.snd'⟩⟩

theorem NF.oadd {e a} (h₁ : NF e) (n)
  (h₂ : NF_below a (repr e)) : NF (oadd e n a) :=
⟨⟨_, NF_below.oadd h₁ h₂ (lt_succ _)⟩⟩

instance NF.oadd_zero (e n) [h : NF e] : NF (oadd e n 0) :=
h.oadd _ NF_below.zero

theorem NF_below.lt {e n a b} (h : NF_below (oadd e n a) b) : repr e < b :=
by cases h with _ _ _ _ eb _ h₁ h₂ h₃; exact h₃

theorem NF_below_zero : ∀ {o}, NF_below o 0 ↔ o = 0
| 0            := ⟨λ _, rfl, λ _, NF_below.zero⟩
| (oadd e n a) := ⟨λ h, (not_le_of_lt h.lt).elim (ordinal.zero_le _),
                   λ e, e.symm ▸ NF_below.zero⟩

theorem NF.zero_of_zero {e n a} (h : NF (oadd e n a)) (e0 : e = 0) : a = 0 :=
by simpa [e0, NF_below_zero] using h.snd'

theorem NF_below.repr_lt {o b} (h : NF_below o b) : repr o < ω ^ b :=
begin
  induction h with _ e n a eb b h₁ h₂ h₃ _ IH,
  { exact opow_pos _ omega_pos },
  { rw repr,
    apply ((add_lt_add_iff_left _).2 IH).trans_le,
    rw ← mul_succ,
    apply (mul_le_mul_left' (succ_le_of_lt (nat_lt_omega _)) _).trans,
    rw ← opow_succ,
    exact opow_le_opow_right omega_pos (succ_le_of_lt h₃) }
end

theorem NF_below.mono {o b₁ b₂} (bb : b₁ ≤ b₂) (h : NF_below o b₁) : NF_below o b₂ :=
begin
  induction h with _ e n a eb b h₁ h₂ h₃ _ IH; constructor,
  exacts [h₁, h₂, lt_of_lt_of_le h₃ bb]
end

theorem NF.below_of_lt {e n a b} (H : repr e < b) : NF (oadd e n a) → NF_below (oadd e n a) b
| ⟨⟨b', h⟩⟩ := by cases h with _ _ _ _ eb _ h₁ h₂ h₃;
  exact NF_below.oadd' h₁ h₂ H

theorem NF.below_of_lt' : ∀ {o b}, repr o < ω ^ b → NF o → NF_below o b
| 0            b H _ := NF_below.zero
| (oadd e n a) b H h := h.below_of_lt $ (opow_lt_opow_iff_right one_lt_omega).1 $
    (lt_of_le_of_lt (omega_le_oadd _ _ _) H)

theorem NF_below_of_nat : ∀ n, NF_below (of_nat n) 1
| 0            := NF_below.zero
| (nat.succ n) := NF_below.oadd NF.zero NF_below.zero zero_lt_one

instance NF_of_nat (n) : NF (of_nat n) := ⟨⟨_, NF_below_of_nat n⟩⟩

instance NF_one : NF 1 := by rw ← of_nat_one; apply_instance

theorem oadd_lt_oadd_1 {e₁ n₁ o₁ e₂ n₂ o₂} (h₁ : NF (oadd e₁ n₁ o₁)) (h : e₁ < e₂) :
  oadd e₁ n₁ o₁ < oadd e₂ n₂ o₂ :=
@lt_of_lt_of_le _ _ _ _ _ ((h₁.below_of_lt h).repr_lt) (omega_le_oadd _ _ _)

theorem oadd_lt_oadd_2 {e o₁ o₂ : onote} {n₁ n₂ : ℕ+}
  (h₁ : NF (oadd e n₁ o₁)) (h : (n₁:ℕ) < n₂) : oadd e n₁ o₁ < oadd e n₂ o₂ :=
begin
  simp [lt_def],
  refine lt_of_lt_of_le ((add_lt_add_iff_left _).2 h₁.snd'.repr_lt)
    (le_trans _ (le_add_right _ _)),
  rwa [← mul_succ, mul_le_mul_iff_left (opow_pos _ omega_pos), succ_le_iff, nat_cast_lt]
end

theorem oadd_lt_oadd_3 {e n a₁ a₂} (h : a₁ < a₂) :
  oadd e n a₁ < oadd e n a₂ :=
begin
  rw lt_def, unfold repr,
  exact add_lt_add_left h _
end

theorem cmp_compares : ∀ (a b : onote) [NF a] [NF b], (cmp a b).compares a b
| 0 0 h₁ h₂ := rfl
| (oadd e n a) 0 h₁ h₂ := oadd_pos _ _ _
| 0 (oadd e n a) h₁ h₂ := oadd_pos _ _ _
| o₁@(oadd e₁ n₁ a₁) o₂@(oadd e₂ n₂ a₂) h₁ h₂ := begin
    rw cmp,
    have IHe := @cmp_compares _ _ h₁.fst h₂.fst,
    cases cmp e₁ e₂,
    case ordering.lt { exact oadd_lt_oadd_1 h₁ IHe },
    case ordering.gt { exact oadd_lt_oadd_1 h₂ IHe },
    change e₁ = e₂ at IHe, subst IHe,
    unfold _root_.cmp, cases nh : cmp_using (<) (n₁:ℕ) n₂,
    case ordering.lt
    { rw cmp_using_eq_lt at nh, exact oadd_lt_oadd_2 h₁ nh },
    case ordering.gt
    { rw cmp_using_eq_gt at nh, exact oadd_lt_oadd_2 h₂ nh },
    rw cmp_using_eq_eq at nh,
    obtain rfl := subtype.eq (eq_of_incomp nh),
    have IHa := @cmp_compares _ _ h₁.snd h₂.snd,
    cases cmp a₁ a₂,
    case ordering.lt { exact oadd_lt_oadd_3 IHa },
    case ordering.gt { exact oadd_lt_oadd_3 IHa },
    change a₁ = a₂ at IHa, subst IHa, exact rfl
  end

theorem repr_inj {a b} [NF a] [NF b] : repr a = repr b ↔ a = b :=
⟨match cmp a b, cmp_compares a b with
 | ordering.lt, (h : repr a < repr b), e := (ne_of_lt h e).elim
 | ordering.gt, (h : repr a > repr b), e := (ne_of_gt h e).elim
 | ordering.eq, h, e := h
 end, congr_arg _⟩

theorem NF.of_dvd_omega_opow {b e n a} (h : NF (oadd e n a)) (d : ω ^ b ∣ repr (oadd e n a)) :
  b ≤ repr e ∧ ω ^ b ∣ repr a :=
begin
  have := mt repr_inj.1 (λ h, by injection h : oadd e n a ≠ 0),
  have L := le_of_not_lt (λ l, not_le_of_lt (h.below_of_lt l).repr_lt (le_of_dvd this d)),
  simp at d,
  exact ⟨L, (dvd_add_iff $ (opow_dvd_opow _ L).mul_right _).1 d⟩
end

theorem NF.of_dvd_omega {e n a} (h : NF (oadd e n a)) :
   ω ∣ repr (oadd e n a) → repr e ≠ 0 ∧ ω ∣ repr a :=
by rw [← opow_one ω, ← one_le_iff_ne_zero]; exact h.of_dvd_omega_opow

/-- `top_below b o` asserts that the largest exponent in `o`, if
  it exists, is less than `b`. This is an auxiliary definition
  for decidability of `NF`. -/
def top_below (b) : onote → Prop
| 0            := true
| (oadd e n a) := cmp e b = ordering.lt

instance decidable_top_below : decidable_rel top_below :=
by intros b o; cases o; delta top_below; apply_instance

theorem NF_below_iff_top_below {b} [NF b] : ∀ {o},
  NF_below o (repr b) ↔ NF o ∧ top_below b o
| 0            := ⟨λ h, ⟨⟨⟨_, h⟩⟩, trivial⟩, λ _, NF_below.zero⟩
| (oadd e n a) :=
  ⟨λ h, ⟨⟨⟨_, h⟩⟩, (@cmp_compares _ b h.fst _).eq_lt.2 h.lt⟩,
   λ ⟨h₁, h₂⟩, h₁.below_of_lt $ (@cmp_compares _ b h₁.fst _).eq_lt.1 h₂⟩

instance decidable_NF : decidable_pred NF
| 0            := is_true NF.zero
| (oadd e n a) := begin
  have := decidable_NF e,
  have := decidable_NF a, resetI,
  apply decidable_of_iff (NF e ∧ NF a ∧ top_below e a),
  abstract
  { rw ← and_congr_right (λ h, @NF_below_iff_top_below _ h _),
    exact ⟨λ ⟨h₁, h₂⟩, NF.oadd h₁ n h₂, λ h, ⟨h.fst, h.snd'⟩⟩ },
end

/-- Addition of ordinal notations (correct only for normal input) -/
def add : onote → onote → onote
| 0            o := o
| (oadd e n a) o := match add a o with
  | 0 := oadd e n 0
  | o'@(oadd e' n' a') := match cmp e e' with
    | ordering.lt := o'
    | ordering.eq := oadd e (n + n') a'
    | ordering.gt := oadd e n o'
    end
  end

instance : has_add onote := ⟨add⟩

@[simp] theorem zero_add (o : onote) : 0 + o = o := rfl
theorem oadd_add (e n a o) : oadd e n a + o = add._match_1 e n (a + o) := rfl

/-- Subtraction of ordinal notations (correct only for normal input) -/
def sub : onote → onote → onote
| 0 o := 0
| o 0 := o
| o₁@(oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) := match cmp e₁ e₂ with
  | ordering.lt := 0
  | ordering.gt := o₁
  | ordering.eq := match (n₁:ℕ) - n₂ with
    | 0            := if n₁ = n₂ then sub a₁ a₂ else 0
    | (nat.succ k) := oadd e₁ k.succ_pnat a₁
  end
end

instance : has_sub onote := ⟨sub⟩

theorem add_NF_below {b} : ∀ {o₁ o₂}, NF_below o₁ b → NF_below o₂ b → NF_below (o₁ + o₂) b
| 0            o h₁ h₂ := h₂
| (oadd e n a) o h₁ h₂ := begin
  have h' := add_NF_below (h₁.snd.mono $ le_of_lt h₁.lt) h₂,
  simp [oadd_add], cases a + o with e' n' a',
  { exact NF_below.oadd h₁.fst NF_below.zero h₁.lt },
  simp [add], have := @cmp_compares _ _ h₁.fst h'.fst,
  cases cmp e e'; simp [add],
  { exact h' },
  { simp at this, subst e',
    exact NF_below.oadd h'.fst h'.snd h'.lt },
  { exact NF_below.oadd h₁.fst (NF.below_of_lt this ⟨⟨_, h'⟩⟩) h₁.lt }
end

instance add_NF (o₁ o₂) : ∀ [NF o₁] [NF o₂], NF (o₁ + o₂)
| ⟨⟨b₁, h₁⟩⟩ ⟨⟨b₂, h₂⟩⟩ := ⟨(le_total b₁ b₂).elim
  (λ h, ⟨b₂, add_NF_below (h₁.mono h) h₂⟩)
  (λ h, ⟨b₁, add_NF_below h₁ (h₂.mono h)⟩)⟩

@[simp] theorem repr_add : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ + o₂) = repr o₁ + repr o₂
| 0            o h₁ h₂ := by simp
| (oadd e n a) o h₁ h₂ := begin
  haveI := h₁.snd, have h' := repr_add a o,
  conv at h' in (_+o) {simp [(+)]},
  have nf := onote.add_NF a o,
  conv at nf in (_+o) {simp [(+)]},
  conv in (_+o) {simp [(+), add]},
  cases add a o with e' n' a'; simp [add, h'.symm, add_assoc],
  have := h₁.fst, haveI := nf.fst, have ee := cmp_compares e e',
  cases cmp e e'; simp [add],
  { rw [← add_assoc, @add_absorp _ (repr e') (ω ^ repr e' * (n':ℕ))],
    { have := (h₁.below_of_lt ee).repr_lt, unfold repr at this,
      exact lt_of_le_of_lt (le_add_right _ _) this },
    { simpa using (mul_le_mul_iff_left $
        opow_pos (repr e') omega_pos).2 (nat_cast_le.2 n'.pos) } },
  { change e = e' at ee, substI e',
    rw [← add_assoc, ← mul_add, ← nat.cast_add] }
end

theorem sub_NF_below : ∀ {o₁ o₂ b}, NF_below o₁ b → NF o₂ → NF_below (o₁ - o₂) b
| 0            o b h₁ h₂ := by cases o; exact NF_below.zero
| (oadd e n a) 0 b h₁ h₂ := h₁
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) b h₁ h₂ := begin
  have h' := sub_NF_below h₁.snd h₂.snd,
  simp [has_sub.sub, sub] at h' ⊢,
  have := @cmp_compares _ _ h₁.fst h₂.fst,
  cases cmp e₁ e₂; simp [sub],
  { apply NF_below.zero },
  { simp at this, subst e₂,
    cases mn : (n₁:ℕ) - n₂; simp [sub],
    { by_cases en : n₁ = n₂; simp [en],
      { exact h'.mono (le_of_lt h₁.lt) },
      { exact NF_below.zero } },
    { exact NF_below.oadd h₁.fst h₁.snd h₁.lt } },
  { exact h₁ }
end

instance sub_NF (o₁ o₂) : ∀ [NF o₁] [NF o₂], NF (o₁ - o₂)
| ⟨⟨b₁, h₁⟩⟩ h₂ := ⟨⟨b₁, sub_NF_below h₁ h₂⟩⟩

@[simp] theorem repr_sub : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ - o₂) = repr o₁ - repr o₂
| 0            o h₁ h₂ := by cases o; exact (ordinal.zero_sub _).symm
| (oadd e n a) 0 h₁ h₂ := (ordinal.sub_zero _).symm
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) h₁ h₂ := begin
  haveI := h₁.snd, haveI := h₂.snd, have h' := repr_sub a₁ a₂,
  conv at h' in (a₁-a₂) {simp [has_sub.sub]},
  have nf := onote.sub_NF a₁ a₂,
  conv at nf in (a₁-a₂) {simp [has_sub.sub]},
  conv in (_-oadd _ _ _) {simp [has_sub.sub, sub]},
  have ee := @cmp_compares _ _ h₁.fst h₂.fst,
  cases cmp e₁ e₂,
  { rw [ordinal.sub_eq_zero_iff_le.2], {refl},
    exact le_of_lt (oadd_lt_oadd_1 h₁ ee) },
  { change e₁ = e₂ at ee, substI e₂, unfold sub._match_1,
    cases mn : (n₁:ℕ) - n₂; dsimp only [sub._match_2],
    { by_cases en : n₁ = n₂,
      { simpa [en] },
      { simp [en, -repr],
        exact (ordinal.sub_eq_zero_iff_le.2 $ le_of_lt $ oadd_lt_oadd_2 h₁ $
          lt_of_le_of_ne (tsub_eq_zero_iff_le.1 mn) (mt pnat.eq en)).symm } },
    { simp [nat.succ_pnat, -nat.cast_succ],
      rw [(tsub_eq_iff_eq_add_of_le $ le_of_lt $ nat.lt_of_sub_eq_succ mn).1 mn,
          add_comm, nat.cast_add, mul_add, add_assoc, add_sub_add_cancel],
      refine (ordinal.sub_eq_of_add_eq $ add_absorp h₂.snd'.repr_lt $
        le_trans _ (le_add_right _ _)).symm,
      simpa using mul_le_mul_left' (nat_cast_le.2 $ nat.succ_pos _) _ } },
  { exact (ordinal.sub_eq_of_add_eq $ add_absorp (h₂.below_of_lt ee).repr_lt $
      omega_le_oadd _ _ _).symm }
end

/-- Multiplication of ordinal notations (correct only for normal input) -/
def mul : onote → onote → onote
| 0 _ := 0
| _ 0 := 0
| o₁@(oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) :=
  if e₂ = 0 then oadd e₁ (n₁ * n₂) a₁ else
  oadd (e₁ + e₂) n₂ (mul o₁ a₂)

instance : has_mul onote := ⟨mul⟩

instance : mul_zero_class onote :=
{ mul := (*),
  zero := 0,
  zero_mul := λ o, by cases o; refl,
  mul_zero := λ o, by cases o; refl }

theorem oadd_mul (e₁ n₁ a₁ e₂ n₂ a₂) : oadd e₁ n₁ a₁ * oadd e₂ n₂ a₂ =
  if e₂ = 0 then oadd e₁ (n₁ * n₂) a₁ else
  oadd (e₁ + e₂) n₂ (oadd e₁ n₁ a₁ * a₂) := rfl

theorem oadd_mul_NF_below {e₁ n₁ a₁ b₁} (h₁ : NF_below (oadd e₁ n₁ a₁) b₁) :
  ∀ {o₂ b₂}, NF_below o₂ b₂ → NF_below (oadd e₁ n₁ a₁ * o₂) (repr e₁ + b₂)
| 0 b₂ h₂ := NF_below.zero
| (oadd e₂ n₂ a₂) b₂ h₂ := begin
  have IH := oadd_mul_NF_below h₂.snd,
  by_cases e0 : e₂ = 0; simp [e0, oadd_mul],
  { apply NF_below.oadd h₁.fst h₁.snd,
    simpa using (add_lt_add_iff_left (repr e₁)).2
      (lt_of_le_of_lt (ordinal.zero_le _) h₂.lt) },
  { haveI := h₁.fst, haveI := h₂.fst,
    apply NF_below.oadd, apply_instance,
    { rwa repr_add },
    { rw [repr_add, add_lt_add_iff_left], exact h₂.lt } }
end

instance mul_NF : ∀ o₁ o₂ [NF o₁] [NF o₂], NF (o₁ * o₂)
| 0 o h₁ h₂ := by cases o; exact NF.zero
| (oadd e n a) o ⟨⟨b₁, hb₁⟩⟩ ⟨⟨b₂, hb₂⟩⟩ :=
  ⟨⟨_, oadd_mul_NF_below hb₁ hb₂⟩⟩

@[simp] theorem repr_mul : ∀ o₁ o₂ [NF o₁] [NF o₂], repr (o₁ * o₂) = repr o₁ * repr o₂
| 0               o               h₁ h₂ := by cases o; exact (zero_mul _).symm
| (oadd e₁ n₁ a₁) 0               h₁ h₂ := (mul_zero _).symm
| (oadd e₁ n₁ a₁) (oadd e₂ n₂ a₂) h₁ h₂ := begin
  have IH : repr (mul _ _) = _ := @repr_mul _ _ h₁ h₂.snd,
  conv {to_lhs, simp [(*)]},
  have ao : repr a₁ + ω ^ repr e₁ * (n₁:ℕ) = ω ^ repr e₁ * (n₁:ℕ),
  { apply add_absorp h₁.snd'.repr_lt,
    simpa using (mul_le_mul_iff_left $ opow_pos _ omega_pos).2
      (nat_cast_le.2 n₁.2) },
  by_cases e0 : e₂ = 0; simp [e0, mul],
  { cases nat.exists_eq_succ_of_ne_zero n₂.ne_zero with x xe,
    simp [h₂.zero_of_zero e0, xe, -nat.cast_succ],
    rw [nat_cast_succ x, add_mul_succ _ ao, mul_assoc] },
  { haveI := h₁.fst, haveI := h₂.fst,
    simp [IH, repr_add, opow_add, mul_add],
    rw ← mul_assoc, congr' 2,
    have := mt repr_inj.1 e0,
    rw [add_mul_limit ao (opow_is_limit_left omega_is_limit this),
        mul_assoc, mul_omega_dvd (nat_cast_pos.2 n₁.pos) (nat_lt_omega _)],
    simpa using opow_dvd_opow ω (one_le_iff_ne_zero.2 this) },
end

/-- Calculate division and remainder of `o` mod ω.
  `split' o = (a, n)` means `o = ω * a + n`. -/
def split' : onote → onote × ℕ
| 0            := (0, 0)
| (oadd e n a) := if e = 0 then (0, n) else
  let (a', m) := split' a in (oadd (e - 1) n a', m)

/-- Calculate division and remainder of `o` mod ω.
  `split o = (a, n)` means `o = a + n`, where `ω ∣ a`. -/
def split : onote → onote × ℕ
| 0            := (0, 0)
| (oadd e n a) := if e = 0 then (0, n) else
  let (a', m) := split a in (oadd e n a', m)

/-- `scale x o` is the ordinal notation for `ω ^ x * o`. -/
def scale (x : onote) : onote → onote
| 0            := 0
| (oadd e n a) := oadd (x + e) n (scale a)

/-- `mul_nat o n` is the ordinal notation for `o * n`. -/
def mul_nat : onote → ℕ → onote
| 0            m := 0
| _            0 := 0
| (oadd e n a) (m+1) := oadd e (n * m.succ_pnat) a

/-- Auxiliary definition to compute the ordinal notation for the ordinal
exponentiation in `opow` -/
def opow_aux (e a0 a : onote) : ℕ → ℕ → onote
| _     0     := 0
| 0     (m+1) := oadd e m.succ_pnat 0
| (k+1) m     := scale (e + mul_nat a0 k) a + opow_aux k m

/-- `opow o₁ o₂` calculates the ordinal notation for
  the ordinal exponential `o₁ ^ o₂`. -/
def opow (o₁ o₂ : onote) : onote :=
match split o₁ with
| (0, 0) := if o₂ = 0 then 1 else 0
| (0, 1) := 1
| (0, m+1) := let (b', k) := split' o₂ in
  oadd b' (@has_pow.pow ℕ+ _ _ m.succ_pnat k) 0
| (a@(oadd a0 _ _), m) := match split o₂ with
  | (b, 0) := oadd (a0 * b) 1 0
  | (b, k+1) := let eb := a0*b in
    scale (eb + mul_nat a0 k) a + opow_aux eb a0 (mul_nat a m) k m
  end
end

instance : has_pow onote onote := ⟨opow⟩

theorem opow_def (o₁ o₂ : onote) : o₁ ^ o₂ = opow._match_1 o₂ (split o₁) := rfl

theorem split_eq_scale_split' : ∀ {o o' m} [NF o], split' o = (o', m) → split o = (scale 1 o', m)
| 0            o' m h p := by injection p; substs o' m; refl
| (oadd e n a) o' m h p := begin
  by_cases e0 : e = 0; simp [e0, split, split'] at p ⊢,
  { rcases p with ⟨rfl, rfl⟩, exact ⟨rfl, rfl⟩ },
  { revert p, cases h' : split' a with a' m',
    haveI := h.fst, haveI := h.snd,
    simp [split_eq_scale_split' h', split, split'],
    have : 1 + (e - 1) = e,
    { refine repr_inj.1 _, simp,
      have := mt repr_inj.1 e0,
      exact ordinal.add_sub_cancel_of_le (one_le_iff_ne_zero.2 this) },
    intros, substs o' m, simp [scale, this] }
end

theorem NF_repr_split' : ∀ {o o' m} [NF o], split' o = (o', m) → NF o' ∧ repr o = ω * repr o' + m
| 0            o' m h p := by injection p; substs o' m; simp [NF.zero]
| (oadd e n a) o' m h p := begin
  by_cases e0 : e = 0; simp [e0, split, split'] at p ⊢,
  { rcases p with ⟨rfl, rfl⟩,
    simp [h.zero_of_zero e0, NF.zero] },
  { revert p, cases h' : split' a with a' m',
    haveI := h.fst, haveI := h.snd,
    cases NF_repr_split' h' with IH₁ IH₂,
    simp [IH₂, split'],
    intros, substs o' m,
    have : (ω : ordinal.{0}) ^ repr e = ω ^ (1 : ordinal.{0}) * ω ^ (repr e - 1),
    { have := mt repr_inj.1 e0,
      rw [← opow_add, ordinal.add_sub_cancel_of_le (one_le_iff_ne_zero.2 this)] },
    refine ⟨NF.oadd (by apply_instance) _ _, _⟩,
    { simp at this ⊢,
      refine IH₁.below_of_lt' ((mul_lt_mul_iff_left omega_pos).1 $
        lt_of_le_of_lt (le_add_right _ m') _),
      rw [← this, ← IH₂], exact h.snd'.repr_lt },
    { rw this, simp [mul_add, mul_assoc, add_assoc] } }
end

theorem scale_eq_mul (x) [NF x] : ∀ o [NF o], scale x o = oadd x 1 0 * o
| 0            h := rfl
| (oadd e n a) h := begin
  simp [(*)], simp [mul, scale],
  haveI := h.snd,
  by_cases e0 : e = 0,
  { rw scale_eq_mul, simp [e0, h.zero_of_zero, show x + 0 = x, from repr_inj.1 (by simp)] },
  { simp [e0, scale_eq_mul, (*)] }
end

instance NF_scale (x) [NF x] (o) [NF o] : NF (scale x o) :=
by rw scale_eq_mul; apply_instance

@[simp] theorem repr_scale (x) [NF x] (o) [NF o] : repr (scale x o) = ω ^ repr x * repr o :=
by simp [scale_eq_mul]

theorem NF_repr_split {o o' m} [NF o] (h : split o = (o', m)) : NF o' ∧ repr o = repr o' + m :=
begin
  cases e : split' o with a n,
  cases NF_repr_split' e with s₁ s₂, resetI,
  rw split_eq_scale_split' e at h,
  injection h, substs o' n,
  simp [repr_scale, s₂.symm],
  apply_instance
end

theorem split_dvd {o o' m} [NF o] (h : split o = (o', m)) : ω ∣ repr o' :=
begin
  cases e : split' o with a n,
  rw split_eq_scale_split' e at h,
  injection h, subst o',
  cases NF_repr_split' e, resetI, simp
end

theorem split_add_lt {o e n a m} [NF o] (h : split o = (oadd e n a, m)) : repr a + m < ω ^ repr e :=
begin
  cases NF_repr_split h with h₁ h₂,
  cases h₁.of_dvd_omega (split_dvd h) with e0 d,
  have := h₁.fst, have := h₁.snd,
  apply principal_add_omega_opow _ h₁.snd'.repr_lt (lt_of_lt_of_le (nat_lt_omega _) _),
  simpa using opow_le_opow_right omega_pos (one_le_iff_ne_zero.2 e0),
end

@[simp] theorem mul_nat_eq_mul (n o) : mul_nat o n = o * of_nat n :=
by cases o; cases n; refl

instance NF_mul_nat (o) [NF o] (n) : NF (mul_nat o n) :=
by simp; apply_instance

instance NF_opow_aux (e a0 a) [NF e] [NF a0] [NF a] : ∀ k m, NF (opow_aux e a0 a k m)
| k     0     := by cases k; exact NF.zero
| 0     (m+1) := NF.oadd_zero _ _
| (k+1) (m+1) := by haveI := NF_opow_aux k;
  simp [opow_aux, nat.succ_ne_zero]; apply_instance

instance NF_opow (o₁ o₂) [NF o₁] [NF o₂] : NF (o₁ ^ o₂) :=
begin
  cases e₁ : split o₁ with a m,
  have na := (NF_repr_split e₁).1,
  cases e₂ : split' o₂ with b' k,
  haveI := (NF_repr_split' e₂).1,
  casesI a with a0 n a',
  { cases m with m,
    { by_cases o₂ = 0; simp [pow, opow, *]; apply_instance },
    { by_cases m = 0,
      { simp only [pow, opow, *, zero_def], apply_instance },
      { simp [pow, opow, *, - npow_eq_pow], apply_instance } } },
  { simp [pow, opow, e₁, e₂, split_eq_scale_split' e₂],
    have := na.fst,
    cases k with k; simp [opow]; resetI; apply_instance }
end

theorem scale_opow_aux (e a0 a : onote) [NF e] [NF a0] [NF a] :
  ∀ k m, repr (opow_aux e a0 a k m) = ω ^ repr e * repr (opow_aux 0 a0 a k m)
| 0     m := by cases m; simp [opow_aux]
| (k+1) m := by by_cases m = 0; simp [h, opow_aux, mul_add, opow_add, mul_assoc, scale_opow_aux]

theorem repr_opow_aux₁ {e a} [Ne : NF e] [Na : NF a] {a' : ordinal} (e0 : repr e ≠ 0)
  (h : a' < (ω : ordinal.{0}) ^ repr e) (aa : repr a = a') (n : ℕ+) :
  ((ω : ordinal.{0}) ^ repr e * (n:ℕ) + a') ^ (ω : ordinal.{0}) =
  (ω ^ repr e) ^ (ω : ordinal.{0}) :=
begin
  subst aa,
  have No := Ne.oadd n (Na.below_of_lt' h),
  have := omega_le_oadd e n a, unfold repr at this,
  refine le_antisymm _ (opow_le_opow_left _ this),
  apply (opow_le_of_limit ((opow_pos _ omega_pos).trans_le this).ne' omega_is_limit).2,
  intros b l,
  have := (No.below_of_lt (lt_succ _)).repr_lt, unfold repr at this,
  apply (opow_le_opow_left b $ this.le).trans,
  rw [← opow_mul, ← opow_mul],
  apply opow_le_opow_right omega_pos,
  cases le_or_lt ω (repr e) with h h,
  { apply (mul_le_mul_left' (le_succ b) _).trans,
    rw [←add_one_eq_succ, add_mul_succ _ (one_add_of_omega_le h), add_one_eq_succ,
        succ_le_iff, mul_lt_mul_iff_left (ordinal.pos_iff_ne_zero.2 e0)],
    exact omega_is_limit.2 _ l },
  { apply (principal_mul_omega (omega_is_limit.2 _ h) l).le.trans,
    simpa using mul_le_mul_right' (one_le_iff_ne_zero.2 e0) ω }
end

section
local infixr (name := ordinal.pow) ^ := @pow ordinal.{0} ordinal ordinal.has_pow

theorem repr_opow_aux₂ {a0 a'} [N0 : NF a0] [Na' : NF a'] (m : ℕ)
  (d : ω ∣ repr a')
  (e0 : repr a0 ≠ 0) (h : repr a' + m < ω ^ repr a0) (n : ℕ+) (k : ℕ) :
  let R := repr (opow_aux 0 a0 (oadd a0 n a' * of_nat m) k m) in
  (k ≠ 0 → R < (ω ^ repr a0) ^ succ k) ∧
  (ω ^ repr a0) ^ k * (ω ^ repr a0 * (n:ℕ) + repr a') + R =
    (ω ^ repr a0 * (n:ℕ) + repr a' + m) ^ succ k :=
begin
  intro,
  haveI No : NF (oadd a0 n a') :=
    N0.oadd n (Na'.below_of_lt' $ lt_of_le_of_lt (le_add_right _ _) h),
  induction k with k IH, {cases m; simp [opow_aux, R]},
  rename R R', let R := repr (opow_aux 0 a0 (oadd a0 n a' * of_nat m) k m),
  let ω0 := ω ^ repr a0, let α' := ω0 * n + repr a',
  change (k ≠ 0 → R < ω0 ^ succ k) ∧ ω0 ^ k * α' + R = (α' + m) ^ succ k at IH,
  have RR : R' = ω0 ^ k * (α' * m) + R,
  { by_cases m = 0; simp [h, R', opow_aux, R, opow_mul],
    { cases k; simp [opow_aux] }, { refl } },
  have α0 : 0 < α', {simpa [α', lt_def, repr] using oadd_pos a0 n a'},
  have ω00 : 0 < ω0 ^ k := opow_pos _ (opow_pos _ omega_pos),
  have Rl : R < ω ^ (repr a0 * succ ↑k),
  { by_cases k0 : k = 0,
    { simp [k0],
      refine lt_of_lt_of_le _ (opow_le_opow_right omega_pos (one_le_iff_ne_zero.2 e0)),
      cases m with m; simp [k0, R, opow_aux, omega_pos],
      rw [←add_one_eq_succ, ←nat.cast_succ], apply nat_lt_omega },
    { rw opow_mul, exact IH.1 k0 } },
  refine ⟨λ_, _, _⟩,
  { rw [RR, ← opow_mul _ _ (succ k.succ)],
    have e0 := ordinal.pos_iff_ne_zero.2 e0,
    have rr0 := lt_of_lt_of_le e0 (le_add_left _ _),
    apply principal_add_omega_opow,
    { simp [opow_mul, ω0, opow_add, mul_assoc],
      rw [mul_lt_mul_iff_left ω00, ← ordinal.opow_add],
      have := (No.below_of_lt _).repr_lt, unfold repr at this,
      refine mul_lt_omega_opow rr0 this (nat_lt_omega _),
      simpa using (add_lt_add_iff_left (repr a0)).2 e0 },
    { refine lt_of_lt_of_le Rl (opow_le_opow_right omega_pos $
        mul_le_mul_left' (succ_le_succ_iff.2 (nat_cast_le.2 (le_of_lt k.lt_succ_self))) _) } },
  calc
        ω0 ^ k.succ * α' + R'
      = ω0 ^ succ k * α' + (ω0 ^ k * α' * m + R) : by rw [nat_cast_succ, RR, ← mul_assoc]
  ... = (ω0 ^ k * α' + R) * α' + (ω0 ^ k * α' + R) * m : _
  ... = (α' + m) ^ succ k.succ : by rw [← mul_add, nat_cast_succ, opow_succ, IH.2],
  congr' 1,
  { have αd : ω ∣ α' := dvd_add (dvd_mul_of_dvd_left
      (by simpa using opow_dvd_opow ω (one_le_iff_ne_zero.2 e0)) _) d,
    rw [mul_add (ω0 ^ k), add_assoc, ← mul_assoc, ← opow_succ,
        add_mul_limit _ (is_limit_iff_omega_dvd.2 ⟨ne_of_gt α0, αd⟩), mul_assoc,
        @mul_omega_dvd n (nat_cast_pos.2 n.pos) (nat_lt_omega _) _ αd],
    apply @add_absorp _ (repr a0 * succ k),
    { refine principal_add_omega_opow _ _ Rl,
      rw [opow_mul, opow_succ, mul_lt_mul_iff_left ω00],
      exact No.snd'.repr_lt },
    { have := mul_le_mul_left' (one_le_iff_pos.2 $ nat_cast_pos.2 n.pos) (ω0 ^ succ k),
      rw opow_mul, simpa [-opow_succ] } },
  { cases m,
    { have : R = 0, {cases k; simp [R, opow_aux]}, simp [this] },
    { rw [nat_cast_succ, add_mul_succ],
      apply add_absorp Rl,
      rw [opow_mul, opow_succ],
      apply mul_le_mul_left',
      simpa [α', repr] using omega_le_oadd a0 n a' } }
end

end

theorem repr_opow (o₁ o₂) [NF o₁] [NF o₂] : repr (o₁ ^ o₂) = repr o₁ ^ repr o₂ :=
begin
  cases e₁ : split o₁ with a m,
  cases NF_repr_split e₁ with N₁ r₁,
  cases a with a0 n a',
  { cases m with m,
    { by_cases o₂ = 0; simp [opow_def, opow, e₁, h, r₁],
      have := mt repr_inj.1 h, rw zero_opow this },
    { cases e₂ : split' o₂ with b' k,
      cases NF_repr_split' e₂ with _ r₂,
      by_cases m = 0; simp [opow_def, opow, e₁, h, r₁, e₂, r₂, -nat.cast_succ],
      rw [opow_add, opow_mul, opow_omega _ (nat_lt_omega _)],
      simpa using nat_cast_lt.2 (nat.succ_lt_succ $ pos_iff_ne_zero.2 h) } },
  { haveI := N₁.fst, haveI := N₁.snd,
    cases N₁.of_dvd_omega (split_dvd e₁) with a00 ad,
    have al := split_add_lt e₁,
    have aa : repr (a' + of_nat m) = repr a' + m, {simp},
    cases e₂ : split' o₂ with b' k,
    cases NF_repr_split' e₂ with _ r₂,
    simp [opow_def, opow, e₁, r₁, split_eq_scale_split' e₂],
    cases k with k; resetI,
    { simp [opow, r₂, opow_mul, repr_opow_aux₁ a00 al aa, add_assoc] },
    { simp [opow, r₂, opow_add, opow_mul, mul_assoc, add_assoc],
      rw [repr_opow_aux₁ a00 al aa, scale_opow_aux], simp [opow_mul],
      rw [← mul_add, ← add_assoc ((ω : ordinal.{0}) ^ repr a0 * (n:ℕ))], congr' 1,
      rw [← opow_succ],
      exact (repr_opow_aux₂ _ ad a00 al _ _).2 } }
end

/-- Given an ordinal, returns `inl none` for `0`, `inl (some a)` for `a+1`, and
  `inr f` for a limit ordinal `a`, where `f i` is a sequence converging to `a`. -/
def fundamental_sequence : onote → option onote ⊕ (ℕ → onote)
| zero := sum.inl none
| (oadd a m b) :=
  match fundamental_sequence b with
  | sum.inr f := sum.inr (λ i, oadd a m (f i))
  | sum.inl (some b') := sum.inl (some (oadd a m b'))
  | sum.inl none := match fundamental_sequence a, m.nat_pred with
    | sum.inl none, 0 := sum.inl (some zero)
    | sum.inl none, m+1 := sum.inl (some (oadd zero m.succ_pnat zero))
    | sum.inl (some a'), 0 := sum.inr (λ i, oadd a' i.succ_pnat zero)
    | sum.inl (some a'), m+1 := sum.inr (λ i, oadd a m.succ_pnat (oadd a' i.succ_pnat zero))
    | sum.inr f, 0 := sum.inr (λ i, oadd (f i) 1 zero)
    | sum.inr f, m+1 := sum.inr (λ i, oadd a m.succ_pnat (oadd (f i) 1 zero))
    end
  end

private theorem exists_lt_add {α} [hα : nonempty α] {o : ordinal} {f : α → ordinal}
  (H : ∀ ⦃a⦄, a < o → ∃ i, a < f i) {b : ordinal} ⦃a⦄ (h : a < b + o) : ∃ i, a < b + f i :=
begin
  cases lt_or_le a b with h h',
  { obtain ⟨i⟩ := id hα, exact ⟨i, h.trans_le (le_add_right _ _)⟩ },
  { rw [← ordinal.add_sub_cancel_of_le h', add_lt_add_iff_left] at h,
    refine (H h).imp (λ i H, _),
    rwa [← ordinal.add_sub_cancel_of_le h', add_lt_add_iff_left] }
end

private theorem exists_lt_mul_omega' {o : ordinal} ⦃a⦄ (h : a < o * ω) : ∃ i : ℕ, a < o * ↑i + o :=
begin
  obtain ⟨i, hi, h'⟩ := (lt_mul_of_limit omega_is_limit).1 h,
  obtain ⟨i, rfl⟩ := lt_omega.1 hi,
  exact ⟨i, h'.trans_le (le_add_right _ _)⟩
end

local infixr (name := ordinal.pow) ^ := @pow ordinal ordinal ordinal.has_pow
private theorem exists_lt_omega_opow' {α} {o b : ordinal}
  (hb : 1 < b) (ho : o.is_limit) {f : α → ordinal}
  (H : ∀ ⦃a⦄, a < o → ∃ i, a < f i) ⦃a⦄ (h : a < b ^ o) : ∃ i, a < b ^ f i :=
begin
  obtain ⟨d, hd, h'⟩ := (lt_opow_of_limit (zero_lt_one.trans hb).ne' ho).1 h,
  exact (H hd).imp (λ i hi, h'.trans $ (opow_lt_opow_iff_right hb).2 hi)
end

/-- The property satisfied by `fundamental_sequence o`:
  * `inl none` means `o = 0`
  * `inl (some a)` means `o = succ a`
  * `inr f` means `o` is a limit ordinal and `f` is a
    strictly increasing sequence which converges to `o` -/
def fundamental_sequence_prop (o : onote) : option onote ⊕ (ℕ → onote) → Prop
| (sum.inl none) := o = 0
| (sum.inl (some a)) := o.repr = succ a.repr ∧ (o.NF → a.NF)
| (sum.inr f) := o.repr.is_limit ∧
  (∀ i, f i < f (i + 1) ∧ f i < o ∧ (o.NF → (f i).NF)) ∧
  (∀ a, a < o.repr → ∃ i, a < (f i).repr)

theorem fundamental_sequence_has_prop (o) : fundamental_sequence_prop o (fundamental_sequence o) :=
begin
  induction o with a m b iha ihb, {exact rfl},
  rw [fundamental_sequence],
  rcases e : b.fundamental_sequence with ⟨_|b'⟩|f;
    simp only [fundamental_sequence, fundamental_sequence_prop];
    rw [e, fundamental_sequence_prop] at ihb,
  { rcases e : a.fundamental_sequence with ⟨_|a'⟩|f; cases e' : m.nat_pred with m';
      simp only [fundamental_sequence, fundamental_sequence_prop];
      rw [e, fundamental_sequence_prop] at iha;
      try { rw show m = 1,
        { have := pnat.nat_pred_add_one m, rw [e'] at this, exact pnat.coe_inj.1 this.symm } };
      try { rw show m = m'.succ.succ_pnat,
        { rw [← e', ← pnat.coe_inj, nat.succ_pnat_coe, ← nat.add_one, pnat.nat_pred_add_one] } };
      simp only [repr, iha, ihb, opow_lt_opow_iff_right one_lt_omega,
        add_lt_add_iff_left, add_zero, coe_coe, eq_self_iff_true, lt_add_iff_pos_right,
        lt_def, mul_one, nat.cast_zero, nat.cast_succ, nat.succ_pnat_coe, opow_succ,
        opow_zero, mul_add_one, pnat.one_coe, succ_zero, true_and, _root_.zero_add,
        zero_def],
    { apply_instance },
    { exact ⟨rfl, infer_instance⟩ },
    { have := opow_pos _ omega_pos,
      refine ⟨mul_is_limit this omega_is_limit,
        λ i, ⟨this, _, λ H, @NF.oadd_zero _ _ (iha.2 H.fst)⟩, exists_lt_mul_omega'⟩,
      rw [← mul_succ, ← nat_cast_succ, ordinal.mul_lt_mul_iff_left this],
      apply nat_lt_omega },
    { have := opow_pos _ omega_pos,
      refine ⟨
        add_is_limit _ (mul_is_limit this omega_is_limit), λ i, ⟨this, _, _⟩,
        exists_lt_add exists_lt_mul_omega'⟩,
      { rw [← mul_succ, ← nat_cast_succ, ordinal.mul_lt_mul_iff_left this],
        apply nat_lt_omega },
      { refine λ H, H.fst.oadd _ (NF.below_of_lt' _ (@NF.oadd_zero _ _ (iha.2 H.fst))),
        rw [repr, repr, add_zero, iha.1, opow_succ, ordinal.mul_lt_mul_iff_left this],
        apply nat_lt_omega } },
    { rcases iha with ⟨h1, h2, h3⟩,
      refine ⟨opow_is_limit one_lt_omega h1, λ i, _, exists_lt_omega_opow' one_lt_omega h1 h3⟩,
      obtain ⟨h4, h5, h6⟩ := h2 i, exact ⟨h4, h5, λ H, @NF.oadd_zero _ _ (h6 H.fst)⟩ },
    { rcases iha with ⟨h1, h2, h3⟩,
      refine ⟨add_is_limit _ (opow_is_limit one_lt_omega h1), λ i, _,
        exists_lt_add (exists_lt_omega_opow' one_lt_omega h1 h3)⟩,
      obtain ⟨h4, h5, h6⟩ := h2 i,
      refine ⟨h4, h5, λ H, H.fst.oadd _ (NF.below_of_lt' _ (@NF.oadd_zero _ _ (h6 H.fst)))⟩,
      rwa [repr, repr, add_zero, coe_coe, pnat.one_coe, nat.cast_one, mul_one,
        opow_lt_opow_iff_right one_lt_omega] } },
  { refine ⟨by rw [repr, ihb.1, add_succ, repr],
      λ H, H.fst.oadd _ (NF.below_of_lt' _ (ihb.2 H.snd))⟩,
    have := H.snd'.repr_lt, rw ihb.1 at this,
    exact (lt_succ _).trans this },
  { rcases ihb with ⟨h1, h2, h3⟩,
    simp only [repr],
    exact ⟨ordinal.add_is_limit _ h1,
      λ i, ⟨oadd_lt_oadd_3 (h2 i).1, oadd_lt_oadd_3 (h2 i).2.1, λ H, H.fst.oadd _
        (NF.below_of_lt' (lt_trans (h2 i).2.1 H.snd'.repr_lt) ((h2 i).2.2 H.snd))⟩,
      exists_lt_add h3⟩ }
end

/-- The fast growing hierarchy for ordinal notations `< ε₀`. This is a sequence of
functions `ℕ → ℕ` indexed by ordinals, with the definition:
* `f_0(n) = n + 1`
* `f_(α+1)(n) = f_α^[n](n)`
* `f_α(n) = f_(α[n])(n)` where `α` is a limit ordinal
   and `α[i]` is the fundamental sequence converging to `α` -/
def fast_growing : onote → ℕ → ℕ
| o :=
  match fundamental_sequence o, fundamental_sequence_has_prop o with
  | sum.inl none, _ := nat.succ
  | sum.inl (some a), h :=
    have a < o, { rw [lt_def, h.1], apply lt_succ },
    λ i, (fast_growing a)^[i] i
  | sum.inr f, h := λ i, have f i < o, from (h.2.1 i).2.1, fast_growing (f i) i
  end
using_well_founded
{ rel_tac := λ _ _, `[exact ⟨_, inv_image.wf repr ordinal.lt_wf⟩],
  dec_tac := `[assumption] }

theorem fast_growing_def
  {o : onote} {x} (e : fundamental_sequence o = x) :
    fast_growing o =
    fast_growing._match_1 o
      (λ a _ _, a.fast_growing)
      (λ f _ i _, (f i).fast_growing i)
      x (e ▸ fundamental_sequence_has_prop _) :=
by { subst x, rw [fast_growing] }

theorem fast_growing_zero' (o : onote) (h : fundamental_sequence o = sum.inl none) :
  fast_growing o = nat.succ := by { rw [fast_growing_def h], refl }
theorem fast_growing_succ (o) {a} (h : fundamental_sequence o = sum.inl (some a)) :
  fast_growing o = λ i, ((fast_growing a)^[i] i) := by { rw [fast_growing_def h], refl }
theorem fast_growing_limit (o) {f} (h : fundamental_sequence o = sum.inr f) :
  fast_growing o = λ i, fast_growing (f i) i := by { rw [fast_growing_def h], refl }

@[simp]

@[simp] theorem fast_growing_one : fast_growing 1 = (λ n, 2 * n) :=
begin
  rw [@fast_growing_succ 1 0 rfl], funext i, rw [two_mul, fast_growing_zero],
  suffices : ∀ a b, nat.succ^[a] b = b + a, from this _ _,
  intros a b, induction a; simp [*, function.iterate_succ', nat.add_succ],
end

section
local infixr (name := pow) ^ := pow
@[simp] theorem fast_growing_two : fast_growing 2 = (λ n, 2 ^ n * n) :=
begin
  rw [@fast_growing_succ 2 1 rfl], funext i, rw [fast_growing_one],
  suffices : ∀ a b, (λ (n : ℕ), 2 * n)^[a] b = 2 ^ a * b, from this _ _,
  intros a b, induction a; simp [*, function.iterate_succ', pow_succ, mul_assoc],
end
end

/-- We can extend the fast growing hierarchy one more step to `ε₀` itself,
  using `ω^(ω^...^ω^0)` as the fundamental sequence converging to `ε₀` (which is not an `onote`).
  Extending the fast growing hierarchy beyond this requires a definition of fundamental sequence
  for larger ordinals. -/
def fast_growing_ε₀ (i : ℕ) : ℕ := fast_growing ((λ a, a.oadd 1 0)^[i] 0) i

theorem fast_growing_ε₀_zero : fast_growing_ε₀ 0 = 1 := by simp [fast_growing_ε₀]

theorem fast_growing_ε₀_one : fast_growing_ε₀ 1 = 2 :=
by simp [fast_growing_ε₀, show oadd 0 1 0 = 1, from rfl]

theorem fast_growing_ε₀_two : fast_growing_ε₀ 2 = 2048 :=
by norm_num [fast_growing_ε₀,
  show oadd 0 1 0 = 1, from rfl,
  @fast_growing_limit (oadd 1 1 0) _ rfl,
  show oadd 0 (2:nat).succ_pnat 0 = 3, from rfl,
  @fast_growing_succ 3 2 rfl]

end onote

/-- The type of normal ordinal notations. (It would have been
  nicer to define this right in the inductive type, but `NF o`
  requires `repr` which requires `onote`, so all these things
  would have to be defined at once, which messes up the VM
  representation.) -/
def nonote := {o : onote // o.NF}

instance : decidable_eq nonote := by unfold nonote; apply_instance

namespace nonote
open onote

instance NF (o : nonote) : NF o.1 := o.2

/-- Construct a `nonote` from an ordinal notation
  (and infer normality) -/
def mk (o : onote) [h : NF o] : nonote := ⟨o, h⟩

/-- The ordinal represented by an ordinal notation.
  (This function is noncomputable because ordinal
  arithmetic is noncomputable. In computational applications
  `nonote` can be used exclusively without reference
  to `ordinal`, but this function allows for correctness
  results to be stated.) -/
noncomputable def repr (o : nonote) : ordinal := o.1.repr

instance : has_to_string nonote := ⟨λ x, x.1.to_string⟩
instance : has_repr nonote := ⟨λ x, x.1.repr'⟩

instance : preorder nonote :=
{ le       := λ x y, repr x ≤ repr y,
  lt       := λ x y, repr x < repr y,
  le_refl  := λ a, @le_refl ordinal _ _,
  le_trans := λ a b c, @le_trans ordinal _ _ _ _,
  lt_iff_le_not_le := λ a b, @lt_iff_le_not_le ordinal _ _ _ }

instance : has_zero nonote := ⟨⟨0, NF.zero⟩⟩
instance : inhabited nonote := ⟨0⟩

theorem lt_wf : @well_founded nonote (<) := inv_image.wf repr ordinal.lt_wf
instance : well_founded_lt nonote := ⟨lt_wf⟩
instance : has_well_founded nonote := ⟨(<), lt_wf⟩

/-- Convert a natural number to an ordinal notation -/
def of_nat (n : ℕ) : nonote := ⟨of_nat n, ⟨⟨_, NF_below_of_nat _⟩⟩⟩

/-- Compare ordinal notations -/
def cmp (a b : nonote) : ordering :=
cmp a.1 b.1

theorem cmp_compares : ∀ a b : nonote, (cmp a b).compares a b
| ⟨a, ha⟩ ⟨b, hb⟩ := begin
  resetI,
  dsimp [cmp], have := onote.cmp_compares a b,
  cases onote.cmp a b; try {exact this},
  exact subtype.mk_eq_mk.2 this
end

instance : linear_order nonote := linear_order_of_compares cmp cmp_compares
instance : is_well_order nonote (<) := { }

/-- Asserts that `repr a < ω ^ repr b`. Used in `nonote.rec_on` -/
def below (a b : nonote) : Prop := NF_below a.1 (repr b)

/-- The `oadd` pseudo-constructor for `nonote` -/
def oadd (e : nonote) (n : ℕ+) (a : nonote) (h : below a e) : nonote := ⟨_, NF.oadd e.2 n h⟩

/-- This is a recursor-like theorem for `nonote` suggesting an
  inductive definition, which can't actually be defined this
  way due to conflicting dependencies. -/
@[elab_as_eliminator] def rec_on {C : nonote → Sort*} (o : nonote)
  (H0 : C 0)
  (H1 : ∀ e n a h, C e → C a → C (oadd e n a h)) : C o :=
begin
  cases o with o h, induction o with e n a IHe IHa,
  { exact H0 },
  { exact H1 ⟨e, h.fst⟩ n ⟨a, h.snd⟩ h.snd' (IHe _) (IHa _) }
end

/-- Addition of ordinal notations -/
instance : has_add nonote := ⟨λ x y, mk (x.1 + y.1)⟩

theorem repr_add (a b) : repr (a + b) = repr a + repr b :=
onote.repr_add a.1 b.1

/-- Subtraction of ordinal notations -/
instance : has_sub nonote := ⟨λ x y, mk (x.1 - y.1)⟩

theorem repr_sub (a b) : repr (a - b) = repr a - repr b :=
onote.repr_sub a.1 b.1

/-- Multiplication of ordinal notations -/
instance : has_mul nonote := ⟨λ x y, mk (x.1 * y.1)⟩

theorem repr_mul (a b) : repr (a * b) = repr a * repr b :=
onote.repr_mul a.1 b.1

/-- Exponentiation of ordinal notations -/
def opow (x y : nonote) := mk (x.1.opow y.1)

theorem repr_opow (a b) : repr (opow a b) = repr a ^ repr b :=
onote.repr_opow a.1 b.1

end nonote