/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nathaniel Thomas, Jeremy Avigad, Johannes Hölzl, Mario Carneiro, Anne Baanen,
  Frédéric Dupuis, Heather Macbeth

! This file was ported from Lean 3 source module algebra.module.equiv
! leanprover-community/mathlib commit ea94d7cd54ad9ca6b7710032868abb7c6a104c9c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Module.LinearMap

/-!
# (Semi)linear equivalences

In this file we define

* `LinearEquiv σ M M₂`, `M ≃ₛₗ[σ] M₂`: an invertible semilinear map. Here, `σ` is a `RingHom`
  from `R` to `R₂` and an `e : M ≃ₛₗ[σ] M₂` satisfies `e (c • x) = (σ c) • (e x)`. The plain
  linear version, with `σ` being `RingHom.id R`, is denoted by `M ≃ₗ[R] M₂`, and the
  star-linear version (with `σ` being `starRingEnd`) is denoted by `M ≃ₗ⋆[R] M₂`.

## Implementation notes

To ensure that composition works smoothly for semilinear equivalences, we use the typeclasses
`RingHomCompTriple`, `RingHomInvPair` and `RingHomSurjective` from
`Algebra/Ring/CompTypeclasses`.

The group structure on automorphisms, `LinearEquiv.automorphismGroup`, is provided elsewhere.

## TODO

* Parts of this file have not yet been generalized to semilinear maps

## Tags

linear equiv, linear equivalences, linear isomorphism, linear isomorphic
-/

open Function

universe u u' v w x y z

variable {R : Type _} {R₁ : Type _} {R₂ : Type _} {R₃ : Type _}
variable {k : Type _} {S : Type _} {M : Type _} {M₁ : Type _} {M₂ : Type _} {M₃ : Type _}
variable {N₁ : Type _} {N₂ : Type _} {N₃ : Type _} {N₄ : Type _} {ι : Type _}

section

/-- A linear equivalence is an invertible linear map. -/
--Porting note: TODO @[nolint has_nonempty_instance]
structure LinearEquiv {R : Type _} {S : Type _} [Semiring R] [Semiring S] (σ : R →+* S)
  {σ' : S →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ] (M : Type _) (M₂ : Type _)
  [AddCommMonoid M] [AddCommMonoid M₂] [Module R M] [Module S M₂] extends LinearMap σ M M₂, M ≃+ M₂
#align linear_equiv LinearEquiv

attribute [coe] LinearEquiv.toLinearMap

/-- The linear map underlying a linear equivalence. -/
add_decl_doc LinearEquiv.toLinearMap
#align linear_equiv.to_linear_map LinearEquiv.toLinearMap

/-- The additive equivalence of types underlying a linear equivalence. -/
add_decl_doc LinearEquiv.toAddEquiv
#align linear_equiv.to_add_equiv LinearEquiv.toAddEquiv

/-- The backwards directed function underlying a linear equivalence. -/
add_decl_doc LinearEquiv.invFun

/-- `LinearEquiv.invFun` is a right inverse to the linear equivalence's underlying function. -/
add_decl_doc LinearEquiv.right_inv

/-- `LinearEquiv.invFun` is a left inverse to the linear equivalence's underlying function. -/
add_decl_doc LinearEquiv.left_inv

/-- The notation `M ≃ₛₗ[σ] M₂` denotes the type of linear equivalences between `M` and `M₂` over a
ring homomorphism `σ`. -/
notation:50 M " ≃ₛₗ[" σ "] " M₂ => LinearEquiv σ M M₂

/-- The notation `M ≃ₗ [R] M₂` denotes the type of linear equivalences between `M` and `M₂` over
a plain linear map `M →ₗ M₂`. -/
notation:50 M " ≃ₗ[" R "] " M₂ => LinearEquiv (RingHom.id R) M M₂

/-- The notation `M ≃ₗ⋆[R] M₂` denotes the type of star-linear equivalences between `M` and `M₂`
over the `⋆` endomorphism of the underlying starred ring `R`. -/
notation:50 M " ≃ₗ⋆[" R "] " M₂ => LinearEquiv (starRingEnd R) M M₂

/-- `SemilinearEquivClass F σ M M₂` asserts `F` is a type of bundled `σ`-semilinear equivs
`M → M₂`.

See also `LinearEquivClass F R M M₂` for the case where `σ` is the identity map on `R`.

A map `f` between an `R`-module and an `S`-module over a ring homomorphism `σ : R →+* S`
is semilinear if it satisfies the two properties `f (x + y) = f x + f y` and
`f (c • x) = (σ c) • f x`. -/
class SemilinearEquivClass (F : Type _) {R S : outParam (Type _)} [Semiring R] [Semiring S]
  (σ : outParam <| R →+* S) {σ' : outParam <| S →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
  (M M₂ : outParam (Type _)) [AddCommMonoid M] [AddCommMonoid M₂] [Module R M] [Module S M₂] extends
  AddEquivClass F M M₂ where
  /-- Applying a semilinear equivalence `f` over `σ` to `r • x ` equals `σ r • f x`. -/
  map_smulₛₗ : ∀ (f : F) (r : R) (x : M), f (r • x) = σ r • f x
#align semilinear_equiv_class SemilinearEquivClass

-- `R, S, σ, σ'` become metavars, but it's OK since they are outparams.

/-- `LinearEquivClass F R M M₂` asserts `F` is a type of bundled `R`-linear equivs `M → M₂`.
This is an abbreviation for `SemilinearEquivClass F (RingHom.id R) M M₂`.
-/
abbrev LinearEquivClass (F : Type _) (R M M₂ : outParam (Type _)) [Semiring R] [AddCommMonoid M]
    [AddCommMonoid M₂] [Module R M] [Module R M₂] :=
  SemilinearEquivClass F (RingHom.id R) M M₂
#align linear_equiv_class LinearEquivClass

end

namespace SemilinearEquivClass

variable (F : Type _) [Semiring R] [Semiring S]

variable [AddCommMonoid M] [AddCommMonoid M₁] [AddCommMonoid M₂]

variable [Module R M] [Module S M₂] {σ : R →+* S} {σ' : S →+* R}

@[infer_tc_goals_rl, nolint dangerousInstance]
instance (priority := 100) [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
  [s : SemilinearEquivClass F σ M M₂] : SemilinearMapClass F σ M M₂ :=
  { s with
    coe := (s.coe : F → M → M₂)
    coe_injective' := @FunLike.coe_injective F _ _ _ }

end SemilinearEquivClass

namespace LinearEquiv

section AddCommMonoid

variable {M₄ : Type _}

variable [Semiring R] [Semiring S]

section

variable [AddCommMonoid M] [AddCommMonoid M₁] [AddCommMonoid M₂]

variable [Module R M] [Module S M₂] {σ : R →+* S} {σ' : S →+* R}

variable [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]

instance : Coe (M ≃ₛₗ[σ] M₂) (M →ₛₗ[σ] M₂) :=
  ⟨toLinearMap⟩

-- This exists for compatibility, previously `≃ₗ[R]` extended `≃` instead of `≃+`.
/-- The equivalence of types underlying a linear equivalence. -/
def toEquiv : (M ≃ₛₗ[σ] M₂) → M ≃ M₂ := fun f => f.toAddEquiv.toEquiv
#align linear_equiv.to_equiv LinearEquiv.toEquiv

theorem toEquiv_injective : Function.Injective (toEquiv : (M ≃ₛₗ[σ] M₂) → M ≃ M₂) :=
  fun ⟨⟨⟨_, _⟩, _⟩, _, _, _⟩ ⟨⟨⟨_, _⟩, _⟩, _, _, _⟩ h =>
    (LinearEquiv.mk.injEq _ _ _ _ _ _ _ _).mpr
      ⟨LinearMap.ext (congr_fun (Equiv.mk.inj h).1), (Equiv.mk.inj h).2⟩
#align linear_equiv.to_equiv_injective LinearEquiv.toEquiv_injective

@[simp]
theorem toEquiv_inj {e₁ e₂ : M ≃ₛₗ[σ] M₂} : e₁.toEquiv = e₂.toEquiv ↔ e₁ = e₂ :=
  toEquiv_injective.eq_iff
#align linear_equiv.to_equiv_inj LinearEquiv.toEquiv_inj

theorem toLinearMap_injective : Injective (toLinearMap : (M ≃ₛₗ[σ] M₂) → M →ₛₗ[σ] M₂) :=
  fun _ _ H => toEquiv_injective <| Equiv.ext <| LinearMap.congr_fun H
#align linear_equiv.to_linear_map_injective LinearEquiv.toLinearMap_injective

@[simp, norm_cast]
theorem toLinearMap_inj {e₁ e₂ : M ≃ₛₗ[σ] M₂} : (↑e₁ : M →ₛₗ[σ] M₂) = e₂ ↔ e₁ = e₂ :=
  toLinearMap_injective.eq_iff
#align linear_equiv.to_linear_map_inj LinearEquiv.toLinearMap_inj

instance : SemilinearEquivClass (M ≃ₛₗ[σ] M₂) σ M M₂ where
  inv := LinearEquiv.invFun
  coe_injective' _ _ h _ := toLinearMap_injective (FunLike.coe_injective h)
  left_inv := LinearEquiv.left_inv
  right_inv := LinearEquiv.right_inv
  map_add := (·.map_add') --map_add' Porting note: TODO why did I need to change this?
  map_smulₛₗ := (·.map_smul') --map_smul' Porting note: TODO why did I need to change this?

-- Porting note: moved to a lower line since there is no shortcut `CoeFun` instance any more
@[simp]
theorem coe_mk {to_fun inv_fun map_add map_smul left_inv right_inv} :
    (⟨⟨⟨to_fun, map_add⟩, map_smul⟩, inv_fun, left_inv, right_inv⟩ : M ≃ₛₗ[σ] M₂) = to_fun := rfl
#align linear_equiv.coe_mk LinearEquiv.coe_mk

theorem coe_injective : @Injective (M ≃ₛₗ[σ] M₂) (M → M₂) CoeFun.coe :=
  FunLike.coe_injective
#align linear_equiv.coe_injective LinearEquiv.coe_injective

end

section

variable [Semiring R₁] [Semiring R₂] [Semiring R₃]

variable [AddCommMonoid M] [AddCommMonoid M₁] [AddCommMonoid M₂]

variable [AddCommMonoid M₃] [AddCommMonoid M₄]

variable [AddCommMonoid N₁] [AddCommMonoid N₂]

variable {module_M : Module R M} {module_S_M₂ : Module S M₂} {σ : R →+* S} {σ' : S →+* R}

variable {re₁ : RingHomInvPair σ σ'} {re₂ : RingHomInvPair σ' σ}

variable (e e' : M ≃ₛₗ[σ] M₂)

@[simp, norm_cast]
theorem coe_coe : ⇑(e : M →ₛₗ[σ] M₂) = e :=
  rfl
#align linear_equiv.coe_coe LinearEquiv.coe_coe

@[simp]
theorem coe_toEquiv : ⇑(e.toEquiv) = e :=
  rfl
#align linear_equiv.coe_to_equiv LinearEquiv.coe_toEquiv

@[simp]
theorem coe_toLinearMap : ⇑e.toLinearMap = e :=
  rfl
#align linear_equiv.coe_to_linear_map LinearEquiv.coe_toLinearMap

-- porting note: no longer a `simp`
theorem toFun_eq_coe : e.toFun = e := rfl
#align linear_equiv.to_fun_eq_coe LinearEquiv.toFun_eq_coe

section

variable {e e'}

@[ext]
theorem ext (h : ∀ x, e x = e' x) : e = e' :=
  FunLike.ext _ _ h
#align linear_equiv.ext LinearEquiv.ext

theorem ext_iff : e = e' ↔ ∀ x, e x = e' x :=
  FunLike.ext_iff
#align linear_equiv.ext_iff LinearEquiv.ext_iff

protected theorem congr_arg {x x'} : x = x' → e x = e x' :=
  FunLike.congr_arg e
#align linear_equiv.congr_arg LinearEquiv.congr_arg

protected theorem congr_fun (h : e = e') (x : M) : e x = e' x :=
  FunLike.congr_fun h x
#align linear_equiv.congr_fun LinearEquiv.congr_fun

end

section

variable (M R)

/-- The identity map is a linear equivalence. -/
@[refl]
def refl [Module R M] : M ≃ₗ[R] M :=
  { LinearMap.id, Equiv.refl M with }
#align linear_equiv.refl LinearEquiv.refl

end

@[simp]
theorem refl_apply [Module R M] (x : M) : refl R M x = x :=
  rfl
#align linear_equiv.refl_apply LinearEquiv.refl_apply

/-- Linear equivalences are symmetric. -/
@[symm]
def symm (e : M ≃ₛₗ[σ] M₂) : M₂ ≃ₛₗ[σ'] M :=
  { e.toLinearMap.inverse e.invFun e.left_inv e.right_inv,
    e.toEquiv.symm with
    toFun := e.toLinearMap.inverse e.invFun e.left_inv e.right_inv
    invFun := e.toEquiv.symm.invFun
    map_smul' := fun r x => by dsimp only; rw [map_smulₛₗ] }
#align linear_equiv.symm LinearEquiv.symm

-- Porting note: this is new
/-- See Note [custom simps projection] -/
def Simps.apply {R : Type _} {S : Type _} [Semiring R] [Semiring S]
    {σ : R →+* S} {σ' : S →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
    {M : Type _} {M₂ : Type _} [AddCommMonoid M] [AddCommMonoid M₂] [Module R M] [Module S M₂]
    (e : M ≃ₛₗ[σ] M₂) : M → M₂ :=
  e
#align linear_equiv.simps.apply LinearEquiv.Simps.apply

/-- See Note [custom simps projection] -/
def Simps.symm_apply {R : Type _} {S : Type _} [Semiring R] [Semiring S]
    {σ : R →+* S} {σ' : S →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
    {M : Type _} {M₂ : Type _} [AddCommMonoid M] [AddCommMonoid M₂] [Module R M] [Module S M₂]
    (e : M ≃ₛₗ[σ] M₂) : M₂ → M :=
  e.symm
#align linear_equiv.simps.symm_apply LinearEquiv.Simps.symm_apply

initialize_simps_projections LinearEquiv (toFun → apply, invFun → symm_apply)

@[simp]
theorem invFun_eq_symm : e.invFun = e.symm :=
  rfl
#align linear_equiv.inv_fun_eq_symm LinearEquiv.invFun_eq_symm

@[simp]
theorem coe_toEquiv_symm : e.toEquiv.symm = e.symm :=
  rfl
#align linear_equiv.coe_to_equiv_symm LinearEquiv.coe_toEquiv_symm

variable {module_M₁ : Module R₁ M₁} {module_M₂ : Module R₂ M₂} {module_M₃ : Module R₃ M₃}

variable {module_N₁ : Module R₁ N₁} {module_N₂ : Module R₁ N₂}

variable {σ₁₂ : R₁ →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R₁ →+* R₃}

variable {σ₂₁ : R₂ →+* R₁} {σ₃₂ : R₃ →+* R₂} {σ₃₁ : R₃ →+* R₁}

variable [RingHomCompTriple σ₁₂ σ₂₃ σ₁₃]

variable [RingHomCompTriple σ₃₂ σ₂₁ σ₃₁]

variable {re₁₂ : RingHomInvPair σ₁₂ σ₂₁} {re₂₃ : RingHomInvPair σ₂₃ σ₃₂}

variable [RingHomInvPair σ₁₃ σ₃₁] {re₂₁ : RingHomInvPair σ₂₁ σ₁₂}

variable {re₃₂ : RingHomInvPair σ₃₂ σ₂₃} [RingHomInvPair σ₃₁ σ₁₃]

variable (e₁₂ : M₁ ≃ₛₗ[σ₁₂] M₂) (e₂₃ : M₂ ≃ₛₗ[σ₂₃] M₃)

-- Porting note: Lean 4 aggressively removes unused variables declared using `variables`, so
-- we have to list all the variables explicitly here in order to match the Lean 3 signature.
set_option linter.unusedVariables false in
/-- Linear equivalences are transitive. -/
-- Note: the `ring_hom_comp_triple σ₃₂ σ₂₁ σ₃₁` is unused, but is convenient to carry around
-- implicitly for lemmas like `linear_equiv.self_trans_symm`.
@[trans, nolint unusedArguments]
def trans
    [RingHomCompTriple σ₁₂ σ₂₃ σ₁₃] [RingHomCompTriple σ₃₂ σ₂₁ σ₃₁]
    {re₁₂ : RingHomInvPair σ₁₂ σ₂₁} {re₂₃ : RingHomInvPair σ₂₃ σ₃₂}
    [RingHomInvPair σ₁₃ σ₃₁] {re₂₁ : RingHomInvPair σ₂₁ σ₁₂}
    {re₃₂ : RingHomInvPair σ₃₂ σ₂₃} [RingHomInvPair σ₃₁ σ₁₃]
    (e₁₂ : M₁ ≃ₛₗ[σ₁₂] M₂) (e₂₃ : M₂ ≃ₛₗ[σ₂₃] M₃) : M₁ ≃ₛₗ[σ₁₃] M₃ :=
  { e₂₃.toLinearMap.comp e₁₂.toLinearMap, e₁₂.toEquiv.trans e₂₃.toEquiv with }
#align linear_equiv.trans LinearEquiv.trans

/-- The notation `e₁ ≪≫ₗ e₂` denotes the composition of the linear equivalences `e₁` and `e₂`. -/
infixl:80 " ≪≫ₗ " =>
  @LinearEquiv.trans _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (RingHom.id _) (RingHom.id _) (RingHom.id _)
    (RingHom.id _) (RingHom.id _) (RingHom.id _) RingHomCompTriple.ids RingHomCompTriple.ids
    RingHomInvPair.ids RingHomInvPair.ids RingHomInvPair.ids RingHomInvPair.ids RingHomInvPair.ids
    RingHomInvPair.ids

variable {e₁₂} {e₂₃}

@[simp]
theorem coe_toAddEquiv : e.toAddEquiv = e :=
  rfl
#align linear_equiv.coe_to_add_equiv LinearEquiv.coe_toAddEquiv

/-- The two paths coercion can take to an `AddMonoidHom` are equivalent -/
theorem toAddMonoidHom_commutes : e.toLinearMap.toAddMonoidHom = e.toAddEquiv.toAddMonoidHom :=
  rfl
#align linear_equiv.to_add_monoid_hom_commutes LinearEquiv.toAddMonoidHom_commutes

@[simp]
theorem trans_apply (c : M₁) : (e₁₂.trans e₂₃ : M₁ ≃ₛₗ[σ₁₃] M₃) c = e₂₃ (e₁₂ c) :=
  rfl
#align linear_equiv.trans_apply LinearEquiv.trans_apply

theorem coe_trans :
    (e₁₂.trans e₂₃ : M₁ →ₛₗ[σ₁₃] M₃) = (e₂₃ : M₂ →ₛₗ[σ₂₃] M₃).comp (e₁₂ : M₁ →ₛₗ[σ₁₂] M₂) :=
  rfl
#align linear_equiv.coe_trans LinearEquiv.coe_trans

@[simp]
theorem apply_symm_apply (c : M₂) : e (e.symm c) = c :=
  e.right_inv c
#align linear_equiv.apply_symm_apply LinearEquiv.apply_symm_apply

@[simp]
theorem symm_apply_apply (b : M) : e.symm (e b) = b :=
  e.left_inv b
#align linear_equiv.symm_apply_apply LinearEquiv.symm_apply_apply

@[simp]
theorem trans_symm : (e₁₂.trans e₂₃ : M₁ ≃ₛₗ[σ₁₃] M₃).symm = e₂₃.symm.trans e₁₂.symm :=
  rfl
#align linear_equiv.trans_symm LinearEquiv.trans_symm

theorem symm_trans_apply (c : M₃) :
    (e₁₂.trans e₂₃ : M₁ ≃ₛₗ[σ₁₃] M₃).symm c = e₁₂.symm (e₂₃.symm c) :=
  rfl
#align linear_equiv.symm_trans_apply LinearEquiv.symm_trans_apply

@[simp]
theorem trans_refl : e.trans (refl S M₂) = e :=
  toEquiv_injective e.toEquiv.trans_refl
#align linear_equiv.trans_refl LinearEquiv.trans_refl

@[simp]
theorem refl_trans : (refl R M).trans e = e :=
  toEquiv_injective e.toEquiv.refl_trans
#align linear_equiv.refl_trans LinearEquiv.refl_trans

theorem symm_apply_eq {x y} : e.symm x = y ↔ x = e y :=
  e.toEquiv.symm_apply_eq
#align linear_equiv.symm_apply_eq LinearEquiv.symm_apply_eq

theorem eq_symm_apply {x y} : y = e.symm x ↔ e y = x :=
  e.toEquiv.eq_symm_apply
#align linear_equiv.eq_symm_apply LinearEquiv.eq_symm_apply

theorem eq_comp_symm {α : Type _} (f : M₂ → α) (g : M₁ → α) : f = g ∘ e₁₂.symm ↔ f ∘ e₁₂ = g :=
  e₁₂.toEquiv.eq_comp_symm f g
#align linear_equiv.eq_comp_symm LinearEquiv.eq_comp_symm

theorem comp_symm_eq {α : Type _} (f : M₂ → α) (g : M₁ → α) : g ∘ e₁₂.symm = f ↔ g = f ∘ e₁₂ :=
  e₁₂.toEquiv.comp_symm_eq f g
#align linear_equiv.comp_symm_eq LinearEquiv.comp_symm_eq

theorem eq_symm_comp {α : Type _} (f : α → M₁) (g : α → M₂) : f = e₁₂.symm ∘ g ↔ e₁₂ ∘ f = g :=
  e₁₂.toEquiv.eq_symm_comp f g
#align linear_equiv.eq_symm_comp LinearEquiv.eq_symm_comp

theorem symm_comp_eq {α : Type _} (f : α → M₁) (g : α → M₂) : e₁₂.symm ∘ g = f ↔ g = e₁₂ ∘ f :=
  e₁₂.toEquiv.symm_comp_eq f g
#align linear_equiv.symm_comp_eq LinearEquiv.symm_comp_eq

variable [RingHomCompTriple σ₂₁ σ₁₃ σ₂₃] [RingHomCompTriple σ₃₁ σ₁₂ σ₃₂]

theorem eq_comp_toLinearMap_symm (f : M₂ →ₛₗ[σ₂₃] M₃) (g : M₁ →ₛₗ[σ₁₃] M₃) :
    f = g.comp e₁₂.symm.toLinearMap ↔ f.comp e₁₂.toLinearMap = g := by
  constructor <;> intro H <;> ext
  · simp [H, e₁₂.toEquiv.eq_comp_symm f g]
  · simp [← H, ← e₁₂.toEquiv.eq_comp_symm f g]
#align linear_equiv.eq_comp_to_linear_map_symm LinearEquiv.eq_comp_toLinearMap_symm

theorem comp_toLinearMap_symm_eq (f : M₂ →ₛₗ[σ₂₃] M₃) (g : M₁ →ₛₗ[σ₁₃] M₃) :
    g.comp e₁₂.symm.toLinearMap = f ↔ g = f.comp e₁₂.toLinearMap := by
  constructor <;> intro H <;> ext
  · simp [← H, ← e₁₂.toEquiv.comp_symm_eq f g]
  · simp [H, e₁₂.toEquiv.comp_symm_eq f g]
#align linear_equiv.comp_to_linear_map_symm_eq LinearEquiv.comp_toLinearMap_symm_eq

theorem eq_toLinearMap_symm_comp (f : M₃ →ₛₗ[σ₃₁] M₁) (g : M₃ →ₛₗ[σ₃₂] M₂) :
    f = e₁₂.symm.toLinearMap.comp g ↔ e₁₂.toLinearMap.comp f = g := by
  constructor <;> intro H <;> ext
  · simp [H, e₁₂.toEquiv.eq_symm_comp f g]
  · simp [← H, ← e₁₂.toEquiv.eq_symm_comp f g]
#align linear_equiv.eq_to_linear_map_symm_comp LinearEquiv.eq_toLinearMap_symm_comp

theorem toLinearMap_symm_comp_eq (f : M₃ →ₛₗ[σ₃₁] M₁) (g : M₃ →ₛₗ[σ₃₂] M₂) :
    e₁₂.symm.toLinearMap.comp g = f ↔ g = e₁₂.toLinearMap.comp f := by
  constructor <;> intro H <;> ext
  · simp [← H, ← e₁₂.toEquiv.symm_comp_eq f g]
  · simp [H, e₁₂.toEquiv.symm_comp_eq f g]
#align linear_equiv.to_linear_map_symm_comp_eq LinearEquiv.toLinearMap_symm_comp_eq

@[simp]
theorem refl_symm [Module R M] : (refl R M).symm = LinearEquiv.refl R M :=
  rfl
#align linear_equiv.refl_symm LinearEquiv.refl_symm

@[simp]
theorem self_trans_symm (f : M₁ ≃ₛₗ[σ₁₂] M₂) : f.trans f.symm = LinearEquiv.refl R₁ M₁ := by
  ext x
  simp
#align linear_equiv.self_trans_symm LinearEquiv.self_trans_symm

@[simp]
theorem symm_trans_self (f : M₁ ≃ₛₗ[σ₁₂] M₂) : f.symm.trans f = LinearEquiv.refl R₂ M₂ := by
  ext x
  simp
#align linear_equiv.symm_trans_self LinearEquiv.symm_trans_self

@[simp]  -- Porting note: norm_cast
theorem refl_toLinearMap [Module R M] : (LinearEquiv.refl R M : M →ₗ[R] M) = LinearMap.id :=
  rfl
#align linear_equiv.refl_to_linear_map LinearEquiv.refl_toLinearMap

@[simp]  -- Porting note: norm_cast
theorem comp_coe [Module R M] [Module R M₂] [Module R M₃] (f : M ≃ₗ[R] M₂) (f' : M₂ ≃ₗ[R] M₃) :
    (f' : M₂ →ₗ[R] M₃).comp (f : M →ₗ[R] M₂) = (f.trans f' : M ≃ₗ[R] M₃) :=
  rfl
#align linear_equiv.comp_coe LinearEquiv.comp_coe

@[simp]
theorem mk_coe (f h₁ h₂) : (LinearEquiv.mk e f h₁ h₂ : M ≃ₛₗ[σ] M₂) = e :=
  ext fun _ => rfl
#align linear_equiv.mk_coe LinearEquiv.mk_coe

protected theorem map_add (a b : M) : e (a + b) = e a + e b :=
  map_add e a b
#align linear_equiv.map_add LinearEquiv.map_add

protected theorem map_zero : e 0 = 0 :=
  map_zero e
#align linear_equiv.map_zero LinearEquiv.map_zero

protected theorem map_smulₛₗ (c : R) (x : M) : e (c • x) = (σ : R → S) c • e x :=
  e.map_smul' c x
#align linear_equiv.map_smulₛₗ LinearEquiv.map_smulₛₗ

theorem map_smul (e : N₁ ≃ₗ[R₁] N₂) (c : R₁) (x : N₁) : e (c • x) = c • e x :=
  map_smulₛₗ e c x
#align linear_equiv.map_smul LinearEquiv.map_smul

theorem map_eq_zero_iff {x : M} : e x = 0 ↔ x = 0 :=
  e.toAddEquiv.map_eq_zero_iff
#align linear_equiv.map_eq_zero_iff LinearEquiv.map_eq_zero_iff

theorem map_ne_zero_iff {x : M} : e x ≠ 0 ↔ x ≠ 0 :=
  e.toAddEquiv.map_ne_zero_iff
#align linear_equiv.map_ne_zero_iff LinearEquiv.map_ne_zero_iff

@[simp]
theorem symm_symm (e : M ≃ₛₗ[σ] M₂) : e.symm.symm = e := by
  cases e
  rfl
#align linear_equiv.symm_symm LinearEquiv.symm_symm

theorem symm_bijective [Module R M] [Module S M₂] [RingHomInvPair σ' σ] [RingHomInvPair σ σ'] :
    Function.Bijective (symm : (M ≃ₛₗ[σ] M₂) → M₂ ≃ₛₗ[σ'] M) :=
  Equiv.bijective
    ⟨(symm : (M ≃ₛₗ[σ] M₂) → M₂ ≃ₛₗ[σ'] M), (symm : (M₂ ≃ₛₗ[σ'] M) → M ≃ₛₗ[σ] M₂), symm_symm,
      symm_symm⟩
#align linear_equiv.symm_bijective LinearEquiv.symm_bijective

@[simp]
theorem mk_coe' (f h₁ h₂ h₃ h₄) :
    (LinearEquiv.mk ⟨⟨f, h₁⟩, h₂⟩ (⇑e) h₃ h₄ : M₂ ≃ₛₗ[σ'] M) = e.symm :=
  symm_bijective.injective <| ext fun _ => rfl
#align linear_equiv.mk_coe' LinearEquiv.mk_coe'

@[simp]
theorem symm_mk (f h₁ h₂ h₃ h₄) :
    (⟨⟨⟨e, h₁⟩, h₂⟩, f, h₃, h₄⟩ : M ≃ₛₗ[σ] M₂).symm =
      {
        (⟨⟨⟨e, h₁⟩, h₂⟩, f, h₃, h₄⟩ : M ≃ₛₗ[σ]
              M₂).symm with
        toFun := f
        invFun := e } :=
  rfl
#align linear_equiv.symm_mk LinearEquiv.symm_mk

@[simp]
theorem coe_symm_mk [Module R M] [Module R M₂]
    {to_fun inv_fun map_add map_smul left_inv right_inv} :
    ⇑(⟨⟨⟨to_fun, map_add⟩, map_smul⟩, inv_fun, left_inv, right_inv⟩ : M ≃ₗ[R] M₂).symm = inv_fun :=
  rfl
#align linear_equiv.coe_symm_mk LinearEquiv.coe_symm_mk

protected theorem bijective : Function.Bijective e :=
  e.toEquiv.bijective
#align linear_equiv.bijective LinearEquiv.bijective

protected theorem injective : Function.Injective e :=
  e.toEquiv.injective
#align linear_equiv.injective LinearEquiv.injective

protected theorem surjective : Function.Surjective e :=
  e.toEquiv.surjective
#align linear_equiv.surjective LinearEquiv.surjective

protected theorem image_eq_preimage (s : Set M) : e '' s = e.symm ⁻¹' s :=
  e.toEquiv.image_eq_preimage s
#align linear_equiv.image_eq_preimage LinearEquiv.image_eq_preimage

protected theorem image_symm_eq_preimage (s : Set M₂) : e.symm '' s = e ⁻¹' s :=
  e.toEquiv.symm.image_eq_preimage s
#align linear_equiv.image_symm_eq_preimage LinearEquiv.image_symm_eq_preimage

end

/-- Interpret a `RingEquiv` `f` as an `f`-semilinear equiv. -/
@[simps]
def _root_.RingEquiv.toSemilinearEquiv (f : R ≃+* S) :
    haveI := RingHomInvPair.of_ringEquiv f
    haveI := RingHomInvPair.symm (↑f : R →+* S) (f.symm : S →+* R)
    R ≃ₛₗ[(↑f : R →+* S)] S :=
  haveI := RingHomInvPair.of_ringEquiv f
  haveI := RingHomInvPair.symm (↑f : R →+* S) (f.symm : S →+* R)
  { f with
    toFun := f
    map_smul' := f.map_mul }
#align ring_equiv.to_semilinear_equiv RingEquiv.toSemilinearEquiv
#align ring_equiv.to_semilinear_equiv_symm_apply RingEquiv.toSemilinearEquiv_symm_apply

variable [Semiring R₁] [Semiring R₂] [Semiring R₃]

variable [AddCommMonoid M] [AddCommMonoid M₁] [AddCommMonoid M₂]

/-- An involutive linear map is a linear equivalence. -/
def ofInvolutive {σ σ' : R →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
    {_ : Module R M} (f : M →ₛₗ[σ] M) (hf : Involutive f) : M ≃ₛₗ[σ] M :=
  { f, hf.toPerm f with }
#align linear_equiv.of_involutive LinearEquiv.ofInvolutive

@[simp]
theorem coe_ofInvolutive {σ σ' : R →+* R} [RingHomInvPair σ σ'] [RingHomInvPair σ' σ]
    {_ : Module R M} (f : M →ₛₗ[σ] M) (hf : Involutive f) : ⇑(ofInvolutive f hf) = f :=
  rfl
#align linear_equiv.coe_of_involutive LinearEquiv.coe_ofInvolutive

section RestrictScalars

variable (R)
variable [Module R M] [Module R M₂] [Module S M] [Module S M₂]
  [LinearMap.CompatibleSMul M M₂ R S]

/-- If `M` and `M₂` are both `R`-semimodules and `S`-semimodules and `R`-semimodule structures
are defined by an action of `R` on `S` (formally, we have two scalar towers), then any `S`-linear
equivalence from `M` to `M₂` is also an `R`-linear equivalence.

See also `LinearMap.restrictScalars`. -/
@[simps]
def restrictScalars (f : M ≃ₗ[S] M₂) : M ≃ₗ[R] M₂ :=
  { f.toLinearMap.restrictScalars R with
    toFun := f
    invFun := f.symm
    left_inv := f.left_inv
    right_inv := f.right_inv }
#align linear_equiv.restrict_scalars LinearEquiv.restrictScalars
#align linear_equiv.restrict_scalars_apply LinearEquiv.restrictScalars_apply
#align linear_equiv.restrict_scalars_symm_apply LinearEquiv.restrictScalars_symm_apply

theorem restrictScalars_injective :
    Function.Injective (restrictScalars R : (M ≃ₗ[S] M₂) → M ≃ₗ[R] M₂) := fun _ _ h =>
  ext (LinearEquiv.congr_fun h : _)
#align linear_equiv.restrict_scalars_injective LinearEquiv.restrictScalars_injective

@[simp]
theorem restrictScalars_inj (f g : M ≃ₗ[S] M₂) :
    f.restrictScalars R = g.restrictScalars R ↔ f = g :=
  (restrictScalars_injective R).eq_iff
#align linear_equiv.restrict_scalars_inj LinearEquiv.restrictScalars_inj

end RestrictScalars

section Automorphisms

variable [Module R M]

instance automorphismGroup : Group (M ≃ₗ[R] M) where
  mul f g := g.trans f
  one := LinearEquiv.refl R M
  inv f := f.symm
  mul_assoc f g h := rfl
  mul_one f := ext fun x => rfl
  one_mul f := ext fun x => rfl
  mul_left_inv f := ext <| f.left_inv
#align linear_equiv.automorphism_group LinearEquiv.automorphismGroup

/-- Restriction from `R`-linear automorphisms of `M` to `R`-linear endomorphisms of `M`,
promoted to a monoid hom. -/
@[simps]
def automorphismGroup.toLinearMapMonoidHom : (M ≃ₗ[R] M) →* M →ₗ[R] M where
  toFun e := e.toLinearMap
  map_one' := rfl
  map_mul' _ _ := rfl
#align linear_equiv.automorphism_group.to_linear_map_monoid_hom LinearEquiv.automorphismGroup.toLinearMapMonoidHom
#align linear_equiv.automorphism_group.to_linear_map_monoid_hom_apply LinearEquiv.automorphismGroup.toLinearMapMonoidHom_apply

/-- The tautological action by `M ≃ₗ[R] M` on `M`.

This generalizes `Function.End.applyMulAction`. -/
instance applyDistribMulAction : DistribMulAction (M ≃ₗ[R] M) M where
  smul := (· <| ·)
  smul_zero := LinearEquiv.map_zero
  smul_add := LinearEquiv.map_add
  one_smul _ := rfl
  mul_smul _ _ _ := rfl
#align linear_equiv.apply_distrib_mul_action LinearEquiv.applyDistribMulAction

@[simp]
protected theorem smul_def (f : M ≃ₗ[R] M) (a : M) : f • a = f a :=
  rfl
#align linear_equiv.smul_def LinearEquiv.smul_def

/-- `LinearEquiv.applyDistribMulAction` is faithful. -/
instance apply_faithfulSMul : FaithfulSMul (M ≃ₗ[R] M) M :=
  ⟨@fun _ _ => LinearEquiv.ext⟩
#align linear_equiv.apply_has_faithful_smul LinearEquiv.apply_faithfulSMul

instance apply_smulCommClass : SMulCommClass R (M ≃ₗ[R] M) M
    where smul_comm r e m := (e.map_smul r m).symm
#align linear_equiv.apply_smul_comm_class LinearEquiv.apply_smulCommClass

instance apply_smulCommClass' : SMulCommClass (M ≃ₗ[R] M) R M
    where smul_comm := LinearEquiv.map_smul
#align linear_equiv.apply_smul_comm_class' LinearEquiv.apply_smulCommClass'

end Automorphisms

section OfSubsingleton

variable (M M₂)
variable [Module R M] [Module R M₂] [Subsingleton M] [Subsingleton M₂]

/-- Any two modules that are subsingletons are isomorphic. -/
@[simps]
def ofSubsingleton : M ≃ₗ[R] M₂ :=
  { (0 : M →ₗ[R] M₂) with
    toFun := fun _ => 0
    invFun := fun _ => 0
    left_inv := fun _ => Subsingleton.elim _ _
    right_inv := fun _ => Subsingleton.elim _ _ }
#align linear_equiv.of_subsingleton LinearEquiv.ofSubsingleton
#align linear_equiv.of_subsingleton_symm_apply LinearEquiv.ofSubsingleton_symm_apply

@[simp]
theorem ofSubsingleton_self : ofSubsingleton M M = refl R M := by
  ext
  simp
#align linear_equiv.of_subsingleton_self LinearEquiv.ofSubsingleton_self

end OfSubsingleton

end AddCommMonoid

end LinearEquiv

namespace Module

/-- `g : R ≃+* S` is `R`-linear when the module structure on `S` is `Module.compHom S g` . -/
@[simps]
def compHom.toLinearEquiv {R S : Type _} [Semiring R] [Semiring S] (g : R ≃+* S) :
    haveI := compHom S (↑g : R →+* S)
    R ≃ₗ[R] S :=
  letI := compHom S (↑g : R →+* S)
  { g with
    toFun := (g : R → S)
    invFun := (g.symm : S → R)
    map_smul' := g.map_mul }
#align module.comp_hom.to_linear_equiv Module.compHom.toLinearEquiv
#align module.comp_hom.to_linear_equiv_symm_apply Module.compHom.toLinearEquiv_symm_apply

end Module

namespace DistribMulAction

variable (R M) [Semiring R] [AddCommMonoid M] [Module R M]

variable [Group S] [DistribMulAction S M] [SMulCommClass S R M]

/-- Each element of the group defines a linear equivalence.

This is a stronger version of `DistribMulAction.toAddEquiv`. -/
@[simps!]
def toLinearEquiv (s : S) : M ≃ₗ[R] M :=
  { toAddEquiv M s, toLinearMap R M s with }
#align distrib_mul_action.to_linear_equiv DistribMulAction.toLinearEquiv
#align distrib_mul_action.to_linear_equiv_apply DistribMulAction.toLinearEquiv_apply
#align distrib_mul_action.to_linear_equiv_symm_apply DistribMulAction.toLinearEquiv_symm_apply

/-- Each element of the group defines a module automorphism.

This is a stronger version of `DistribMulAction.toAddAut`. -/
@[simps]
def toModuleAut : S →* M ≃ₗ[R] M where
  toFun := toLinearEquiv R M
  map_one' := LinearEquiv.ext <| one_smul _
  map_mul' _ _ := LinearEquiv.ext <| mul_smul _ _
#align distrib_mul_action.to_module_aut DistribMulAction.toModuleAut
#align distrib_mul_action.to_module_aut_apply DistribMulAction.toModuleAut_apply

end DistribMulAction

namespace AddEquiv

section AddCommMonoid

variable [Semiring R] [AddCommMonoid M] [AddCommMonoid M₂] [AddCommMonoid M₃]

variable [Module R M] [Module R M₂]

variable (e : M ≃+ M₂)

/-- An additive equivalence whose underlying function preserves `smul` is a linear equivalence. -/
def toLinearEquiv (h : ∀ (c : R) (x), e (c • x) = c • e x) : M ≃ₗ[R] M₂ :=
  { e with map_smul' := h }
#align add_equiv.to_linear_equiv AddEquiv.toLinearEquiv

@[simp]
theorem coe_toLinearEquiv (h : ∀ (c : R) (x), e (c • x) = c • e x) : ⇑(e.toLinearEquiv h) = e :=
  rfl
#align add_equiv.coe_to_linear_equiv AddEquiv.coe_toLinearEquiv

@[simp]
theorem coe_toLinearEquiv_symm (h : ∀ (c : R) (x), e (c • x) = c • e x) :
    ⇑(e.toLinearEquiv h).symm = e.symm :=
  rfl
#align add_equiv.coe_to_linear_equiv_symm AddEquiv.coe_toLinearEquiv_symm

/-- An additive equivalence between commutative additive monoids is a linear equivalence between
ℕ-modules -/
def toNatLinearEquiv : M ≃ₗ[ℕ] M₂ :=
  e.toLinearEquiv fun c a => by
    erw [e.toAddMonoidHom.map_nsmul]
    rfl
#align add_equiv.to_nat_linear_equiv AddEquiv.toNatLinearEquiv

@[simp]
theorem coe_toNatLinearEquiv : ⇑e.toNatLinearEquiv = e :=
  rfl
#align add_equiv.coe_to_nat_linear_equiv AddEquiv.coe_toNatLinearEquiv

@[simp]
theorem toNatLinearEquiv_toAddEquiv : ↑e.toNatLinearEquiv = e := by
  ext
  rfl
#align add_equiv.to_nat_linear_equiv_to_add_equiv AddEquiv.toNatLinearEquiv_toAddEquiv

@[simp]
theorem _root_.LinearEquiv.toAddEquiv_toNatLinearEquiv (e : M ≃ₗ[ℕ] M₂) :
    AddEquiv.toNatLinearEquiv ↑e = e :=
  FunLike.coe_injective rfl
#align linear_equiv.to_add_equiv_to_nat_linear_equiv LinearEquiv.toAddEquiv_toNatLinearEquiv

@[simp]
theorem toNatLinearEquiv_symm : e.toNatLinearEquiv.symm = e.symm.toNatLinearEquiv :=
  rfl
#align add_equiv.to_nat_linear_equiv_symm AddEquiv.toNatLinearEquiv_symm

@[simp]
theorem toNatLinearEquiv_refl : (AddEquiv.refl M).toNatLinearEquiv = LinearEquiv.refl ℕ M :=
  rfl
#align add_equiv.to_nat_linear_equiv_refl AddEquiv.toNatLinearEquiv_refl

@[simp]
theorem toNatLinearEquiv_trans (e₂ : M₂ ≃+ M₃) :
    e.toNatLinearEquiv.trans e₂.toNatLinearEquiv = (e.trans e₂).toNatLinearEquiv :=
  rfl
#align add_equiv.to_nat_linear_equiv_trans AddEquiv.toNatLinearEquiv_trans

end AddCommMonoid

section AddCommGroup

variable [AddCommGroup M] [AddCommGroup M₂] [AddCommGroup M₃]

variable (e : M ≃+ M₂)

/-- An additive equivalence between commutative additive groups is a linear
equivalence between ℤ-modules -/
def toIntLinearEquiv : M ≃ₗ[ℤ] M₂ :=
  e.toLinearEquiv fun c a => e.toAddMonoidHom.map_zsmul a c
#align add_equiv.to_int_linear_equiv AddEquiv.toIntLinearEquiv

@[simp]
theorem coe_toIntLinearEquiv : ⇑e.toIntLinearEquiv = e :=
  rfl
#align add_equiv.coe_to_int_linear_equiv AddEquiv.coe_toIntLinearEquiv

@[simp]
theorem toIntLinearEquiv_toAddEquiv : ↑e.toIntLinearEquiv = e := by
  ext
  rfl
#align add_equiv.to_int_linear_equiv_to_add_equiv AddEquiv.toIntLinearEquiv_toAddEquiv

@[simp]
theorem _root_.LinearEquiv.toAddEquiv_toIntLinearEquiv (e : M ≃ₗ[ℤ] M₂) :
    AddEquiv.toIntLinearEquiv (e : M ≃+ M₂) = e :=
  FunLike.coe_injective rfl
#align linear_equiv.to_add_equiv_to_int_linear_equiv LinearEquiv.toAddEquiv_toIntLinearEquiv

@[simp]
theorem toIntLinearEquiv_symm : e.toIntLinearEquiv.symm = e.symm.toIntLinearEquiv :=
  rfl
#align add_equiv.to_int_linear_equiv_symm AddEquiv.toIntLinearEquiv_symm

@[simp]
theorem toIntLinearEquiv_refl : (AddEquiv.refl M).toIntLinearEquiv = LinearEquiv.refl ℤ M :=
  rfl
#align add_equiv.to_int_linear_equiv_refl AddEquiv.toIntLinearEquiv_refl

@[simp]
theorem toIntLinearEquiv_trans (e₂ : M₂ ≃+ M₃) :
    e.toIntLinearEquiv.trans e₂.toIntLinearEquiv = (e.trans e₂).toIntLinearEquiv :=
  rfl
#align add_equiv.to_int_linear_equiv_trans AddEquiv.toIntLinearEquiv_trans

end AddCommGroup

end AddEquiv


import ring_theory.principal_ideal_domain set_lemmas linear_algebra.basic torsion
open unique_factorization_domain multiset associates

variables {R : Type*} [integral_domain R] [is_principal_ideal_ring R] [decidable_eq R]
          [decidable_eq (associates R)] (r : R)
open_locale classical

local infix ` ~ᵤ ` : 50 := associated
noncomputable theory

@[reducible] def mk' := map associates.mk (factors r)

/-- Given `r, w : R`, multiset of irreducible factors of `r` which are not associated to `w`.-/
def of_dvd' (w : R) : multiset R :=
(filter (λ x, ¬ x ~ᵤ w) $ factors r)

/-- Given `r = p₁ ^ k₁ * ... * pₙ ^ kₙ : R` with pᵢ prime, this is the finite set
`{(r / p₁ ^ k₁), ..., (r / pₙ ^ kₙ)}`. -/
def coprimes' := finset.image (multiset.prod ∘ of_dvd' r) (factors r).to_finset

variables (hr : r ≠ 0)
include hr

lemma prod_factors_eq : prod (mk' r) = associates.mk r :=
by rw [prod_mk, mk_eq_mk_iff_associated]; exact factors_prod hr

variables {w : associates R} {t : R}

/-- If t is an irred factor of r, it divides r. -/
lemma le_of_mem (t) (h : t ∈ factors r) : t ∣ r :=
begin
  have := multiset.dvd_prod h,
  rwa ←dvd_iff_dvd_of_rel_right (factors_prod hr),
end

/-- Given `r t : R`, if `i : ℕ` is the highest power to which `t` divides `r` and *`t` is irreducible*,
i.e. `r = p₁ ^ k₁ * ... * pₙ ^ kₙ * t ^ i` for some primes pᵢ and t prime, then there exist
`(q₁ ^ k₁ * ... * qₙ ^ kₙ) * (s₁ * ... * sᵢ) = r` where each `qⱼ` is associated to each `pⱼ` and each
`sⱼ` is associated to `t`. -/
lemma prod_of_dvd_eq' (t : R) :
  (of_dvd' r t).prod  * (filter (λ x, x ~ᵤ t) $ factors r).prod ~ᵤ r :=
begin
  unfold of_dvd',
  rw ←multiset.prod_add,
  rw add_comm,
  rw filter_add_not,
  exact factors_prod hr,
end

/-- For any irreducible factor `t` of `r`, if `i : ℕ` is the highest power to which
`t` divides `r` then `r \ t ^ i` divides `r`. -/
lemma of_dvd'_dvd : (of_dvd' r t).prod ∣ r :=
begin
  cases prod_of_dvd_eq' r hr t with u hu,
  rw mul_assoc at hu,
  use (filter (λ x, x ~ᵤ t) $ factors r).prod * u,
  rw hu,
end

/-- If `q ∈ coprimes' r` (see coprimes' defn), `q` divides `r`. -/
lemma le_of_mem_coprimes' (q : R) (hq : q ∈ coprimes' r) :
  q ∣ r :=
begin
  unfold coprimes' at hq,
  rw finset.mem_image at hq,
  rcases hq with ⟨i, hm, hi⟩,
  have : r ~ᵤ q * (filter (λ x, x ~ᵤ i) $ factors r).prod,
    by {rw ←hi, symmetry, convert prod_of_dvd_eq' r hr i },
  cases (associated.symm this) with u hu,
  rw mul_assoc at hu,
  use (filter (λ x, x ~ᵤ i) $ factors r).prod * u,
  exact hu.symm,
end

/-- If `r ≠ 0` and `t` divides `r`, t ≠ 0.-/
lemma ne_zero_of_dvd (h : t ∣ r) : t ≠ 0 :=
λ ht0, hr $ zero_dvd_iff.1 $ ht0 ▸ h

/-- If `r ≠ 0`, for any irreducible factor `t` of `r`, if `i : ℕ` is the highest power to which
`t` divides `r` then `r \ t ^ i ≠ 0`. -/
lemma ne_zero_of_dvd' : (of_dvd' r t).prod ≠ 0 :=
ne_zero_of_dvd r hr (of_dvd'_dvd r hr)

/-- Given 2 primes `p q : R`, if one divides the other they are associated. -/
lemma prime_dvd_prime {p q : R} (hp : prime p) (hq : prime q) (hpq : p ∣ q) : p ~ᵤ q :=
begin
  have hpq' := hpq,
  cases hpq with u hu,
  have : q ∣ p * u := ⟨1, by rw hu; rw mul_one⟩,
  cases hq.2.2 _ _ this,
  exact associated_of_dvd_dvd hpq' h,
  cases h with t ht,
  rw ht at hu,
  have H : q * (1 - p * t) = 0, by {rw mul_sub, rw ←mul_assoc, rw mul_comm q p,
    rw mul_assoc, rw ←hu, ring,},
  rw mul_eq_zero at H, cases H with h1 h2,
  exfalso,
  exact hq.1 h1,
  rw sub_eq_zero at h2,
  exfalso,
  exact hp.2.1 (is_unit_of_mul_eq_one p t h2.symm),
end

/-- For any irreducible factor `t` of `r`, if `i : ℕ` is the highest power to which
`t` divides `r` then `t` doesn't divide `r \ t ^ i`. -/
lemma not_le_of_dvd' (hm : t ∈ factors r) : ¬t ∣ (of_dvd' r t).prod :=
λ h,
begin
  rcases exists_mem_factors_of_dvd (ne_zero_of_dvd' r hr) (irreducible_factors hr t hm)
    h with ⟨q, hmq, hq⟩,
  rcases exists_mem_multiset_dvd_of_prime (prime_factors (ne_zero_of_dvd' r hr) q hmq)
  (le_of_mem (of_dvd' r t).prod (ne_zero_of_dvd' r hr) q hmq) with ⟨p, hmp, hqp⟩,
  have hp : prime p := prime_factors hr p (filter_subset _ hmp),
  have ht := associated.trans hq (prime_dvd_prime r hr (prime_factors (ne_zero_of_dvd' r hr) q hmq) hp hqp),
  exact (mem_filter.1 hmp ).2 (associated.symm ht),
end

def wtf : is_monoid_hom (associates.mk) :=
{ map_mul := λ x y : R, associates.mk_mul_mk,
  map_one := associates.one_eq_mk_one }
variables (hu : ¬is_unit r)
include hu

/-- If `r : R` isn't a unit, there exists an irreducible element dividing `r`. -/
lemma exists_mem_of_nonunit : ∃ p, p ∈ factors r :=
exists_mem_of_ne_zero
  (λ h, absurd (by rw [←is_unit_mk, is_unit_iff_eq_one, ←prod_factors_eq r hr,
  @multiset.prod_hom _ _ _ _ (factors r) (associates.mk) (wtf r hr), h, prod_zero,
    associates.one_eq_mk_one]) hu)

/-- If `r : R` isn't a unit, the set `coprimes' r` (see the defn in this file) is nonempty. -/
lemma exists_mem_coprimes'_of_nonunit : ∃ q, q ∈ coprimes' r :=
let ⟨w, h⟩ := exists_mem_of_nonunit r hr hu in
finset.nonempty_iff_ne_empty.2 (λ hn, absurd (finset.image_eq_empty.1 hn)
                             (finset.ne_empty_of_mem (mem_to_finset.2 h)))

/-- Given nonunit nonzero `r : R` and `t : R`, if for all `q` in the set
"Given `r = p₁ ^ k₁ * ... * pₙ ^ kₙ : R` with pᵢ prime, the finite set
`{(r / p₁ ^ k₁), ..., (r / pₙ ^ kₙ)}`", t divides q, then t is a unit. -/
lemma relatively_prime' (H : ∀ q ∈ coprimes' r, t ∣ q) : is_unit t :=
begin
    cases exists_mem_coprimes'_of_nonunit r hr hu,
  apply (@not_not _ _).1, assume hnu,
  have h' : t ≠ 0, by
    {intro hnu,
    exact absurd hnu (by {specialize H w h, have := le_of_mem_coprimes' r hr w h,
    exfalso, apply hr,
    rw ←zero_dvd_iff,
    rw hnu at H,
    exact dvd_trans H this,})},
   cases exists_mem_of_nonunit t h' hnu with x hx,
   have hxm : ∃ y ∈ factors r, x ~ᵤ y,
   by {apply exists_mem_factors_of_dvd hr (irreducible_factors h' x hx),
   apply dvd_trans (le_of_mem t h' x hx),
   apply dvd_trans (H w h) (le_of_mem_coprimes' r hr w h),
   },
   rcases hxm with ⟨y, hmy, hy⟩,
   cases associated.symm hy with u hu,
   have H' : x ∣ (of_dvd' r y).prod, by
   {apply dvd_trans (le_of_mem t h' x hx),
   exact H (of_dvd' r y).prod (finset.mem_image.2 (⟨y, mem_to_finset.2 hmy, rfl⟩)), },
    exact not_le_of_dvd' r hr hmy (dvd_trans (⟨u, hu.symm⟩) H'),
  apply_instance
end

omit hr hu

/-- Given `s : multiset R` and `p : R`, the multiset of elements of `s` associated to `p` is
equal modulo association to a (number-of-elements-of-s-associated-to-p)-tuple of p's, modulo
association. -/
lemma associated_pow' {n : ℕ} {s : multiset R} (h : s.card = n) {p : R} :
  map associates.mk (filter (λ x, x ~ᵤ p) s) =
  map associates.mk (repeat p (filter (λ x, x ~ᵤ p) s).card) :=
begin
  revert s,
  induction n with n hn,
  intros s h0,
  rw card_eq_zero.1 h0, simp only [filter_zero, card_zero, map_zero, repeat_zero],
  intros s hs,
  cases card_pos_iff_exists_mem.1 (by rw hs; exact n.succ_pos) with a ha,
  cases exists_cons_of_mem ha with t ht,
  rw ht,
  cases (classical.em (associated a p)),
  rw @filter_cons_of_pos R (λ x, associated x p) _ _ t h,
  rw map_cons, rw card_cons, rw repeat_succ, rw map_cons,
  rw mk_eq_mk_iff_associated.2 h,
  rw hn (by {rw ht at hs, rw card_cons at hs, exact nat.succ.inj hs}),
  rw @filter_cons_of_neg R (λ x, associated x p) _ _ t h,
  rw hn (by {rw ht at hs, rw card_cons at hs, exact nat.succ.inj hs}),
end

/-- Given multisets `s, t ⊆ R` if s equals t up to association, the product of the
elements of s is associated to the product of the elements of t. -/
lemma associated_prod {n : ℕ} {s t : multiset R} (hs : s.card = n)
  (ht : t.card = n) (h : map associates.mk s = map associates.mk t) :
  associates.mk s.prod = associates.mk t.prod :=
begin
  revert s t,
  induction n with n hn,
  intros s t hs ht h,
  rw card_eq_zero.1 hs,
  rw card_eq_zero.1 ht,
  intros s t hs ht h,
  cases card_pos_iff_exists_mem.1 (by rw hs; exact n.succ_pos) with a ha,
  cases exists_cons_of_mem ha with b hb,
  cases card_pos_iff_exists_mem.1 (by rw ht; exact n.succ_pos) with c hc,
  cases exists_cons_of_mem hc with d hd,
  rw hb, rw hd,
  rw prod_cons, rw prod_cons,
  rw ←mk_mul_mk,
  rw ←mk_mul_mk,
  rw hb at h, rw hd at h,
  rw map_cons at h, rw map_cons at h,
  rw cons_eq_cons at h,
  cases h with h h,
  have hn' := hn (by {rw hb at hs, rw card_cons at hs, exact nat.succ.inj hs})
    (by {rw hd at ht, rw card_cons at ht, exact nat.succ.inj ht}) h.2,
    rw hn', rw h.1,
    cases h with h1 h2,
    cases h2 with cs hcs,
    cases subset_map (show cs ≤ map associates.mk b, by rw hcs.1; exact le_cons_self _ _) with u hu,
  rw hu at hcs,
  rw ←map_cons at hcs, rw ←map_cons at hcs,
  have hbu := hn (by {rw hb at hs, rw card_cons at hs, exact nat.succ.inj hs})
    (show (c :: u).card = n, by {rw  ←card_map associates.mk, rw ←hcs.1,
    rw card_map,
    rw hb at hs, rw card_cons at hs, exact nat.succ.inj hs}) hcs.1,
  rw hbu, rw prod_cons,
  have hdu := hn (by {rw hd at ht, rw card_cons at ht, exact nat.succ.inj ht})
    (show (a :: u).card = n, by {rw  ←card_map associates.mk, rw ←hcs.2,
    rw card_map,
    rw hd at ht, rw card_cons at ht, exact nat.succ.inj ht}) hcs.2,
  rw hdu, rw prod_cons, rw ←associates.mk_mul_mk,
  rw ←associates.mk_mul_mk,
  rw ←mul_assoc, rw mul_comm (associates.mk a), rw mul_assoc,
end

/-- Let `r, p : R` with `p` prime. Then
`p ^ ((number of elements of a factorisation of irred factors of r associated to p) + 1)`
does not divide `r`. -/
lemma fin_pow_dvd {r p : R} (hr : r ≠ 0) (hp : prime p) :
  ¬((p ^ ((filter (λ x, associated x p) (factors r)).card + 1)) ∣ r) :=
begin
  intro h,
  cases h with z hz,
  have ha := @associated_pow' _ _ _ _ _ _ (unique_factorization_domain.factors r) rfl p,
  have ha' := associated_prod rfl (card_repeat _ _) ha,
  cases mk_eq_mk_iff_associated.1 ha' with u hu,
  rw prod_repeat at hu,
  rw pow_succ at hz,
  rw ←hu at hz,
  have hnf := @filter_add_not _ (λ x, associated x p) _ (factors r),
  have hf : (factors r).prod = ((filter (λ (x : R), x ~ᵤ p) (factors r)).prod *
    (filter (λ (a : R), ¬(λ (x : R), x ~ᵤ p) a) (factors r)).prod) := by
    {rw ←multiset.prod_add, rw hnf},
  cases (factors_prod hr) with w hw,
  conv at hz {to_lhs, rw ←hw, rw hf},
  rw ←mul_assoc p at hz,
  rw mul_comm p at hz,
  rw ←sub_eq_zero at hz,
  repeat {rw mul_assoc at hz},
  rw ←mul_sub at hz,
  have h0 := or.resolve_left (mul_eq_zero.1 hz) (by {intro hp0,
  have huh := prod_eq_zero_iff'.1 hp0,
  exact not_prime_zero ((prime_iff_of_associated (mem_filter.1 huh).2).2 hp),
  }),
  rw sub_eq_zero at h0,
  have h0' := units.eq_mul_inv_iff_mul_eq.2 h0,
  rcases exists_mem_multiset_dvd_of_prime hp (by {rw h0', exact ⟨(u : R) * z * (w⁻¹ : units R),
    by rw mul_assoc⟩}) with ⟨s, hms, hs⟩,
  have hms := mem_filter.1 hms,
  have hps := prime_dvd_prime r hr hp (prime_factors hr s hms.1) hs,
  exact hms.2 hps.symm,
end


/-
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_arithmetic

/-!
# 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
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 $ power_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 _ _ _ _ _ (power_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 [cmp],
  cases h₁ : cmp e₁ e₂; intro h; try {cases h},
  have := eq_of_cmp_eq h₁, subst e₂,
  revert h, cases h₂ : _root_.cmp (n₁:ℕ) n₂; intro h; try {cases h},
  have := eq_of_cmp_eq h, subst a₂,
  rw [_root_.cmp, cmp_using_eq_eq] at h₂,
  have := subtype.eq (eq_of_incomp h₂), subst n₂, simp
end

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₂ (ordinal.lt_succ_self _)⟩⟩

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 power_pos _ omega_pos },
  { rw repr,
    refine lt_of_lt_of_le ((ordinal.add_lt_add_iff_left _).2 IH) _,
    rw ← mul_succ,
    refine le_trans (mul_le_mul_left _ $ ordinal.succ_le.2 $ nat_lt_omega _) _,
    rw ← power_succ,
    exact power_le_power_right omega_pos (ordinal.succ_le.2 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 $ (power_lt_power_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 ordinal.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 ((ordinal.add_lt_add_iff_left _).2 h₁.snd'.repr_lt)
    (le_trans _ (le_add_right _ _)),
  rwa [← mul_succ, mul_le_mul_iff_left (power_pos _ omega_pos),
       ordinal.succ_le, 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 (ordinal.add_lt_add_iff_left _).2 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,
    have := subtype.eq (eq_of_incomp nh), subst n₂,
    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_power {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 $ dvd_mul_of_dvd_left (power_dvd_power _ L) _).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 [← power_one ω, ← one_le_iff_ne_zero]; exact h.of_dvd_omega_power

/-- `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₂⟩⟩ := ⟨(b₁.le_total 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 $
        power_pos (repr e') omega_pos).2 (nat_cast_le.2 n'.pos) } },
  { change e = e' at ee, substI e',
    rw [← add_assoc, ← ordinal.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 [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₂,
      { simp [en], rwa [add_sub_add_cancel] },
      { simp [en, -repr],
        exact (sub_eq_zero_iff_le.2 $ le_of_lt $ oadd_lt_oadd_2 h₁ $
          lt_of_le_of_ne (nat.sub_eq_zero_iff_le.1 mn) (mt pnat.eq en)).symm } },
    { simp [nat.succ_pnat, -nat.cast_succ],
      rw [(nat.sub_eq_iff_eq_add $ le_of_lt $ nat.lt_of_sub_eq_succ mn).1 mn,
          add_comm, nat.cast_add, ordinal.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⟩

@[simp] theorem zero_mul (o : onote) : 0 * o = 0 := by cases o; refl
@[simp] theorem mul_zero (o : onote) : o * 0 = 0 := 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, ordinal.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 (ordinal.zero_mul _).symm
| (oadd e₁ n₁ a₁) 0               h₁ h₂ := (ordinal.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 $ power_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, power_add, ordinal.mul_add],
    rw ← mul_assoc, congr' 2,
    have := mt repr_inj.1 e0,
    rw [add_mul_limit ao (power_is_limit_left omega_is_limit this),
        mul_assoc, mul_omega_dvd (nat_cast_pos.2 n₁.pos) (nat_lt_omega _)],
    simpa using power_dvd_power ω (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 `power` -/
def power_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 + power_aux k m

/-- `power o₁ o₂` calculates the ordinal notation for
  the ordinal exponential `o₁ ^ o₂`. -/
def power (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 + power_aux eb a0 (mul_nat a m) k m
  end
end

instance : has_pow onote onote := ⟨power⟩

theorem power_def (o₁ o₂ : onote) : o₁ ^ o₂ = power._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 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 : ω ^ repr e = ω ^ (1 : ordinal.{0}) * ω ^ (repr e - 1),
    { have := mt repr_inj.1 e0,
      rw [← power_add, 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 [ordinal.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,
  refine add_lt_omega_power h₁.snd'.repr_lt (lt_of_lt_of_le (nat_lt_omega _) _),
  simpa using power_le_power_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_power_aux (e a0 a) [NF e] [NF a0] [NF a] : ∀ k m, NF (power_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_power_aux k;
  simp [power_aux, nat.succ_ne_zero]; apply_instance

instance NF_power (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, power, *]; apply_instance },
    { by_cases m = 0,
      { simp only [pow, power, *, zero_def], apply_instance },
      { simp [pow, power, *, - npow_eq_pow], apply_instance } } },
  { simp [pow, power, e₁, e₂, split_eq_scale_split' e₂],
    have := na.fst,
    cases k with k; simp [succ_eq_add_one, power]; resetI; apply_instance }
end

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

theorem repr_power_aux₁ {e a} [Ne : NF e] [Na : NF a] {a' : ordinal}
  (e0 : repr e ≠ 0) (h : a' < ω ^ repr e) (aa : repr a = a') (n : ℕ+) :
  (ω ^ repr e * (n:ℕ) + a') ^ ω = (ω ^ repr e) ^ ω :=
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 _ (power_le_power_left _ this),
  apply (power_le_of_limit
    (ne_of_gt $ lt_of_lt_of_le (power_pos _ omega_pos) this) omega_is_limit).2,
  intros b l,
  have := (No.below_of_lt (lt_succ_self _)).repr_lt, unfold repr at this,
  apply le_trans (power_le_power_left b $ le_of_lt this),
  rw [← power_mul, ← power_mul],
  apply power_le_power_right omega_pos,
  cases le_or_lt ω (repr e) with h h,
  { apply le_trans (mul_le_mul_left _ $ le_of_lt $ lt_succ_self _),
    rw [succ, add_mul_succ _ (one_add_of_omega_le h), ← succ,
        succ_le, mul_lt_mul_iff_left (ordinal.pos_iff_ne_zero.2 e0)],
    exact omega_is_limit.2 _ l },
  { refine le_trans (le_of_lt $ mul_lt_omega (omega_is_limit.2 _ h) l) _,
    simpa using mul_le_mul_right ω (one_le_iff_ne_zero.2 e0) }
end

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

theorem repr_power_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 (power_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 [power_aux, R]},
  rename R R', let R := repr (power_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', power_aux, R, power_mul],
    { cases k; simp [power_aux] }, { refl } },
  have α0 : 0 < α', {simpa [α', lt_def, repr] using oadd_pos a0 n a'},
  have ω00 : 0 < ω0 ^ k := power_pos _ (power_pos _ omega_pos),
  have Rl : R < ω ^ (repr a0 * succ ↑k),
  { by_cases k0 : k = 0,
    { simp [k0],
      refine lt_of_lt_of_le _ (power_le_power_right omega_pos (one_le_iff_ne_zero.2 e0)),
      cases m with m; simp [k0, R, power_aux, omega_pos],
      rw [← nat.cast_succ], apply nat_lt_omega },
    { rw power_mul, exact IH.1 k0 } },
  refine ⟨λ_, _, _⟩,
  { rw [RR, ← power_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 add_lt_omega_power,
    { simp [power_mul, ω0, power_add, mul_assoc],
      rw [mul_lt_mul_iff_left ω00, ← ordinal.power_add],
      have := (No.below_of_lt _).repr_lt, unfold repr at this,
      refine mul_lt_omega_power rr0 this (nat_lt_omega _),
      simpa using (add_lt_add_iff_left (repr a0)).2 e0 },
    { refine lt_of_lt_of_le Rl (power_le_power_right omega_pos $
        mul_le_mul_left _ $ succ_le_succ.2 $ nat_cast_le.2 $ le_of_lt k.lt_succ_self) } },
  refine 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 [← ordinal.mul_add, ← nat_cast_succ, power_succ, IH.2],
  congr' 1,
  { have αd : ω ∣ α' := dvd_add (dvd_mul_of_dvd_left
      (by simpa using power_dvd_power ω (one_le_iff_ne_zero.2 e0)) _) d,
    rw [ordinal.mul_add (ω0 ^ k), add_assoc, ← mul_assoc, ← power_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 add_lt_omega_power _ Rl,
      rw [power_mul, power_succ, mul_lt_mul_iff_left ω00],
      exact No.snd'.repr_lt },
    { have := mul_le_mul_left (ω0 ^ succ k) (one_le_iff_pos.2 $ nat_cast_pos.2 n.pos),
      rw power_mul, simpa [-power_succ] } },
  { cases m,
    { have : R = 0, {cases k; simp [R, power_aux]}, simp [this] },
    { rw [← nat_cast_succ, add_mul_succ],
      apply add_absorp Rl,
      rw [power_mul, power_succ],
      apply ordinal.mul_le_mul_left,
      simpa [α', repr] using omega_le_oadd a0 n a' } }
end

end

theorem repr_power (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 [power_def, power, e₁, h, r₁],
      have := mt repr_inj.1 h, rw zero_power this },
    { cases e₂ : split' o₂ with b' k,
      cases NF_repr_split' e₂ with _ r₂,
      by_cases m = 0; simp [power_def, power, e₁, h, r₁, e₂, r₂, -nat.cast_succ],
      rw [power_add, power_mul, power_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 [power_def, power, e₁, r₁, split_eq_scale_split' e₂],
    cases k with k; resetI,
    { simp [power, r₂, power_mul, repr_power_aux₁ a00 al aa, add_assoc] },
    { simp [succ_eq_add_one, power, r₂, power_add, power_mul, mul_assoc, add_assoc],
      rw [repr_power_aux₁ a00 al aa, scale_power_aux], simp [power_mul],
      rw [← ordinal.mul_add, ← add_assoc (ω ^ repr a0 * (n:ℕ))], congr' 1,
      rw [← power_succ],
      exact (repr_power_aux₂ _ ad a00 al _ _).2 } }
end

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⟩

/-- 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

/-- 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 power (x y : nonote) := mk (x.1.power y.1)

theorem repr_power (a b) : repr (power a b) = (repr a).power (repr b) :=
onote.repr_power a.1 b.1

end nonote


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

! This file was ported from Lean 3 source module order.well_founded
! leanprover-community/mathlib commit 1c521b4fb909320eca16b2bb6f8b5b0490b1cb5e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Tactic.ByContra
import Mathlib.Data.Set.Image

/-!
# Well-founded relations

A relation is well-founded if it can be used for induction: for each `x`, `(∀ y, r y x → P y) → P x`
implies `P x`. Well-founded relations can be used for induction and recursion, including
construction of fixed points in the space of dependent functions `Π x : α , β x`.

The predicate `WellFounded` is defined in the core library. In this file we prove some extra lemmas
and provide a few new definitions: `WellFounded.min`, `WellFounded.sup`, and `WellFounded.succ`,
and an induction principle `WellFounded.induction_bot`.
-/

variable {α : Type _}

namespace WellFounded

#align well_founded_relation.r WellFoundedRelation.rel

protected theorem isAsymm {α : Sort _} {r : α → α → Prop} (h : WellFounded r) : IsAsymm α r :=
  ⟨h.asymmetric⟩
#align well_founded.is_asymm WellFounded.isAsymm

instance {α : Sort _} [WellFoundedRelation α] : IsAsymm α WellFoundedRelation.rel :=
  WellFoundedRelation.wf.isAsymm

protected theorem isIrrefl {α : Sort _} {r : α → α → Prop} (h : WellFounded r) : IsIrrefl α r :=
  @IsAsymm.isIrrefl α r h.isAsymm
#align well_founded.is_irrefl WellFounded.isIrrefl

instance {α : Sort _} [WellFoundedRelation α] : IsIrrefl α WellFoundedRelation.rel :=
  IsAsymm.isIrrefl

/-- If `r` is a well-founded relation, then any nonempty set has a minimal element
with respect to `r`. -/
theorem has_min {α} {r : α → α → Prop} (H : WellFounded r) (s : Set α) :
    s.Nonempty → ∃ a ∈ s, ∀ x ∈ s, ¬r x a
  | ⟨a, ha⟩ => show ∃ b ∈ s, ∀ x ∈ s, ¬r x b from
    Acc.recOn (H.apply a) (fun x _ IH =>
        not_imp_not.1 fun hne hx => hne <| ⟨x, hx, fun y hy hyx => hne <| IH y hyx hy⟩)
      ha
#align well_founded.has_min WellFounded.has_min

/-- A minimal element of a nonempty set in a well-founded order.

If you're working with a nonempty linear order, consider defining a
`ConditionallyCompleteLinearOrderBot` instance via
`WellFounded.conditionallyCompleteLinearOrderWithBot` and using `Inf` instead. -/
noncomputable def min {r : α → α → Prop} (H : WellFounded r) (s : Set α) (h : s.Nonempty) : α :=
  Classical.choose (H.has_min s h)
#align well_founded.min WellFounded.min

theorem min_mem {r : α → α → Prop} (H : WellFounded r) (s : Set α) (h : s.Nonempty) :
    H.min s h ∈ s :=
  let ⟨h, _⟩ := Classical.choose_spec (H.has_min s h)
  h
#align well_founded.min_mem WellFounded.min_mem

theorem not_lt_min {r : α → α → Prop} (H : WellFounded r) (s : Set α) (h : s.Nonempty) {x}
    (hx : x ∈ s) : ¬r x (H.min s h) :=
  let ⟨_, h'⟩ := Classical.choose_spec (H.has_min s h)
  h' _ hx
#align well_founded.not_lt_min WellFounded.not_lt_min

theorem wellFounded_iff_has_min {r : α → α → Prop} :
    WellFounded r ↔ ∀ s : Set α, s.Nonempty → ∃ m ∈ s, ∀ x ∈ s, ¬r x m := by
  refine ⟨fun h => h.has_min, fun h => ⟨fun x => ?_⟩⟩
  by_contra hx
  obtain ⟨m, hm, hm'⟩ := h {x | ¬Acc r x} ⟨x, hx⟩
  refine' hm ⟨_, fun y hy => _⟩
  by_contra hy'
  exact hm' y hy' hy
#align well_founded.well_founded_iff_has_min WellFounded.wellFounded_iff_has_min

theorem eq_iff_not_lt_of_le {α} [PartialOrder α] {x y : α} : (x ≤ y → y = x) ↔ ¬x < y := by
  constructor
  · intro xle nge
    rw [xle (le_not_le_of_lt nge).1] at nge
    exact lt_irrefl x nge
  . intro ngt xle
    contrapose! ngt
    exact lt_of_le_of_ne xle (Ne.symm ngt)
#align well_founded.eq_iff_not_lt_of_le WellFounded.eq_iff_not_lt_of_le

theorem wellFounded_iff_has_max' [PartialOrder α] :
    WellFounded ((· > ·) : α → α → Prop) ↔
      ∀ p : Set α, p.Nonempty → ∃ m ∈ p, ∀ x ∈ p, m ≤ x → x = m :=
  by simp [eq_iff_not_lt_of_le, wellFounded_iff_has_min]
#align well_founded.well_founded_iff_has_max' WellFounded.wellFounded_iff_has_max'

theorem wellFounded_iff_has_min' [PartialOrder α] :
    WellFounded (LT.lt : α → α → Prop) ↔
      ∀ p : Set α, p.Nonempty → ∃ m ∈ p, ∀ x ∈ p, x ≤ m → x = m :=
  @wellFounded_iff_has_max' αᵒᵈ _
#align well_founded.well_founded_iff_has_min' WellFounded.wellFounded_iff_has_min'

open Set

/-- The supremum of a bounded, well-founded order -/
protected noncomputable def sup {r : α → α → Prop} (wf : WellFounded r) (s : Set α)
    (h : Bounded r s) : α :=
  wf.min { x | ∀ a ∈ s, r a x } h
#align well_founded.sup WellFounded.sup

protected theorem lt_sup {r : α → α → Prop} (wf : WellFounded r) {s : Set α} (h : Bounded r s) {x}
    (hx : x ∈ s) : r x (wf.sup s h) :=
  min_mem wf { x | ∀ a ∈ s, r a x } h x hx
#align well_founded.lt_sup WellFounded.lt_sup

section

open Classical

/-- A successor of an element `x` in a well-founded order is a minimal element `y` such that
`x < y` if one exists. Otherwise it is `x` itself. -/
protected noncomputable def succ {r : α → α → Prop} (wf : WellFounded r) (x : α) : α :=
  if h : ∃ y, r x y then wf.min { y | r x y } h else x
#align well_founded.succ WellFounded.succ

protected theorem lt_succ {r : α → α → Prop} (wf : WellFounded r) {x : α} (h : ∃ y, r x y) :
    r x (wf.succ x) := by
  rw [WellFounded.succ, dif_pos h]
  apply min_mem
#align well_founded.lt_succ WellFounded.lt_succ

end

protected theorem lt_succ_iff {r : α → α → Prop} [wo : IsWellOrder α r] {x : α} (h : ∃ y, r x y)
    (y : α) : r y (wo.wf.succ x) ↔ r y x ∨ y = x := by
  constructor
  · intro h'
    have : ¬r x y := by
      intro hy
      rw [WellFounded.succ, dif_pos] at h'
      exact wo.wf.not_lt_min _ h hy h'
    rcases trichotomous_of r x y with (hy | hy | hy)
    exfalso
    exact this hy
    right
    exact hy.symm
    left
    exact hy
  rintro (hy | rfl); exact _root_.trans hy (wo.wf.lt_succ h); exact wo.wf.lt_succ h
#align well_founded.lt_succ_iff WellFounded.lt_succ_iff

section LinearOrder

variable {β : Type _} [LinearOrder β] (h : WellFounded ((· < ·) : β → β → Prop)) {γ : Type _}
  [PartialOrder γ]

theorem min_le {x : β} {s : Set β} (hx : x ∈ s) (hne : s.Nonempty := ⟨x, hx⟩) : h.min s hne ≤ x :=
  not_lt.1 <| h.not_lt_min _ _ hx
#align well_founded.min_le WellFounded.min_le

private theorem eq_strictMono_iff_eq_range_aux {f g : β → γ} (hf : StrictMono f)
    (hg : StrictMono g) (hfg : Set.range f = Set.range g) {b : β} (H : ∀ a < b, f a = g a) :
    f b ≤ g b := by
  obtain ⟨c, hc⟩ : g b ∈ Set.range f := by
    rw [hfg]
    exact Set.mem_range_self b
  cases' lt_or_le c b with hcb hbc
  · rw [H c hcb] at hc
    rw [hg.injective hc] at hcb
    exact hcb.false.elim
  · rw [← hc]
    exact hf.monotone hbc

theorem eq_strictMono_iff_eq_range {f g : β → γ} (hf : StrictMono f) (hg : StrictMono g) :
    Set.range f = Set.range g ↔ f = g :=
  ⟨fun hfg => by
    funext a
    apply h.induction a
    exact fun b H =>
      le_antisymm (eq_strictMono_iff_eq_range_aux hf hg hfg H)
        (eq_strictMono_iff_eq_range_aux hg hf hfg.symm fun a hab => (H a hab).symm),
    congr_arg _⟩
#align well_founded.eq_strict_mono_iff_eq_range WellFounded.eq_strictMono_iff_eq_range

theorem self_le_of_strictMono {f : β → β} (hf : StrictMono f) : ∀ n, n ≤ f n := by
  by_contra' h₁
  have h₂ := h.min_mem _ h₁
  exact h.not_lt_min _ h₁ (hf h₂) h₂
#align well_founded.self_le_of_strict_mono WellFounded.self_le_of_strictMono

end LinearOrder

end WellFounded

namespace Function

variable {β : Type _} (f : α → β)

section LT

variable [LT β] (h : WellFounded ((· < ·) : β → β → Prop))

/-- Given a function `f : α → β` where `β` carries a well-founded `<`, this is an element of `α`
whose image under `f` is minimal in the sense of `Function.not_lt_argmin`. -/
noncomputable def argmin [Nonempty α] : α :=
  WellFounded.min (InvImage.wf f h) Set.univ Set.univ_nonempty
#align function.argmin Function.argmin

theorem not_lt_argmin [Nonempty α] (a : α) : ¬f a < f (argmin f h) :=
  WellFounded.not_lt_min (InvImage.wf f h) _ _ (Set.mem_univ a)
#align function.not_lt_argmin Function.not_lt_argmin

/-- Given a function `f : α → β` where `β` carries a well-founded `<`, and a non-empty subset `s`
of `α`, this is an element of `s` whose image under `f` is minimal in the sense of
`Function.not_lt_argminOn`. -/
noncomputable def argminOn (s : Set α) (hs : s.Nonempty) : α :=
  WellFounded.min (InvImage.wf f h) s hs
#align function.argmin_on Function.argminOn

@[simp]
theorem argminOn_mem (s : Set α) (hs : s.Nonempty) : argminOn f h s hs ∈ s :=
  WellFounded.min_mem _ _ _
#align function.argmin_on_mem Function.argminOn_mem

--Porting note: @[simp] removed as it will never apply
theorem not_lt_argminOn (s : Set α) {a : α} (ha : a ∈ s)
    (hs : s.Nonempty := Set.nonempty_of_mem ha) : ¬f a < f (argminOn f h s hs) :=
  WellFounded.not_lt_min (InvImage.wf f h) s hs ha
#align function.not_lt_argmin_on Function.not_lt_argminOn

end LT

section LinearOrder

variable [LinearOrder β] (h : WellFounded ((· < ·) : β → β → Prop))

--Porting note: @[simp] removed as it will never apply
theorem argmin_le (a : α) [Nonempty α] : f (argmin f h) ≤ f a :=
  not_lt.mp <| not_lt_argmin f h a
#align function.argmin_le Function.argmin_le

--Porting note: @[simp] removed as it will never apply
theorem argminOn_le (s : Set α) {a : α} (ha : a ∈ s) (hs : s.Nonempty := Set.nonempty_of_mem ha) :
    f (argminOn f h s hs) ≤ f a :=
  not_lt.mp <| not_lt_argminOn f h s ha hs
#align function.argmin_on_le Function.argminOn_le

end LinearOrder

end Function

section Induction

/-- Let `r` be a relation on `α`, let `f : α → β` be a function, let `C : β → Prop`, and
let `bot : α`. This induction principle shows that `C (f bot)` holds, given that
* some `a` that is accessible by `r` satisfies `C (f a)`, and
* for each `b` such that `f b ≠ f bot` and `C (f b)` holds, there is `c`
  satisfying `r c b` and `C (f c)`. -/
theorem Acc.induction_bot' {α β} {r : α → α → Prop} {a bot : α} (ha : Acc r a) {C : β → Prop}
    {f : α → β} (ih : ∀ b, f b ≠ f bot → C (f b) → ∃ c, r c b ∧ C (f c)) : C (f a) → C (f bot) :=
  (@Acc.recOn _ _ (fun x _ => C (f x) → C (f bot)) _ ha) fun x _ ih' hC =>
    (eq_or_ne (f x) (f bot)).elim (fun h => h ▸ hC) (fun h =>
      let ⟨y, hy₁, hy₂⟩ := ih x h hC
      ih' y hy₁ hy₂)
#align acc.induction_bot' Acc.induction_bot'

/-- Let `r` be a relation on `α`, let `C : α → Prop` and let `bot : α`.
This induction principle shows that `C bot` holds, given that
* some `a` that is accessible by `r` satisfies `C a`, and
* for each `b ≠ bot` such that `C b` holds, there is `c` satisfying `r c b` and `C c`. -/
theorem Acc.induction_bot {α} {r : α → α → Prop} {a bot : α} (ha : Acc r a) {C : α → Prop}
    (ih : ∀ b, b ≠ bot → C b → ∃ c, r c b ∧ C c) : C a → C bot :=
  ha.induction_bot' ih
#align acc.induction_bot Acc.induction_bot

/-- Let `r` be a well-founded relation on `α`, let `f : α → β` be a function,
let `C : β → Prop`, and  let `bot : α`.
This induction principle shows that `C (f bot)` holds, given that
* some `a` satisfies `C (f a)`, and
* for each `b` such that `f b ≠ f bot` and `C (f b)` holds, there is `c`
  satisfying `r c b` and `C (f c)`. -/
theorem WellFounded.induction_bot' {α β} {r : α → α → Prop} (hwf : WellFounded r) {a bot : α}
    {C : β → Prop} {f : α → β} (ih : ∀ b, f b ≠ f bot → C (f b) → ∃ c, r c b ∧ C (f c)) :
    C (f a) → C (f bot) :=
  (hwf.apply a).induction_bot' ih
#align well_founded.induction_bot' WellFounded.induction_bot'

/-- Let `r` be a well-founded relation on `α`, let `C : α → Prop`, and let `bot : α`.
This induction principle shows that `C bot` holds, given that
* some `a` satisfies `C a`, and
* for each `b` that satisfies `C b`, there is `c` satisfying `r c b` and `C c`.

The naming is inspired by the fact that when `r` is transitive, it follows that `bot` is
the smallest element w.r.t. `r` that satisfies `C`. -/
theorem WellFounded.induction_bot {α} {r : α → α → Prop} (hwf : WellFounded r) {a bot : α}
    {C : α → Prop} (ih : ∀ b, b ≠ bot → C b → ∃ c, r c b ∧ C c) : C a → C bot :=
  hwf.induction_bot' ih
#align well_founded.induction_bot WellFounded.induction_bot

end Induction


import .love08_operational_semantics_demo

/-! # LoVe Exercise 8: Operational Semantics -/

set_option pp.beta true

namespace LoVe

/-! ## Question 1: Program Equivalence

For this question, we introduce the notion of program equivalence: `S₁ ≈ S₂`. -/

def big_step_equiv (S₁ S₂ : stmt) : Prop :=
∀s t, (S₁, s) ⟹ t ↔ (S₂, s) ⟹ t

infix ` ≈ ` := big_step_equiv

/-! Program equivalence is a equivalence relation, i.e., it is reflexive,
symmetric, and transitive. -/

@[refl] lemma big_step_equiv.refl {S : stmt} :
  S ≈ S :=
fix s t,
show (S, s) ⟹ t ↔ (S, s) ⟹ t, from
  by refl

@[symm] lemma big_step_equiv.symm {S₁ S₂ : stmt}:
  S₁ ≈ S₂ → S₂ ≈ S₁ :=
assume h : S₁ ≈ S₂,
fix s t,
show (S₂, s) ⟹ t ↔ (S₁, s) ⟹ t, from
  iff.symm (h s t)

@[trans] lemma big_step_equiv.trans {S₁ S₂ S₃ : stmt} (h₁₂ : S₁ ≈ S₂)
    (h₂₃ : S₂ ≈ S₃) :
  S₁ ≈ S₃ :=
fix s t,
show (S₁, s) ⟹ t ↔ (S₃, s) ⟹ t, from
  iff.trans (h₁₂ s t) (h₂₃ s t)

/-! 1.1. Prove the following program equivalences. -/

lemma big_step_equiv.skip_assign_id {x} :
  stmt.assign x (λs, s x) ≈ stmt.skip :=
begin
    unfold big_step_equiv,
    intros,
    apply iff.intro,
    repeat {
        simp [big_step_skip_iff],
    },
end

lemma big_step_equiv.seq_skip_left {S : stmt} :
  stmt.skip ;; S ≈ S :=
begin
    unfold big_step_equiv,
    intros,
    apply iff.intro,
    repeat {
        simp [big_step_skip_iff],
    },
end

lemma big_step_equiv.seq_skip_right {S : stmt} :
  S ;; stmt.skip ≈ S :=
begin
    unfold big_step_equiv,
    intros,
    apply iff.intro,
    repeat {
        simp [big_step_skip_iff],
    },
end

lemma big_step_equiv.ite_seq_while {b} {S : stmt} :
  stmt.ite b (S ;; stmt.while b S) stmt.skip ≈ stmt.while b S :=
begin
    intros s t,
    rw [big_step_while_iff],
    simp,
    -- apply iff.intro,
    -- {
    --     intro h,
    --     cases h,
    --     cases h_hbody,
    --     {
    --         rw [big_step_while_true_iff],
    --         {
    --             existsi h_hbody_t,
    --             tautology,
    --         },
    --         { assumption, }
    --     },
    --     {
    --         rw [big_step_while_false_iff],
    --         {
    --             cases h_hbody,
    --             tautology,
    --         },
    --         { assumption, }
    --     },
    -- },
    -- {
    --     intro h,
    --     cases h,
    --     {
    --         rw [big_step_ite_iff],
    --         apply or.intro_left,
    --         apply and.intro,
    --         { assumption, },
    --         {
    --             rw [big_step_seq_iff],
    --             existsi h_t,
    --             tautology,
    --         }
    --     },
    --     {
    --         rw [big_step_ite_iff],
    --         apply or.intro_right,
    --         apply and.intro,
    --         { assumption, },
    --         { rw [big_step_skip_iff],}
    --     }
    -- },
end

/-! 1.2. Program equivalence can be used to replace subprograms by other
subprograms with the same semantics. Prove the following so-called congruence
rules: -/

lemma big_step_equiv.seq_congr {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  S₁ ;; T₁ ≈ S₂ ;; T₂ :=
begin
    unfold big_step_equiv,
    intros,
    unfold big_step_equiv at hS hT,
    apply iff.intro,
    {
        rw [big_step_seq_iff],
        intro h,
        cases h,
        have h1: (S₂, s) ⟹ h_w := begin
            apply (hS s h_w).mp,
            apply and.elim_left h_h,
        end,
        have h2:  (T₂, h_w) ⟹ t := begin
            apply (hT h_w t).mp,
            apply and.elim_right h_h,
        end,
        rw [big_step_seq_iff],
        existsi h_w,
        tautology,
    },
    {
        intro h,
        cases h,
        rw [big_step_seq_iff],
        existsi h_t,
        apply and.intro,
        {
            apply (hS s h_t).mpr,
            assumption,
        },
        {
            apply (hT h_t t).mpr,
            assumption,
        },
    },
end

lemma big_step_equiv.ite_congr {b} {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  stmt.ite b S₁ T₁ ≈ stmt.ite b S₂ T₂ :=
begin
    unfold big_step_equiv,
    intros,
    unfold big_step_equiv at hS hT,
    apply iff.intro,
    {
        intro h,
        cases h,
        {
            rw [big_step_ite_iff],
            apply or.intro_left,
            apply and.intro,
            { assumption, },
            {
                apply (hS s t).mp,
                assumption,
            },
        },
        {
            rw [big_step_ite_iff],
            apply or.intro_right,
            apply and.intro,
            { assumption, },
            {
                apply (hT s t).mp,
                assumption,
            },
        }
    },
    {
        intro h,
        cases h,
        {
            rw [big_step_ite_iff],
            apply or.intro_left,
            apply and.intro,
            { assumption, },
            {
                apply (hS s t).mpr,
                assumption,
            },
        },
        {
            rw [big_step_ite_iff],
            apply or.intro_right,
            apply and.intro,
            { assumption, },
            {
                apply (hT s t).mpr,
                assumption,
            },
        }
    }
end

/-! 1.3 (**optional**): Prove one more congruence rule. This one is more
difficult. -/

lemma denote_equiv.while_congr {b} {S₁ S₂ : stmt} (hS : S₁ ≈ S₂) :
  stmt.while b S₁ ≈ stmt.while b S₂ :=
begin
    -- intros s t,
    -- apply iff.intro,
    -- {
    --     generalize G : (stmt.while b S₁, s) = st1,
    --     sorry,
    -- }
    sorry,
end

/-! ## Question 2: Guarded Command Language (GCL)

In 1976, E. W. Dijkstra introduced the guarded command language, a
minimalistic imperative language with built-in nondeterminism. A grammar for one
of its variants is given below:

    S  ::=  x := e       -- assignment
         |  assert b     -- assertion
         |  S ; S        -- sequential composition
         |  S | ⋯ | S    -- nondeterministic choice
         |  loop S       -- nondeterministic iteration

Assignment and sequential composition are as in the WHILE language. The other
statements have the following semantics:

* `assert b` aborts if `b` evaluates to false; otherwise, the command is a
  no-op.

* `S | ⋯ | S` chooses any of the branches and executes it, ignoring the other
  branches.

* `loop S` executes `S` any number of times.

In Lean, GCL is captured by the following inductive type: -/

namespace gcl

inductive stmt (σ : Type) : Type
| assign : string → (σ → ℕ) → stmt
| assert : (σ → Prop) → stmt
| seq    : stmt → stmt → stmt
| choice : list stmt → stmt
| loop   : stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/-! The parameter `σ` abstracts over the state type. It is necessary as a work
around for a Lean bug.

The big-step semantics is defined as follows: -/

inductive big_step : (stmt state × state) → state → Prop
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| assert {b : state → Prop} {s} (hcond : b s) :
  big_step (stmt.assert b, s) s
| seq {S T s t u} (h₁ : big_step (S, s) t) (h₂ : big_step (T, t) u) :
  big_step (S ;; T, s) u
| choice {Ss s t} (i) (hless : i < list.length Ss)
    (hbody : big_step (list.nth_le Ss i hless, s) t) :
  big_step (stmt.choice Ss, s) t
| loop_base {S s} :
  big_step (stmt.loop S, s) s
| loop_step {S s u} (t) (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.loop S, t) u) :
  big_step (stmt.loop S, s) u

infix ` ⟹ ` : 110 := big_step

/-! 2.1. Prove the following inversion rules, as we did in the lecture for the
WHILE language. -/

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
    apply iff.intro,
    {
        intro h,
        cases h,
        refl,
    },
    {
        intro h,
        cases h,
        apply big_step.assign,
    }
end

@[simp] lemma big_step_assert {b s t} :
  (stmt.assert b, s) ⟹ t ↔ t = s ∧ b s :=
begin
    apply iff.intro,
    {
        intro h,
        cases h,
        tautology,
    },
    {
        intro h,
        cases h,
        have  h1 : (stmt.assert b, s) ⟹ s :=
            begin
                apply big_step.assert,
                assumption,
            end,
        cc,
    }
end

@[simp] lemma big_step_seq_iff {S₁ S₂ s t} :
  (stmt.seq S₁ S₂, s) ⟹ t ↔ (∃u, (S₁, s) ⟹ u ∧ (S₂, u) ⟹ t) :=
begin
    apply iff.intro,
    {
        intro h,
        cases h,
        tautology,
    },
    {
        intro h,
        cases h,
        cases h_h,
        apply big_step.seq,
        assumption,
        assumption,
    }
end

lemma big_step_loop {S s u} :
  (stmt.loop S, s) ⟹ u ↔
  (s = u ∨ (∃t, (S, s) ⟹ t ∧ (stmt.loop S, t) ⟹ u)) :=
begin
    apply iff.intro,
    {
        intro h,
        cases h,
        {
            apply or.intro_left,
            tautology,
        },
        {
            apply or.intro_right,
            existsi h_t,
            apply and.intro,
            assumption,
            assumption,
        }
    },
    {
        intro h,
        cases h,
        {
            rw h,
            apply big_step.loop_base,
        },
        {
            cases h,
            cases h_h,
            apply big_step.loop_step,
            {
                apply h_h_left,
            },
            assumption,
        }
    }
end

@[simp] lemma big_step_choice {Ss s t} :
  (stmt.choice Ss, s) ⟹ t ↔
  (∃(i : ℕ) (hless : i < list.length Ss),
     (list.nth_le Ss i hless, s) ⟹ t) :=
begin
    apply iff.intro,
    {
        intro h,
        cases h,
        existsi h_i,
        existsi h_hless,
        assumption,
    },
    {
        intro h,
        cases h,
        cases h_h,
        apply big_step.choice h_w h_h_w,
        assumption,
    }
end

end gcl

/-! 2.2. Complete the translation below of a deterministic program to a GCL
program, by filling in the `sorry` placeholders below. -/

def gcl_of : stmt → gcl.stmt state
| stmt.skip         := gcl.stmt.assert (λ_, true)
| (stmt.assign x a) :=
  sorry
| (S ;; T)          :=
  sorry
| (stmt.ite b S T)  :=
  sorry
| (stmt.while b S)  :=
  sorry

/-! 2.3. In the definition of `gcl_of` above, `skip` is translated to
`assert (λ_, true)`. Looking at the big-step semantics of both constructs, we
can convince ourselves that it makes sense. Can you think of other correct ways
to define the `skip` case? -/

-- enter your answer here

end LoVe