import tactic

/-
In this file, we'll focus on functions of a natural number variable. The ideas generalise to other
inductive types.
-/

namespace primitive_recursion

  /-
  Our aim is to define, recursively, a function `pow2 : ℕ → ℕ` so that `pow2 n = 2^n`.
  We assume given an operation on multiplication.

  As `ℕ` has two constructors, `zero : ℕ` and `succ : ℕ → ℕ`, it suffices to define `pow2 zero`
  and `pow2 (succ n)`, given `n : ℕ`.

  A (primitive) rescursive definition of `pow2` will give `pow2 (succ n)` only in terms of
  `pow2 n`.

  The equation compiler permits a striaghtfoward notation for this kind of definition.
  -/

  open nat

  def pow2 : ℕ → ℕ
  | zero      := 1
  | (succ n)  := 2 * (pow2 n)

  example : pow2 5 = 32 := rfl

  /-
  However, the compiler does not (immediately) produce a primitive recursive definition. Instead,
  it uses course-of-values recursion. We'll come to this later. For now, let's see a primitive
  recursive definition of the same.
  -/

  #check @nat.rec_on

  def pow2' : ℕ → ℕ := λ n, @nat.rec_on (λ (z : ℕ), ℕ) n 1 (λ m hm, 2 * hm)

  example : pow2' 5 = 32 := rfl

  def boo : Π (n : ℕ), vector ℕ n :=
  λ n, nat.rec_on n ⟨[],dec_trivial⟩ (λ m hm, vector.cons m hm)

  #eval vector.to_list (boo 3)

  /-
  Primitive recursive functions of a natural number variable can be written using the Lean
  constant `nat.rec` (or variants such as `nat.rec_on` and `nat.cases_on`).
  -/

  open nat

  def fib_aux : ℕ → ℕ × ℕ
  | 0         := ⟨0,1⟩
  | (n+1)     := ⟨(fib_aux n).snd, (fib_aux n).fst + (fib_aux n).snd⟩

  def fib_aux' (n : ℕ) : ℕ × ℕ := nat.rec_on n ⟨0,1⟩ (λ m ⟨f1, f2⟩, ⟨f2, f1 + f2⟩)

  def fib_pr : ℕ → ℕ := λ n, (fib_aux n).fst
  def fib_pr' : ℕ → ℕ := λ n, (fib_aux' n).fst

  #eval fib_pr 7
  #eval fib_pr' 7

end primitive_recursion

namespace fibonacci

  -- The Fibonacci sequence.
  def fib : nat → nat
  | 0     := 1
  | 1     := 1
  | (n+2) := fib (n+1) + fib n

  example : fib 0 = 1 := rfl
  example : fib 1 = 1 := rfl
  example (n : nat) : fib (n + 2) = fib (n + 1) + fib n := rfl

  example : fib 7 = 21 := rfl
  example : fib 7 = 21 :=
  begin
    dsimp [fib],   -- expands fib 7 as a sum of 1's
    reflexivity
  end

  /-
  Above, we defined `fib (n+2)` not only in terms of `fib (n+1)` but also in terms of `fib n`.

  The equation compiler converts this not into a `nat.rec_on` definition, but into a defintion
  using `nat.brec_on`, this being an analogue of strong induction.
  -/

  /-
  As seen below, the `nat.brec_on` constant takes a motive `C : ℕ → Sort u`, a natural number `n`,
  and a (dependent) function `F : Π (m : ℕ), nat.below C m → C m`. It returns a term of type `C n`.
  -/
  universe u
  variable (C : ℕ → Sort u) -- A motive.
  example : Π (n : ℕ), (Π (m : ℕ), nat.below C m → C m) → C n := @nat.brec_on C

  example : ℕ → Sort (max 1 u) := nat.below C

  /-
  For a given `n : ℕ`, the type `nat.below C (succ n)` is a structure whose terms record
  elements of `C 0`, `C 1`, ... `C n`.

  In practice, we may want to define a (dependent) function `g : Π (n : ℕ), C n`. In the simple case
  where `C n = C m` for every `n m : ℕ`, we can write this as `g : ℕ → α`, denoting by `α` the
  constant value of `C n`.

  Let `n : ℕ`. Informally, suppose we have a 'function' `f` such that for every `m : ℕ`,
  `f(m)` maps `g(0), g(1), ... g(m-1)` to `g(m)`. Then we construct `g(n)` by applying
  `f(n)` to an already-constructed sequence of values `g(0), g(1), ..., g(n-1)`.

  `nat.brec_on` formalises this notion. We treat `F : Π (m : ℕ), nat.below C m → C m` as being the
  function that produces `g(m)` (where `g` is the function being defined) from `g(0), ... , g(m-1)`.

  In practice, the task is to understand *how* elements of type `nat.below C m` encode the
  values `g(0), ..., g(m-1)`.
  -/
  variable blog0 : nat.below C 0
  variable blog1 : nat.below C 1
  variable blog2 : nat.below C 2
  variable blog3 : nat.below C 3

  #check ( blog0 : punit )
  #check ( blog1 : pprod (pprod (C 0) punit) punit )
  #check ( blog2 : pprod (pprod (C 1) (pprod (pprod (C 0) punit) punit)) punit )
  #check ( blog3 : pprod (pprod (C 2) (pprod (pprod (C 1) (pprod (pprod (C 0) punit) punit)) punit)) punit )

  /-
  You might guess from this that if `nat.below C n = ih`, then
  `nat.below C (succ n) = pprod (pprod (C n) ih) punit`.

  This expectation is borne out in the defintion of `nat.below`, as seen below. Note that this
  constant is created automatically by Lean.
  -/

  @[reducible]
  protected def nat.below : (ℕ → Sort u) → ℕ → Sort (max 1 u) :=
  λ (C : ℕ → Sort u) (n : ℕ),
    nat.rec punit (λ m ih, pprod (pprod (C m) ih) (punit : Sort (max 1 u))) n

  /-
  We *construct* terms of type `nat.below C' n` for various `n`, taking `C' := (λ (m : ℕ), ℕ)`.
  -/
  def C' := λ (m : ℕ), ℕ

  def plog0 : nat.below C' 0 := punit.star
  def plog1 : nat.below C' 1 := ⟨⟨(3 : ℕ), punit.star⟩, punit.star⟩
  def plog2 : nat.below C' 2 := ⟨⟨(4 : ℕ), ⟨⟨(3 : ℕ), punit.star⟩, punit.star⟩⟩ , punit.star⟩

  -- We extract data from these terms using `fst` and `snd`.
  example : plog2.fst.fst = (4 : nat) := rfl
  example : plog2.fst.snd.fst.fst = (3 : nat) := rfl

  /-
  The automatically-generated constant `nat.brec_on` has (pretty much) the following definition.
  -/
  @[reducible]
  protected def nat.brec_on : Π {C : ℕ → Sort u} (n : ℕ), (Π (m : ℕ), nat.below C m → C m) → C n :=
  λ {C : ℕ → Sort u} (n : ℕ) (F : Π (m : ℕ), nat.below C m → C m),
    pprod.fst (
      nat.rec_on n ⟨F 0 punit.star, punit.star⟩
      (λ (m : ℕ) (ih : pprod (C m) (nat.below C m)), ⟨F m.succ ⟨ih, punit.star⟩, ⟨ih, punit.star⟩⟩)
      : pprod (C n) (nat.below C n)  )

  /-
  In stages, we'll contruct the `fib` function manually. The innermost operation is to take
  `n₁ : ℕ` and `h₁ : nat.below C' (n₁ + 2)` and return `h₁.fst.fst + h₁.fst.snd.fst.fst`.

  We want to apply this to `a : ℕ` where `a = n₁ + 2`. We can't satisfy this for every `a : ℕ`
  (in particular, we can't do this for `a = 0` or `a = 1`). Instead, we'll have separate
  functions to deal with the base case and 'pass' the `nat.below C' a` structure down the
  levels of nested functions until we get to the innermost function.
  -/
  def inner₁ (n₁ : ℕ) (h₁ : nat.below (λ _ : ℕ, ℕ) (n₁ + 2)) := h₁.fst.fst + h₁.fst.snd.fst.fst

  def inner₂ (n₂ : ℕ) :=
    @nat.cases_on (λ m₂ : ℕ, nat.below C' (m₂ + 1) → ℕ) n₂ (λ _ : nat.below C' 1, 1) inner₁

  def inner₃ (n₃ : ℕ) (h₃ : nat.below C' (n₃ + 1)) := inner₂ n₃ h₃

  def inner₄ (n₄ : ℕ) :=
    @nat.cases_on (λ m₄ : ℕ, nat.below C' m₄ → ℕ) n₄ (λ _ : nat.below C' 0, 1) inner₃

  def inner₅ (n₅ : ℕ) (h₅ : nat.below C' n₅) := inner₄ n₅ h₅

  def fib' (a : ℕ) : ℕ := nat.brec_on a inner₅

  #eval list.map (λ n, fib' n - fib n) (list.range 10)

  def boo₁ (n₁ : ℕ) (h₁ : nat.below (λ _ : ℕ, ℕ) (n₁ + 1)) := 2* h₁.fst.fst

  def boo₂ (n₂ : ℕ) :=
    @nat.cases_on (λ m₂ : ℕ, nat.below C' m₂ → ℕ) n₂ (λ _ : nat.below C' 0, 1) boo₁

  def pow2 (a : ℕ) : ℕ := nat.brec_on a boo₂

  #check @nat.cases_on

  def pow2' (a : ℕ) : ℕ := nat.brec_on a
   (λ n₂, @nat.cases_on (λ m₂ : ℕ, nat.below C' m₂ → ℕ) n₂ (λ _ : nat.below C' 0, 1) boo₁)

  def pow2'' (a : ℕ) : ℕ  := nat.brec_on a
  ( λ n₂, @nat.cases_on (λ m₂ : ℕ, nat.below C' m₂ → ℕ) n₂ (λ _ : nat.below C' 0, 1)
    ( λ n₁ h₁,  2* h₁.fst.fst) )

  #eval pow2 20
  #eval pow2' 20
  #eval pow2'' 20

  def fib'' (a : ℕ) : ℕ :=
    nat.brec_on a
    ( λ (n₁ : ℕ) (h₁ : nat.below C' n₁),
      ( λ (n₂ : ℕ) (h₂ : nat.below C' n₂),
        (@nat.cases_on (λ m₁ : ℕ, nat.below C' m₁ → ℕ) n₂
        (λ _ : nat.below C' 0, 1)
        ( λ (n₃ : ℕ) (h₃ : nat.below C' (nat.succ n₃)),
          (@nat.cases_on (λ m₂ : ℕ, nat.below C' (nat.succ m₂) → ℕ) n₃
          (λ _ : nat.below C' 1, 1)
          ( λ (n₄ : ℕ) (h₅ : nat.below C' (nat.succ (nat.succ n₄))),
            (h₅.fst.fst + h₅.fst.snd.fst.fst) ) ) h₃ ) ) h₂ ) n₁ h₁ )

end fibonacci

def append {α : Type*} : list α → list α → list α
| []     l := l
| (h::t) l := h :: append t l

namespace fib_vector

  /-
  We write a function `fib''` such that for every `a : ℕ`, `fib'' a` is a length `a+1` vector of
  natural numbers consisting of the Fibonacci numbers from `0` to `a`.
  -/
  def C' := λ (m : ℕ), vector ℕ (m+1)

  example : vector ℕ 1 := ⟨[1], dec_trivial⟩
  example : vector ℕ 2 := ⟨[1,1], dec_trivial⟩

  example :  vector.head (⟨[1,2], dec_trivial⟩ : vector ℕ 2) = 1 := dec_trivial

  example : vector.head (vector.tail (⟨[1,2], dec_trivial⟩ : vector ℕ 2)) = 2 := dec_trivial

  example (n₄ : ℕ) (h₅ : nat.below C' (n₄ + 2)) : C' (n₄ + 1) := h₅.fst.fst

  def moop (n : ℕ) (h : nat.below C' (n + 2)) : C' (n+2) :=
    let fvec := h.fst.fst in
    vector.cons (vector.head fvec + vector.head (vector.tail fvec)) fvec

  def fib'' (a : ℕ) : C' a :=
    nat.brec_on a
    ( λ (n₁ : ℕ) (h₁ : nat.below C' n₁),
      ( λ (n₂ : ℕ) (h₂ : nat.below C' n₂),
        (@nat.cases_on (λ m₁ : ℕ, nat.below C' m₁ → vector ℕ (m₁+1)) n₂
        (λ _ : nat.below C' 0, ⟨[1], dec_trivial⟩)
        ( λ (n₃ : ℕ) (h₃ : nat.below C' (n₃ + 1)),
          (@nat.cases_on (λ m₂ : ℕ, nat.below C' (m₂ + 1) → vector ℕ (m₂+2)) n₃
          (λ _ : nat.below C' 1, ⟨[1,1], dec_trivial⟩)
          ( λ (n₄ : ℕ) (h₅ : nat.below C' (n₄+2)),
            (moop n₄ h₅) ) ) h₃ ) ) h₂ ) n₁ h₁ )

  #eval vector.to_list (fib'' 8)

end fib_vector


-- Axioma_de_McCune_de_grupos.lean
-- Axioma de McCune de grupos
-- José A. Alonso Jiménez
-- Sevilla, 23 de julio de 2021
-- ---------------------------------------------------------------------

-- En el artículo "Single axioms for groups and abelian groups with
-- various operations" https://bit.ly/3kMBlA0 de McCune se demuestra que
-- el siguiente axioma caracteriza a los grupos
--    (x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹) = u

import tactic

variables {G : Type} [group G] (x y z u v w : G)

-- 1ª demostración
example :
  x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹ = u :=
  by group

-- 2ª demostración
example :
  x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹ = u :=
calc x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹
     = x * (y * ((1 * (u * y)⁻¹) * x))⁻¹       : by simp
 ... = x * (y * ((u * y)⁻¹ * x))⁻¹             : by simp
 ... = x * (((u * y)⁻¹ * x)⁻¹ * y⁻¹)           : by simp
 ... = x * ((x⁻¹ * ((u * y)⁻¹)⁻¹) * y⁻¹)       : by simp
 ... = x * ((x⁻¹ * (u * y)) * y⁻¹)             : by simp
 ... = (x * x⁻¹) * ((u * y) * y⁻¹)             : by simp only [mul_assoc]
 ... = 1 * ((u * y) * y⁻¹)                     : by simp
 ... = (u * y) * y⁻¹                           : by simp
 ... = u * (y * y⁻¹)                           : by simp
 ... = u * 1                                   : by simp
 ... = u                                       : by simp

-- 3ª demostración
lemma l5 :
  x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹ = u :=
calc x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹
     = x * (y * ((1 * (u * y)⁻¹) * x))⁻¹       : by simp only [mul_inv_self]
 ... = x * (y * ((u * y)⁻¹ * x))⁻¹             : by simp only [one_mul]
 ... = x * (((u * y)⁻¹ * x)⁻¹ * y⁻¹)           : by simp only [mul_inv_rev]
 ... = x * ((x⁻¹ * ((u * y)⁻¹)⁻¹) * y⁻¹)       : by simp only [mul_inv_rev]
 ... = x * ((x⁻¹ * (u * y)) * y⁻¹)             : by simp only [inv_inv]
 ... = (x * x⁻¹) * ((u * y) * y⁻¹)             : by simp only [mul_assoc]
 ... = 1 * ((u * y) * y⁻¹)                     : by simp only [mul_inv_self]
 ... = (u * y) * y⁻¹                           : by simp only [one_mul]
 ... = u * (y * y⁻¹)                           : by simp only [mul_assoc]
 ... = u * 1                                   : by simp only [mul_inv_self]
 ... = u                                       : by simp only [mul_one]

-- =====================================================================
-- § Lema 7                                                           --
-- =====================================================================

lemma l7 :
  x * ((((y * y⁻¹) * (z * u)⁻¹) * (v * v⁻¹)) * (z * x))⁻¹ = u :=
begin
  convert l5 _ _ _ _,
  rw l5,
end

-- =====================================================================
-- § Lema 9                                                           --
-- =====================================================================

lemma l9 :
  (x * ((y * (z * z⁻¹)) * (u * x))⁻¹) = (((v * v⁻¹) *(y * u)⁻¹) * (w * w⁻¹)) :=
begin
  convert l7 _ _ _ _ _,
  rw l5,
end

-- =====================================================================
-- § Lema 10                                                          --
-- =====================================================================

lemma l10 :
  (((y * y⁻¹)*(((z*z⁻¹)*(u*x)⁻¹)*u)⁻¹)*(v*v⁻¹)) = x :=
begin
  rw ←l9,
  apply l7,
  exact x,
  exact z,
end

-- =====================================================================
-- § Lema 12                                                          --
-- =====================================================================

lemma l12 : (((x * x⁻¹)*y⁻¹⁻¹)*(z*z⁻¹))=y :=
begin
  convert l10 _ _ _ _ _,
  rw l10,
  exact x
end

-- =====================================================================
-- § Lema 14                                                          --
-- =====================================================================

lemma l14 : ((x*x⁻¹)*(y*z)⁻¹)=((u*u⁻¹)*(y*z)⁻¹) := -- [10 -> 5]
begin
  convert l5 _ _ _ _,
  rw l10,
  exact x,
end

-- =====================================================================
-- § Lema 15                                                          --
-- =====================================================================

lemma l15 : ((x*x⁻¹)*y⁻¹) = ((z*z⁻¹)*y⁻¹) := -- [12 -> 14 : 12]
begin
  convert l14 _ _ _ _,
  rw l12,
  exact x,
  exact z,
  rw l12,
end

-- =====================================================================
-- § Lema 17                                                          --
-- =====================================================================

lemma l17 : u * u⁻¹ = v * v⁻¹ := -- [15 → 5 : 5]
begin
  rw ←l5 u u⁻¹ u (v * v⁻¹),
  rw l15 v _,
  rw l5,
end

-- =====================================================================
-- § Lema 19                                                          --
-- =====================================================================

lemma l19 : x * x⁻¹ = ((y * y⁻¹) * (z * z⁻¹)⁻¹) := -- [17 → 15]
begin
  rw [l15],
  exact l17 _ _,
end


/-
Copyright (c) 2015 Jakob von Raumer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn

Properties of trunc_index, is_trunc, trunctype, trunc, and the pointed versions of these
-/

-- NOTE: the fact that (is_trunc n A) is a mere proposition is proved in .prop_trunc

import ..function .unit
universes u v w
hott_theory
namespace hott

open hott.sigma hott.pi hott.function hott.equiv trunctype nat
     hott.is_equiv hott.prod pointed hott.nat hott.is_trunc hott.algebra hott.sum sum hott.unit

  /- basic computation with ℕ₋₂, its operations and its order -/
namespace trunc_index

instance has_le_trunc_index : has_le ℕ₋₂ :=
⟨trunc_index.le⟩

@[hott] def minus_one_le_succ (n : ℕ₋₂) : -1 ≤ n.+1 :=
succ_le_succ (minus_two_le n)

@[hott] def zero_le_of_nat (n : ℕ) : 0 ≤ of_nat n :=
succ_le_succ (minus_one_le_succ _)

@[hott, reducible] protected def code : ℕ₋₂ → ℕ₋₂ → Type
| -2       -2       := unit
| -2       (succ m) := empty
| (succ n) -2       := empty
| (succ n) (succ m) := n = m

@[hott] protected def refl : Πn, trunc_index.code n n
| -2       := ⋆
| (succ n) := idp

@[hott] protected def encode {n m : ℕ₋₂} (p : n = m) : trunc_index.code n m :=
p ▸ trunc_index.refl n

@[hott] protected def decode : Π(n m : ℕ₋₂), trunc_index.code n m → n = m
| -2       -2       := λc, idp
| -2       (succ l) := λc, empty.elim c
| (succ k) -2       := λc, empty.elim c
| (succ k) (succ l) := λc, ap succ c

@[hott] def succ_ne_minus_two (n : ℕ₋₂) : succ n ≠ -2 :=
trunc_index.encode

@[hott, instance] protected def has_decidable_eq : Π(n m : ℕ₋₂), decidable (n = m)
| -2     -2     := decidable.inl rfl
| (n.+1) -2     := decidable.inr trunc_index.encode
| -2     (m.+1) := decidable.inr trunc_index.encode
| (n.+1) (m.+1) :=
    match has_decidable_eq n m with
    | decidable.inl xeqy := decidable.inl (ap succ xeqy)
    | decidable.inr xney := decidable.inr (λh, xney (trunc_index.encode h))
    end

@[hott] def not_succ_le_minus_two {n : ℕ₋₂} (H : n .+1 ≤ -2) : empty :=
begin
  have : Πm, n.+1 ≤ m → m = -2 → empty,
  { intros m H, hinduction H with m H IH, exact succ_ne_minus_two n, exact succ_ne_minus_two m },
  exact this -2 H idp
end

@[hott] protected def le_trans {n m k : ℕ₋₂} (H1 : n ≤ m) (H2 : m ≤ k) : n ≤ k :=
begin
  induction H2 with k H2 IH,
  { exact H1},
  { exact le.step IH}
end

@[hott] protected def pred (n : ℕ₋₂) : ℕ₋₂ :=
trunc_index.rec -2 (λm _, m) n

@[hott] protected def pred_le (n : ℕ₋₂) : trunc_index.pred n ≤ n := by cases n; repeat { constructor }

@[hott] def pred_le_pred {n m : ℕ₋₂} (H : n ≤ m) : trunc_index.pred n ≤ trunc_index.pred m :=
begin
  hinduction H with k H2 IH, apply le.tr_refl, exact trunc_index.le_trans IH (trunc_index.pred_le k)
end

@[hott] def le_of_succ_le_succ {n m : ℕ₋₂} (H : n.+1 ≤ m.+1) : n ≤ m :=
pred_le_pred H

@[hott] def not_succ_le_self {n : ℕ₋₂} : ¬n.+1 ≤ n :=
begin
  induction n with n IH; intro H,
  { exact not_succ_le_minus_two H},
  { exact IH (le_of_succ_le_succ H)}
end

@[hott] protected def le_antisymm {n m : ℕ₋₂} (H1 : n ≤ m) (H2 : m ≤ n) : n = m :=
begin
  induction H2 with n H2 IH,
  { refl },
  { apply empty.elim, apply @not_succ_le_self n, exact trunc_index.le_trans H1 H2}
end

@[hott] protected def le_succ {n m : ℕ₋₂} (H1 : n ≤ m) : n ≤ m.+1 :=
le.step H1

@[hott] protected def self_le_succ (n : ℕ₋₂) : n ≤ n.+1 :=
le.step (trunc_index.le.tr_refl n)

-- the order is total
@[hott] protected def le_sum_le (n m : ℕ₋₂) : n ≤ m ⊎ m ≤ n :=
begin
  induction m with m IH,
  { exact inr (minus_two_le _)},
  { cases IH with H H,
    { exact inl (trunc_index.le_succ H)},
    { hinduction H with n' H x,
      { exact inl (trunc_index.self_le_succ _)},
      { exact inr (succ_le_succ H)}}}
end

end trunc_index open trunc_index

@[hott, instance, reducible] def linear_weak_order_trunc_index :
  linear_weak_order trunc_index :=
linear_weak_order.mk le trunc_index.le.tr_refl @trunc_index.le_trans @trunc_index.le_antisymm
                     trunc_index.le_sum_le

namespace trunc_index

/- more theorems about truncation indices -/

@[hott] def zero_add (n : ℕ₋₂) : (0 : ℕ₋₂) + n = n :=
begin
  cases n with n, refl,
  cases n with n, refl,
  induction n with n IH, refl, exact ap succ IH
end

@[hott] def add_zero (n : ℕ₋₂) : n + (0 : ℕ₋₂) = n :=
by refl

@[hott] def succ_add_nat (n : ℕ₋₂) (m : ℕ) : n.+1 + m = (n + m).+1 :=
begin induction m with m IH, refl, exact ap succ IH end

@[hott] def nat_add_succ (n : ℕ) (m : ℕ₋₂) : ↑n + m.+1 = (n + m).+1 :=
begin
  cases m with m, refl,
  cases m with m, refl,
  induction m with m IH, refl, exact ap succ IH
end

@[hott] def add_nat_succ (n : ℕ₋₂) (m : ℕ) : n + (nat.succ m) = (n + m).+1 :=
by refl

@[hott] def nat_succ_add (n : ℕ) (m : ℕ₋₂) : ↑(nat.succ n) + m = (n + m).+1 :=
begin
  cases m with m, refl,
  cases m with m, refl,
  induction m with m IH, refl, exact ap succ IH
end

@[hott] def sub_two_add_two (n : ℕ₋₂) : sub_two (add_two n) = n :=
begin
  induction n with n IH,
  { refl },
  { exact ap succ IH}
end

@[hott] def add_two_sub_two (n : ℕ) : add_two (sub_two n) = n :=
begin
  induction n with n IH,
  { refl },
  { exact ap nat.succ IH}
end

@[hott] def of_nat_add_plus_two_of_nat (n m : ℕ) : n +2+ m = of_nat (n + m + 2) :=
begin
  induction m with m IH,
  { refl },
  { exact ap succ IH}
end

@[hott] def of_nat_add_of_nat (n m : ℕ) : of_nat n + of_nat m = of_nat (n + m) :=
begin
  induction m with m IH,
  { refl },
  { exact ap succ IH}
end

@[hott] def succ_add_plus_two (n m : ℕ₋₂) : n.+1 +2+ m = (n +2+ m).+1 :=
begin
  induction m with m IH,
  { refl },
  { exact ap succ IH}
end

@[hott] def add_plus_two_succ (n m : ℕ₋₂) : n +2+ m.+1 = (n +2+ m).+1 :=
idp

@[hott] def add_succ_succ (n m : ℕ₋₂) : n + m.+2 = n +2+ m :=
idp

@[hott] def succ_add_succ (n m : ℕ₋₂) : n.+1 + m.+1 = n +2+ m :=
begin
  cases m with m IH,
  { refl },
  { apply succ_add_plus_two}
end

@[hott] def succ_succ_add (n m : ℕ₋₂) : n.+2 + m = n +2+ m :=
begin
  cases m with m IH,
  { refl },
  { exact succ_add_succ _ _ ⬝ succ_add_plus_two _ _}
end

@[hott] def succ_sub_two (n : ℕ) : (nat.succ n).-2 = n.-2 .+1 := rfl
@[hott] def sub_two_succ_succ (n : ℕ) : n.-2.+1.+1 = n := rfl
@[hott] def succ_sub_two_succ (n : ℕ) : (nat.succ n).-2.+1 = n := rfl

@[hott] def of_nat_add_two (n : ℕ₋₂) : of_nat (add_two n) = n.+2 :=
begin induction n with n IH, refl, exact ap succ IH end

@[hott] def of_nat_le_of_nat {n m : ℕ} (H : n ≤ m) : (of_nat n ≤ of_nat m) :=
begin
  induction H with m H IH,
  { apply le.refl },
  { exact trunc_index.le_succ IH}
end

@[hott] def sub_two_le_sub_two {n m : ℕ} (H : n ≤ m) : n.-2 ≤ m.-2 :=
begin
  induction H with m H IH,
  { apply le.refl },
  { exact trunc_index.le_succ IH}
end

@[hott] def add_two_le_add_two {n m : ℕ₋₂} (H : n ≤ m) : add_two n ≤ add_two m :=
begin
  induction H with m H IH,
  { refl },
  { constructor, exact IH},
end

@[hott] def le_of_sub_two_le_sub_two {n m : ℕ} (H : n.-2 ≤ m.-2) : n ≤ m :=
begin
  rwr [←add_two_sub_two n, ←add_two_sub_two m],
  exact add_two_le_add_two H,
end

@[hott] def le_of_of_nat_le_of_nat {n m : ℕ} (H : of_nat n ≤ of_nat m) : n ≤ m :=
begin
  apply le_of_sub_two_le_sub_two,
  exact le_of_succ_le_succ (le_of_succ_le_succ H)
end

@[hott] protected theorem succ_le_of_not_le {n m : ℕ₋₂} (H : ¬ n ≤ m) : m.+1 ≤ n :=
begin
  cases (le.total n m) with H2 H2,
  { apply empty.elim, exact H H2},
  { hinduction H2 with n' H2' x,
    { apply empty.elim, exact H (le.refl _)},
    { exact succ_le_succ H2'}}
end

@[hott, instance] def trunc_index.decidable_le : Π(n m : ℕ₋₂), decidable (n ≤ m) :=
begin
  intro n, induction n with n IH; intro m,
  { left, apply minus_two_le},
  cases m with m,
  { right, apply not_succ_le_minus_two},
  cases IH m with H H,
  { left, apply succ_le_succ H},
  right, intro H2, apply H, exact le_of_succ_le_succ H2
end

end trunc_index open trunc_index

namespace is_trunc

variables {A : Type _} {B : Type _} {n : ℕ₋₂}

/- closure properties of truncatedness -/
@[hott] theorem is_trunc_is_embedding_closed (f : A → B) [Hf : is_embedding f] [HB : is_trunc n B]
  (Hn : -1 ≤ n) : is_trunc n A :=
begin
  unfreezeI; induction n with n,
    {apply empty.elim, exact not_succ_le_minus_two Hn},
    {apply is_trunc_succ_intro, intros a a',
        fapply @is_trunc_is_equiv_closed_rev _ _ n (ap f), resetI, apply_instance }
end

@[hott] theorem is_trunc_is_retraction_closed (f : A → B) [Hf : is_retraction f]
  (n : ℕ₋₂) [HA : is_trunc n A] : is_trunc n B :=
begin
  unfreezeI; induction n with n IH generalizing A B f Hf HA,
  { induction Hf with g ε, fapply is_contr.mk,
    { exactI f (center A) },
    { intro b, apply concat,
      { apply (ap f), exact (center_eq (g b)) },
      { apply ε }}},
  { induction Hf with g ε,
    apply is_trunc_succ_intro, intros b b',
    napply @IH (g b = g b') _ (λq, (ε b)⁻¹ ⬝ ap f q ⬝ ε b'),
    { apply (is_retraction.mk (ap g)),
      { intro p, induction p, dsimp [ap], apply con.left_inv }},
    { apply is_trunc_eq }}
end

@[hott] def is_embedding_to_fun (A B : Type _) : is_embedding (@to_fun A B)  :=
λf f', is_equiv_ap_to_fun _ _

/- theorems about trunctype -/
@[hott] protected def trunctype.sigma_char (n : ℕ₋₂) :
  (trunctype.{u} n) ≃ (Σ (A : Type u), is_trunc n A) :=
begin
  fapply equiv.MK,
  { intro A, exact (⟨carrier A, struct A⟩)},
  { intro S, exact (trunctype.mk S.1 S.2)},
  { intro S, induction S with S1 S2, refl },
  { intro A, induction A with A1 A2, refl },
end

@[hott] def trunctype_eq_equiv (n : ℕ₋₂) (A B : n-Type) :
  (A = B) ≃ (carrier A = carrier B) :=
calc
  (A = B) ≃ (to_fun (trunctype.sigma_char n) A = to_fun (trunctype.sigma_char n) B)
            : eq_equiv_fn_eq_of_equiv (trunctype.sigma_char n) A B
    ... ≃ ((to_fun (trunctype.sigma_char n) A).1 = (to_fun (trunctype.sigma_char n) B).1)
            : equiv.symm (equiv_subtype _ _)
    ... ≃ (carrier A = carrier B) : erfl

@[hott, instance] theorem is_trunc_trunctype (n : ℕ₋₂) : is_trunc n.+1 (n-Type) :=
begin
  apply is_trunc_succ_intro, intros X Y,
  fapply is_trunc_equiv_closed_rev _ (trunctype_eq_equiv _ _ _),
  fapply is_trunc_equiv_closed_rev _ (eq_equiv_equiv _ _),
  induction n,
  { napply is_contr_of_inhabited_prop,
    { apply is_trunc_equiv },
    { apply equiv_of_is_contr_of_is_contr }},
  { apply is_trunc_equiv }
end

/- univalence for truncated types -/
@[hott] def teq_equiv_equiv {n : ℕ₋₂} {A B : n-Type} : (A = B) ≃ (A ≃ B) :=
trunctype_eq_equiv n A B ⬝e eq_equiv_equiv A B

@[hott] def tua {n : ℕ₋₂} {A B : n-Type} (f : A ≃ B) : A = B :=
(trunctype_eq_equiv n A B)⁻¹ᶠ (ua f)

@[hott] def tua_refl {n : ℕ₋₂} (A : n-Type) : tua (@erfl A) = idp :=
begin
  refine ap (trunctype_eq_equiv n A A)⁻¹ᶠ (ua_refl A) ⬝ _,
  refine ap (eq_of_fn_eq_fn _) _ ⬝ eq_of_fn_eq_fn'_idp _ _,
  apply ap (dpair_eq_dpair idp) (is_prop.elim _ idpo),
  apply is_trunc.is_trunc_pathover
end

@[hott] def tua_trans {n : ℕ₋₂} {A B C : n-Type} (f : A ≃ B) (g : B ≃ C)
  : tua (f ⬝e g) = tua f ⬝ tua g :=
begin
  refine ap (trunctype_eq_equiv n A C)⁻¹ᶠ (ua_trans f g) ⬝ _,
  refine ap (eq_of_fn_eq_fn _) _ ⬝ eq_of_fn_eq_fn'_con _ _ _,
  refine _ ⬝ dpair_eq_dpair_con _ _ _ _,
  apply ap (dpair_eq_dpair _), apply is_prop.elim
end

@[hott] def tua_symm {n : ℕ₋₂} {A B : n-Type} (f : A ≃ B) : tua f⁻¹ᵉ = (tua f)⁻¹ :=
begin
  apply eq_inv_of_con_eq_idp',
  refine (tua_trans _ _)⁻¹ ⬝ _,
  refine ap tua _ ⬝ (tua_refl _),
  apply equiv_eq, exact to_right_inv f
end

@[hott] def tcast {n : ℕ₋₂} {A B : n-Type} (p : A = B) (a : A) : B :=
cast (ap trunctype.carrier p) a

@[hott] def ptcast {n : ℕ₋₂} {A B : n-Type*} (p : A = B) : ↑A →* ↑B :=
pcast (ap ptrunctype.to_pType p)

@[hott] theorem tcast_tua_fn {n : ℕ₋₂} {A B : n-Type} (f : A ≃ B) : tcast (tua f) = to_fun f :=
begin
  cases A with A HA, cases B with B HB, dsimp at f,
  hinduction f using rec_on_ua_idp,
  have : HA = HB, from is_prop.elim _ _, hinduction this,
  exact ap tcast (tua_refl _)
end

/- theorems about decidable equality and axiom K -/
@[hott] theorem is_set_of_axiom_K {A : Type _} (K : Π{a : A} (p : a = a), p = idp) : is_set A :=
is_set.mk _ (λa b p q, begin induction q, apply K end)

@[hott] theorem is_set_of_relation {A : Type u} (R : A → A → Type u)
  (mere : Π(a b : A), is_prop (R a b)) (refl : Π(a : A), R a a)
  (imp : Π{a b : A}, R a b → a = b) : is_set A :=
is_set_of_axiom_K
  (λa p,
    have H2 : transport (λx, R a x → a = x) p (@imp a a) = @imp a a, from apdt (@imp a) p,
    have H3 : Π(r : R a a), transport (λx, a = x) p (imp r)
                            = imp (transport (λx, R a x) p r), from
      to_fun ((heq_pi _ _ _)⁻¹ᵉ) H2,
    have H4 : imp (refl a) ⬝ p = imp (refl a), from
      calc
        imp (refl a) ⬝ p = transport (λx, a = x) p (imp (refl a)) : (eq_transport_r _ _)⁻¹
          ... = imp (transport (λx, R a x) p (refl a)) : H3 _
          ... = imp (refl a) : ap imp (is_prop.elim _ _),
    cancel_left (imp (refl a)) H4)

@[hott] def relation_equiv_eq {A : Type _} (R : A → A → Type _)
  (mere : Π(a b : A), is_prop (R a b)) (refl : Π(a : A), R a a)
  (imp : Π{a b : A}, R a b → a = b) (a b : A) : R a b ≃ a = b :=
have is_set A, from is_set_of_relation R mere refl @imp,
by exactI equiv_of_is_prop imp (λp, transport (R a) p (refl a))

local attribute [reducible] not
@[hott] theorem is_set_of_double_neg_elim {A : Type _} (H : Π(a b : A), ¬¬a = b → a = b)
  : is_set A :=
is_set_of_relation (λa b, ¬¬a = b) (by apply_instance) (λa n, n idp) H

section
open decidable
--this is proven differently in init.hedberg
@[hott] theorem is_set_of_decidable_eq (A : Type _) [H : decidable_eq A] : is_set A :=
is_set_of_double_neg_elim (λa b, decidable.by_contradiction)
end

@[hott] theorem is_trunc_of_axiom_K_of_le {A : Type _} {n : ℕ₋₂} (H : -1 ≤ n)
  (K : Π(a : A), is_trunc n (a = a)) : is_trunc (n.+1) A :=
@is_trunc_succ_intro _ _ (λa b, is_trunc_of_imp_is_trunc_of_le H
  begin intro p; induction p; apply K end)

@[hott] theorem is_trunc_succ_of_is_trunc_loop (Hn : -1 ≤ n) (Hp : Π(a : A), is_trunc n (a = a))
  : is_trunc (n.+1) A :=
begin
  apply is_trunc_succ_intro, intros a a',
  apply is_trunc_of_imp_is_trunc_of_le Hn, intro p,
  induction p, apply Hp
end

@[hott] theorem is_prop_iff_is_contr {A : Type _} (a : A) :
  is_prop A ↔ is_contr A :=
iff.intro (λH, by exactI is_contr.mk a (is_prop.elim a)) (by introI; apply_instance)

@[hott] theorem is_trunc_succ_iff_is_trunc_loop (A : Type _) (Hn : -1 ≤ n) :
  is_trunc (n.+1) A ↔ Π(a : A), is_trunc n (a = a) :=
iff.intro (by introI; apply_instance) (is_trunc_succ_of_is_trunc_loop Hn)

@[hott] theorem is_trunc_iff_is_contr_loopn_succ (n : ℕ) (A : Type _)
  : is_trunc n A ↔ Π(a : A), is_contr (Ω[n+1](pointed.Mk a)) :=
begin
  induction n with n IH generalizing A,
  { dsimp [loopn], transitivity _,
    { apply is_trunc_succ_iff_is_trunc_loop, apply le.refl },
    { apply pi_iff_pi, intro a, apply is_prop_iff_is_contr, refl }},
  { dsimp [loopn],
    transitivity _,
    { apply @is_trunc_succ_iff_is_trunc_loop @n, apply minus_one_le_succ },
    apply pi_iff_pi, intro a, transitivity _, apply IH,
    transitivity _, apply pi_iff_pi, intro p,
    rwr [@loopn_space_loop_irrel (pointed.MK A a) n p],
    exact ⟨λf, f idp, λH _, H⟩ }
end

@[hott] theorem is_trunc_iff_is_contr_loopn (n : ℕ) (A : Type _)
  : is_trunc (n.-2.+1) A ↔ (Π(a : A), is_contr (Ω[n](pointed.Mk a))) :=
begin
  induction n with n,
  { dsimp [sub_two,loopn], apply iff.intro,
      intros H a, exactI is_contr_of_inhabited_prop a,
      intro H, apply is_prop_of_imp_is_contr, exact H},
  { applyI is_trunc_iff_is_contr_loopn_succ },
end

-- rename to is_contr_loopn_of_is_trunc
@[hott] theorem is_contr_loop_of_is_trunc (n : ℕ) (A : Type*) [H : is_trunc (n.-2.+1) A] :
  is_contr (Ω[n] A) :=
begin
  unfreezeI; induction A,
  apply iff.mp (is_trunc_iff_is_contr_loopn _ _) H
end

-- rename to is_trunc_loopn_of_is_trunc
@[hott] theorem is_trunc_loop_of_is_trunc (n : ℕ₋₂) (k : ℕ) (A : Type*) [H : is_trunc n A] :
  is_trunc n (Ω[k] A) :=
begin
  induction k with k IH,
  { exact H },
  { applyI is_trunc_eq }
end

@[hott] def is_trunc_loopn (k : ℕ₋₂) (n : ℕ) (A : Type*) [H : is_trunc (k+n) A]
  : is_trunc k (Ω[n] A) :=
begin
  unfreezeI; induction n with n IH generalizing k H, exact H,
  napply is_trunc_eq, napply IH, rwr [succ_add_nat], rwr [add_nat_succ] at H, exact H
end

@[hott] def is_set_loopn (n : ℕ) (A : Type*) [is_trunc n A] : is_set (Ω[n] A) :=
have is_trunc (0 + ↑n) A, by rwr [trunc_index.zero_add]; apply_instance,
by exactI is_trunc_loopn 0 n A

@[hott] def pequiv_punit_of_is_contr (A : Type*) (H : is_contr A) : A ≃* unit* :=
pequiv_of_equiv (equiv_unit_of_is_contr A) (is_prop.elim _ _)

@[hott] def pequiv_punit_of_is_contr' (A : Type _) (H : is_contr A)
  : pointed.MK A (center A) ≃* unit* :=
pequiv_punit_of_is_contr (pointed.MK A (center A)) H

@[hott] def is_trunc_is_contr_fiber (n : ℕ₋₂) {A B : Type _} (f : A → B)
  (b : B) [is_trunc n A] [is_trunc n B] : is_trunc n (is_contr (fiber f b)) :=
begin
  unfreezeI; cases n,
  { applyI is_contr_of_inhabited_prop, napply is_contr_fun_of_is_equiv,
    apply is_equiv_of_is_contr },
  { applyI is_trunc_succ_of_is_prop }
end

end is_trunc open is_trunc

namespace trunc
variables {n : ℕ₋₂} {A : Type u} {B : Type _} {a₁ a₂ a₃ a₄ : A}

@[hott] def trunc_functor2 {n : ℕ₋₂} {A B C : Type _} (f : A → B → C)
  (x : trunc n A) (y : trunc n B) : trunc n C :=
by hinduction x with a; hinduction y with b; exact tr (f a b)

@[hott] def tconcat (p : trunc n (a₁ = a₂)) (q : trunc n (a₂ = a₃)) :
  trunc n (a₁ = a₃) :=
trunc_functor2 concat p q

@[hott] def tinverse (p : trunc n (a₁ = a₂)) : trunc n (a₂ = a₁) :=
trunc_functor _ inverse p

@[hott, reducible] def tidp : trunc n (a₁ = a₁) :=
tr idp

@[hott] def tassoc (p : trunc n (a₁ = a₂)) (q : trunc n (a₂ = a₃))
  (r : trunc n (a₃ = a₄)) : tconcat (tconcat p q) r = tconcat p (tconcat q r) :=
by hinduction p; hinduction q; hinduction r; exact ap tr (con.assoc _ _ _)

@[hott] def tidp_tcon (p : trunc n (a₁ = a₂)) : tconcat tidp p = p :=
by hinduction p; exact ap tr (idp_con _)

@[hott] def tcon_tidp (p : trunc n (a₁ = a₂)) : tconcat p tidp = p :=
by hinduction p; refl

@[hott] def left_tinv (p : trunc n (a₁ = a₂)) : tconcat (tinverse p) p = tidp :=
by hinduction p; exact ap tr (con.left_inv _)

@[hott] def right_tinv (p : trunc n (a₁ = a₂)) : tconcat p (tinverse p) = tidp :=
by hinduction p; exact ap tr (con.right_inv _)

@[hott] def tap (f : A → B) (p : trunc n (a₁ = a₂)) : trunc n (f a₁ = f a₂) :=
trunc_functor _ (ap f) p

@[hott] def tap_tidp (f : A → B) : tap f (@tidp n A a₁) = tidp := idp
@[hott] def tap_tcon (f : A → B) (p : trunc n (a₁ = a₂)) (q : trunc n (a₂ = a₃)) :
  tap f (tconcat p q) = tconcat (tap f p) (tap f q) :=
by hinduction p; hinduction q; exact ap tr (ap_con _ _ _)

/- characterization of equality in truncated types -/
@[hott] protected def code (n : ℕ₋₂) (aa aa' : trunc n.+1 A) : trunctype.{u} n :=
by hinduction aa with a; hinduction aa' with a'; exact trunctype.mk' n (trunc n (a = a'))

@[hott] protected def encode {n : ℕ₋₂} {aa aa' : trunc n.+1 A}
  : aa = aa' → trunc.code n aa aa' :=
begin
  intro p, induction p, hinduction aa with a, exact tr idp
end

@[hott] protected def decode {n : ℕ₋₂} (aa aa' : trunc n.+1 A) :
  trunc.code n aa aa' → aa = aa' :=
begin
  hinduction aa' with a', hinduction aa with a,
  dsimp [trunc.code, trunc.rec_on], intro x,
  hinduction x with p, exact ap tr p,
end

@[hott] def trunc_eq_equiv (n : ℕ₋₂) (aa aa' : trunc n.+1 A)
  : aa = aa' ≃ trunc.code n aa aa' :=
begin
  fapply equiv.MK,
  { apply trunc.encode},
  { apply trunc.decode},
  { hinduction aa', hinduction aa, intro x,
    hinduction x with p,
      induction p, refl },
  { intro p, hinduction p, hinduction aa, refl },
end

@[hott] def tr_eq_tr_equiv (n : ℕ₋₂) (a a' : A)
  : (tr a = tr a' :> trunc n.+1 A) ≃ trunc n (a = a') :=
trunc_eq_equiv _ _ _

@[hott] def trunc_eq {n : ℕ₋₂} {a a' : A} (p : trunc n (a = a')) :tr a = tr a' :> trunc n.+1 A :=
(tr_eq_tr_equiv _ _ _)⁻¹ᵉ.to_fun p

@[hott] def code_mul {n : ℕ₋₂} {aa₁ aa₂ aa₃ : trunc n.+1 A}
  (g : trunc.code n aa₁ aa₂) (h : trunc.code n aa₂ aa₃) : trunc.code n aa₁ aa₃ :=
begin
  hinduction aa₁ with a₁, hinduction aa₂ with a₂, hinduction aa₃ with a₃,
  apply tconcat g h,
end

/- encode preserves concatenation -/
@[hott] def encode_con' {n : ℕ₋₂} {aa₁ aa₂ aa₃ : trunc n.+1 A} (p : aa₁ = aa₂) (q : aa₂ = aa₃)
  : trunc.encode (p ⬝ q) = code_mul (trunc.encode p) (trunc.encode q) :=
begin
  induction p, induction q, hinduction aa₁ with a₁, refl
end

@[hott] def encode_con {n : ℕ₋₂} {a₁ a₂ a₃ : A} (p : tr a₁ = tr a₂ :> trunc (n.+1) A)
  (q : tr a₂ = tr a₃ :> trunc (n.+1) A)
  : trunc.encode (p ⬝ q) = tconcat (trunc.encode p) (trunc.encode q) :=
encode_con' p q

/- the principle of unique choice -/
@[hott] def unique_choice {P : A → Type _} [H : Πa, is_prop (P a)] (f : Πa, ∥ P a ∥) (a : A)
  : P a :=
(trunc_equiv _ _).to_fun (f a)

/- transport over a truncated family -/
@[hott] def trunc_transport {a a' : A} {P : A → Type _} (p : a = a') (n : ℕ₋₂) (x : P a)
  : transport (λa, trunc n (P a)) p (tr x) = tr (p ▸ x) :=
by induction p; refl

/- pathover over a truncated family -/
@[hott] def trunc_pathover {A : Type _} {B : A → Type _} {n : ℕ₋₂} {a a' : A} {p : a = a'}
  {b : B a} {b' : B a'} (q : b =[p] b') : @tr n _ b =[p; λa, trunc n (B a)] @tr n _ b' :=
by induction q; constructor

/- truncations preserve truncatedness -/
@[hott, instance, priority 500] def is_trunc_trunc_of_is_trunc (A : Type _)
  (n m : ℕ₋₂) [H : is_trunc n A] : is_trunc n (trunc m A) :=
begin
  unfreezeI; induction n with n IH generalizing A m H,
  { napply is_contr_equiv_closed,
    { symmetry, napply trunc_equiv, applyI (@is_trunc_of_le _ -2), apply minus_two_le},
    apply_instance },
  { induction m with m,
    { apply (@is_trunc_of_le _ -2), apply minus_two_le},
    { apply is_trunc_succ_intro, intros aa aa',
      hinduction aa, hinduction aa',
      apply is_trunc_equiv_closed_rev,
      { apply tr_eq_tr_equiv },
      { apply IH }}}
end

/- equivalences between truncated types (see also hit.trunc) -/
@[hott] def trunc_trunc_equiv_left (A : Type _) {n m : ℕ₋₂} (H : n ≤ m)
  : trunc n (trunc m A) ≃ trunc n A :=
begin
  haveI H2 := is_trunc_of_le (trunc n A) H,
  fapply equiv.MK,
  { intro x, hinduction x with x, hinduction x with x, exact tr x },
  { intro x, hinduction x with x, exact tr (tr x) },
  { intro x, hinduction x with x, refl },
  { intro x, hinduction x with x, hinduction x with x, refl }
end

@[hott] def trunc_trunc_equiv_right (A : Type _) {n m : ℕ₋₂} (H : n ≤ m)
  : trunc m (trunc n A) ≃ trunc n A :=
begin
  napply trunc_equiv,
  exact is_trunc_of_le _ H,
end

@[hott] def trunc_equiv_trunc_of_le {n m : ℕ₋₂} {A B : Type _} (H : n ≤ m)
  (f : trunc m A ≃ trunc m B) : trunc n A ≃ trunc n B :=
(trunc_trunc_equiv_left A H)⁻¹ᵉ ⬝e trunc_equiv_trunc n f ⬝e trunc_trunc_equiv_left B H

@[hott] def trunc_trunc_equiv_trunc_trunc (n m : ℕ₋₂) (A : Type _)
  : trunc n (trunc m A) ≃ trunc m (trunc n A) :=
begin
  fapply equiv.MK; intro x,
  { hinduction x with x, hinduction x with x, exact tr (tr x) },
  { hinduction x with x, hinduction x with x, exact tr (tr x) },
  { hinduction x with x, hinduction x with x, refl },
  { hinduction x with x, hinduction x with x, refl }
end

@[hott] theorem is_trunc_trunc_of_le (A : Type _)
  (n : ℕ₋₂) {m k : ℕ₋₂} (H : m ≤ k) [is_trunc n (trunc k A)] : is_trunc n (trunc m A) :=
begin
  apply is_trunc_equiv_closed,
  { apply trunc_trunc_equiv_left, exact H },
  apply_instance
end

@[hott] def trunc_functor_homotopy {X Y : Type _} (n : ℕ₋₂) {f g : X → Y}
  (p : f ~ g) (x : trunc n X) : trunc_functor n f x = trunc_functor n g x :=
begin
  hinduction x with x, exact ap tr (p x)
end

@[hott] def trunc_functor_homotopy_of_le {n k : ℕ₋₂} {A B : Type _} (f : A → B) (H : n ≤ k) :
  to_fun (trunc_trunc_equiv_left B H) ∘
  trunc_functor n (trunc_functor k f) ∘
  to_fun (trunc_trunc_equiv_left A H)⁻¹ᵉ ~
    trunc_functor n f :=
begin
  intro x, hinduction x with x, refl
end

@[hott] def is_equiv_trunc_functor_of_le {n k : ℕ₋₂} {A B : Type _} (f : A → B) (H : n ≤ k)
  [Hf : is_equiv (trunc_functor k f)] : is_equiv (trunc_functor n f) :=
is_equiv_of_equiv_of_homotopy (trunc_equiv_trunc_of_le H (equiv.mk (trunc_functor k f) Hf))
                              (trunc_functor_homotopy_of_le f H)

/- trunc_functor preserves surjectivity -/

--set_option trace.hinduction true
@[hott] def is_surjective_trunc_functor {A B : Type _} (n : ℕ₋₂) (f : A → B) [H : is_surjective f]
  : is_surjective (trunc_functor n f) :=
begin
  cases n with n; intro b,
  { exact tr (fiber.mk (center _) (is_prop.elim _ _)) },
  { haveI : Πb, is_trunc n.+1 (image (trunc_functor n.+1 f) b),
    { intro b, exact is_trunc_of_le _ (minus_one_le_succ _) },
    unfreezeI; hinduction b with b,
    hinduction H b with x p, induction p with a p,
    exact tr (fiber.mk (tr a) (ap tr p)) }
end

/- truncation of pointed types -/
@[hott] def ptrunc (n : ℕ₋₂) (X : Type*) : Type* :=
⟨trunc n X, tr pt⟩

@[hott] instance is_trunc_ptrunc (n : ℕ₋₂) (X : Type*) : is_trunc n (ptrunc n X) :=
is_trunc_trunc n X

@[hott] def pttrunc (n : ℕ₋₂) (X : Type*) : n-Type* :=
ptrunctype.mk (ptrunc n X) (is_trunc_trunc n X)

/- pointed maps involving ptrunc -/
@[hott] def ptrunc_functor {X Y : Type*} (n : ℕ₋₂) (f : X →* Y)
  : ptrunc n X →* ptrunc n Y :=
pmap.mk (trunc_functor n f) (ap tr (respect_pt f))

@[hott] def ptr (n : ℕ₋₂) (A : Type*) : A →* ptrunc n A :=
pmap.mk tr idp

@[hott] def puntrunc (n : ℕ₋₂) (A : Type*) [is_trunc n A] : ptrunc n A →* A :=
pmap.mk untrunc_of_is_trunc idp

@[hott] def ptrunc.elim (n : ℕ₋₂) {X Y : Type*} [is_trunc n Y] (f : X →* Y) :
  ptrunc n X →* Y :=
pmap.mk (trunc.elim f) (respect_pt f)

/- pointed equivalences involving ptrunc -/
@[hott] def ptrunc_pequiv_ptrunc (n : ℕ₋₂) {X Y : Type*} (H : X ≃* Y)
  : ptrunc n X ≃* ptrunc n Y :=
pequiv_of_equiv (trunc_equiv_trunc n (equiv_of_pequiv H)) (ap tr (respect_pt H.to_pmap))

@[hott] def ptrunc_pequiv (n : ℕ₋₂) (X : Type*) [H : is_trunc n X]
  : ptrunc n X ≃* X :=
pequiv_of_equiv (trunc_equiv n X) idp

@[hott] def ptrunc_ptrunc_pequiv_left (A : Type*) {n m : ℕ₋₂} (H : n ≤ m)
  : ptrunc n (ptrunc m A) ≃* ptrunc n A :=
pequiv_of_equiv (trunc_trunc_equiv_left A H) idp

@[hott] def ptrunc_ptrunc_pequiv_right (A : Type*) {n m : ℕ₋₂} (H : n ≤ m)
  : ptrunc m (ptrunc n A) ≃* ptrunc n A :=
pequiv_of_equiv (trunc_trunc_equiv_right A H) idp

@[hott] def ptrunc_pequiv_ptrunc_of_le {n m : ℕ₋₂} {A B : Type*} (H : n ≤ m)
  (f : ptrunc m A ≃* ptrunc m B) : ptrunc n A ≃* ptrunc n B :=
(ptrunc_ptrunc_pequiv_left A H)⁻¹ᵉ* ⬝e*
ptrunc_pequiv_ptrunc n f ⬝e*
ptrunc_ptrunc_pequiv_left B H

@[hott] def ptrunc_ptrunc_pequiv_ptrunc_ptrunc (n m : ℕ₋₂) (A : Type*)
  : ptrunc n (ptrunc m A) ≃* ptrunc m (ptrunc n A) :=
pequiv_of_equiv (trunc_trunc_equiv_trunc_trunc n m A) idp

@[hott] def loop_ptrunc_pequiv (n : ℕ₋₂) (A : Type*) :
  Ω (ptrunc (n+1) A) ≃* ptrunc n (Ω A) :=
pequiv_of_equiv (tr_eq_tr_equiv _ _ _) idp

@[hott] def loop_ptrunc_pequiv_con {n : ℕ₋₂} {A : Type*} (p q : Ω (ptrunc (n+1) A)) :
  (loop_ptrunc_pequiv n A).to_pmap (p ⬝ q) =
    tconcat ((loop_ptrunc_pequiv n A).to_pmap p) ((loop_ptrunc_pequiv n A).to_pmap q) :=
encode_con p q

@[hott] def loopn_ptrunc_pequiv (n : ℕ₋₂) (k : ℕ) (A : Type*) :
  Ω[k] (ptrunc (n+k) A) ≃* ptrunc n (Ω[k] A) :=
begin
  induction k with k IH generalizing n,
  { refl },
  { refine _ ⬝e* loop_ptrunc_pequiv n (Ω[k] A),
    change Ω (Ω[k] (ptrunc (n + succ k) A)) ≃* Ω (ptrunc (n + 1) (Ω[k] A)),
    apply loop_pequiv_loop,
    refine _ ⬝e* IH (n.+1),
    exact loopn_pequiv_loopn k (pequiv_of_eq (ap (λn, ptrunc n A) (succ_add_nat _ _)⁻¹ᵖ)) }
end

@[hott] def loopn_ptrunc_pequiv_con {n : ℕ₋₂} {k : ℕ} {A : Type*}
  (p q : Ω[succ k] (ptrunc (n+nat.succ k) A)) :
  (loopn_ptrunc_pequiv n (succ k) A).to_pmap (p ⬝ q) =
  tconcat ((loopn_ptrunc_pequiv n (succ k) A).to_pmap p)
          ((loopn_ptrunc_pequiv n (succ k) A).to_pmap q)  :=
begin
  refine _ ⬝ loop_ptrunc_pequiv_con _ _,
  exact ap (loop_ptrunc_pequiv _ _).to_fun (loop_pequiv_loop_con _ _ _)
end

@[hott] def loopn_ptrunc_pequiv_inv_con {n : ℕ₋₂} {k : ℕ} {A : Type*}
  (p q : ptrunc n (Ω[succ k] A)) :
  (loopn_ptrunc_pequiv n (succ k) A)⁻¹ᵉ*.to_fun (tconcat p q) =
  (loopn_ptrunc_pequiv n (succ k) A)⁻¹ᵉ*.to_fun p ⬝
  (loopn_ptrunc_pequiv n (succ k) A)⁻¹ᵉ*.to_fun q :=
equiv.inv_preserve_binary (loopn_ptrunc_pequiv n (succ k) A).to_equiv concat tconcat
  (@loopn_ptrunc_pequiv_con n k A) p q

/- pointed homotopies involving ptrunc -/
@[hott] def ptrunc_functor_pcompose {X Y Z : Type*} (n : ℕ₋₂) (g : Y →* Z)
  (f : X →* Y) : ptrunc_functor n (g ∘* f) ~* ptrunc_functor n g ∘* ptrunc_functor n f :=
begin
  fapply phomotopy.mk,
  { exact trunc_functor_compose n g f },
  { refine idp_con _ ⬝ _, refine whisker_right _ (ap_compose' _ _ _) ⬝ _,
    refine whisker_right _ (ap_compose tr g _) ⬝ _, exact (ap_con _ _ _)⁻¹ },
end

@[hott] def ptrunc_functor_pid (X : Type*) (n : ℕ₋₂) :
  ptrunc_functor n (pid X) ~* pid (ptrunc n X) :=
begin
  fapply phomotopy.mk,
  { apply trunc_functor_id},
  { refl },
end

@[hott] def ptrunc_functor_pcast {X Y : Type*} (n : ℕ₋₂) (p : X = Y) :
  ptrunc_functor n (pcast p) ~* pcast (ap (ptrunc n) p) :=
begin
  fapply phomotopy.mk,
  { intro x, refine trunc_functor_cast _ _ _ ⬝ _,
    refine ap010 (@hott.eq.cast (ptrunc n X) (@ptrunc n Y)) _ x,
    refine ap_compose' _ _ _ ⬝ _ ⬝ ap_compose _ _ _, refl },
  { induction p, refl },
end

@[hott] def ptrunc_functor_phomotopy {X Y : Type*} (n : ℕ₋₂) {f g : X →* Y}
  (p : f ~* g) : ptrunc_functor n f ~* ptrunc_functor n g :=
begin
  fapply phomotopy.mk,
  { exact trunc_functor_homotopy n p},
  { refine (ap_con _ _ _)⁻¹ ⬝ _, exact ap02 tr (to_homotopy_pt p)},
end

@[hott] def pcast_ptrunc (n : ℕ₋₂) {A B : Type*} (p : A = B) :
  pcast (ap (ptrunc n) p) ~* ptrunc_functor n (pcast p) :=
begin
  fapply phomotopy.mk,
  { intro a, induction p, exact (trunc_functor_id _ _ _)⁻¹ },
  { induction p, refl }
end

@[hott] def ptrunc_elim_ptr (n : ℕ₋₂) {X Y : Type*} [is_trunc n Y] (f : X →* Y) :
  ptrunc.elim n f ∘* ptr n X ~* f :=
begin
  fapply phomotopy.mk,
  { refl },
  { refl }
end

@[hott] def ptrunc_elim_phomotopy (n : ℕ₋₂) {X Y : Type*} [is_trunc n Y] {f g : X →* Y}
  (H : f ~* g) : ptrunc.elim n f ~* ptrunc.elim n g :=
begin
  fapply phomotopy.mk,
  { intro x, hinduction x with x, exact H x },
  { exact to_homotopy_pt H }
end

@[hott] def ap1_ptrunc_functor (n : ℕ₋₂) {A B : Type*} (f : A →* B) :
  Ω→ (ptrunc_functor (n.+1) f) ∘* (loop_ptrunc_pequiv n A)⁻¹ᵉ*.to_pmap ~*
  (loop_ptrunc_pequiv n B)⁻¹ᵉ*.to_pmap ∘* ptrunc_functor n (Ω→ f) :=
begin
  fapply phomotopy.mk,
  { intro p, hinduction p with p,
    refine ((ap_inv _ _)⁻¹ ◾ (ap_compose _ _ _)⁻¹ ◾ idp) ⬝ _ ⬝ (ap_con _ _ _)⁻¹ᵖ,
    apply whisker_right, refine _ ⬝ (ap_con _ _ _)⁻¹ᵖ,
    exact whisker_left _ (ap_compose' _ _ _)⁻¹ᵖ },
  { induction B with B b, induction f with f p, dsimp at f, dsimp at p, hinduction p, refl }
end

@[hott] def ap1_ptrunc_elim (n : ℕ₋₂) {A B : Type*} (f : A →* B) [is_trunc (n.+1) B] :
  Ω→ (ptrunc.elim (n.+1) f) ∘* (loop_ptrunc_pequiv n A)⁻¹ᵉ*.to_pmap ~*
  ptrunc.elim n (Ω→ f) :=
begin
  fapply phomotopy.mk,
  { intro p, hinduction p with p, exact idp ◾ (ap_compose _ _ _)⁻¹ ◾ idp },
  { refl }
end

@[hott] def ap1_ptr (n : ℕ₋₂) (A : Type*) :
  Ω→ (ptr (n.+1) A) ~* (loop_ptrunc_pequiv n A)⁻¹ᵉ*.to_pmap ∘* ptr n (Ω A) :=
begin
  fapply phomotopy.mk,
  { intro p, apply idp_con },
  { refl }
end

@[hott] def ptrunc_elim_ptrunc_functor (n : ℕ₋₂) {A B C : Type*} (g : B →* C) (f : A →* B)
  [is_trunc n C] :
  ptrunc.elim n g ∘* ptrunc_functor n f ~* ptrunc.elim n (g ∘* f) :=
begin
  fapply phomotopy.mk,
  { intro x, hinduction x with a, refl },
  { refine idp_con _ ⬝ whisker_right _ (ap_compose' _ _ _)⁻¹ᵖ },
end

end trunc open trunc

/- The truncated encode-decode method -/
namespace eq

@[hott] def truncated_encode {k : ℕ₋₂} {A : Type _} {a₀ a : A} {code : A → Type _}
  [Πa, is_trunc k (code a)] (c₀ : code a₀) (p : trunc k (a₀ = a)) : code a :=
begin
  hinduction p with p,
  exact transport code p c₀
end

@[hott] def truncated_encode_decode_method {k : ℕ₋₂} {A : Type _} (a₀ a : A) (code : A → Type _)
  [Πa, is_trunc k (code a)] (c₀ : code a₀)
  (decode : Π(a : A) (c : code a), trunc k (a₀ = a))
  (encode_decode : Π(a : A) (c : code a), truncated_encode c₀ (decode a c) = c)
  (decode_encode : decode a₀ c₀ = tr idp) : trunc k (a₀ = a) ≃ code a :=
begin
  fapply equiv.MK,
  { exact truncated_encode c₀},
  { apply decode},
  { intro c, apply encode_decode},
  { intro p, hinduction p with p, induction p, exact decode_encode},
end

end eq

/- some consequences for properties about functions (surjectivity etc.) -/
namespace function
variables {A : Type _} {B : Type _}
@[hott, instance] def is_surjective_of_is_equiv (f : A → B) [H : is_equiv f] : is_surjective f :=
λb, begin dsimp [image, image'], apply center end

@[hott] def is_equiv_equiv_is_embedding_times_is_surjective (f : A → B)
  : is_equiv f ≃ (is_embedding f × is_surjective f) :=
equiv_of_is_prop
  (λH, (by resetI; apply_instance, by resetI; apply_instance))
  (λP, prod.rec_on P (λH₁ H₂, by exactI is_equiv_of_is_surjective_of_is_embedding _))

/-
  @[hott] theorem 8.8.1:
  A function is an equivalence if it's an embedding and it's action on sets is an surjection
-/
@[hott] def is_equiv_of_is_surjective_trunc_of_is_embedding {A B : Type _} (f : A → B)
  [H : is_embedding f] [H' : is_surjective (trunc_functor 0 f)] : is_equiv f :=
have is_surjective f,
begin
  intro b,
  hinduction H' (tr b) with x p, hinduction p with a p,
  hinduction a with a, dsimp [trunc_functor] at p,
  hinduction ((tr_eq_tr_equiv _ _ _).to_fun p) with x q,
  exact image.mk a q
end,
by exactI is_equiv_of_is_surjective_of_is_embedding f

/-
  Corollary 8.8.2:
  A function f is an equivalence if Ωf and trunc_functor 0 f are equivalences
-/
@[hott] def is_equiv_of_is_equiv_ap1_of_is_equiv_trunc {A B : Type _} (f : A → B)
  [H : Πa, is_equiv (ap1 (pmap_of_map f a))] [H' : is_equiv (trunc_functor 0 f)] :
  is_equiv f :=
have is_embedding f,
begin
  intros a a',
  apply is_equiv_of_imp_is_equiv,
  intro p,
  have q := ap (@tr 0 _) p,
  have r := @eq_of_fn_eq_fn' _ _ (trunc_functor 0 f) _ (tr a) (tr a') q,
  hinduction (tr_eq_tr_equiv _ _ _).to_fun r with x s,
  induction s,
  apply is_equiv.homotopy_closed (ap1 (pmap_of_map f a)),
  intro p, apply idp_con
end,
by exactI is_equiv_of_is_surjective_trunc_of_is_embedding f

-- Whitehead's principle itself is in homotopy.homotopy_group, since it needs the @[hott] def of
-- a homotopy group.

end function
end hott


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module analysis.inner_product_space.euclidean_dist
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.Calculus
import Mathbin.Analysis.InnerProductSpace.PiL2

/-!
# Euclidean distance on a finite dimensional space

When we define a smooth bump function on a normed space, it is useful to have a smooth distance on
the space. Since the default distance is not guaranteed to be smooth, we define `to_euclidean` to be
an equivalence between a finite dimensional normed space and the standard Euclidean space of the
same dimension. Then we define `euclidean.dist x y = dist (to_euclidean x) (to_euclidean y)` and
provide some definitions (`euclidean.ball`, `euclidean.closed_ball`) and simple lemmas about this
distance. This way we hide the usage of `to_euclidean` behind an API.
-/

open Topology

open Set

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]

noncomputable section

/-- If `E` is a finite dimensional space over `ℝ`, then `to_euclidean` is a continuous `ℝ`-linear
equivalence between `E` and the Euclidean space of the same dimension. -/
def toEuclidean : E ≃L[ℝ] EuclideanSpace ℝ (Fin <| FiniteDimensional.finrank ℝ E) :=
  ContinuousLinearEquiv.ofFinrankEq finrank_euclideanSpace_fin.symm
#align to_euclidean toEuclidean

namespace Euclidean

/-- If `x` and `y` are two points in a finite dimensional space over `ℝ`, then `euclidean.dist x y`
is the distance between these points in the metric defined by some inner product space structure on
`E`. -/
def dist (x y : E) : ℝ :=
  dist (toEuclidean x) (toEuclidean y)
#align euclidean.dist Euclidean.dist

/-- Closed ball w.r.t. the euclidean distance. -/
def closedBall (x : E) (r : ℝ) : Set E :=
  { y | dist y x ≤ r }
#align euclidean.closed_ball Euclidean.closedBall

/-- Open ball w.r.t. the euclidean distance. -/
def ball (x : E) (r : ℝ) : Set E :=
  { y | dist y x < r }
#align euclidean.ball Euclidean.ball

theorem ball_eq_preimage (x : E) (r : ℝ) :
    ball x r = toEuclidean ⁻¹' Metric.ball (toEuclidean x) r :=
  rfl
#align euclidean.ball_eq_preimage Euclidean.ball_eq_preimage

theorem closedBall_eq_preimage (x : E) (r : ℝ) :
    closedBall x r = toEuclidean ⁻¹' Metric.closedBall (toEuclidean x) r :=
  rfl
#align euclidean.closed_ball_eq_preimage Euclidean.closedBall_eq_preimage

theorem ball_subset_closedBall {x : E} {r : ℝ} : ball x r ⊆ closedBall x r := fun y (hy : _ < _) =>
  le_of_lt hy
#align euclidean.ball_subset_closed_ball Euclidean.ball_subset_closedBall

theorem isOpen_ball {x : E} {r : ℝ} : IsOpen (ball x r) :=
  Metric.isOpen_ball.Preimage toEuclidean.Continuous
#align euclidean.is_open_ball Euclidean.isOpen_ball

theorem mem_ball_self {x : E} {r : ℝ} (hr : 0 < r) : x ∈ ball x r :=
  Metric.mem_ball_self hr
#align euclidean.mem_ball_self Euclidean.mem_ball_self

theorem closedBall_eq_image (x : E) (r : ℝ) :
    closedBall x r = toEuclidean.symm '' Metric.closedBall (toEuclidean x) r := by
  rw [to_euclidean.image_symm_eq_preimage, closed_ball_eq_preimage]
#align euclidean.closed_ball_eq_image Euclidean.closedBall_eq_image

theorem isCompact_closedBall {x : E} {r : ℝ} : IsCompact (closedBall x r) :=
  by
  rw [closed_ball_eq_image]
  exact (is_compact_closed_ball _ _).image to_euclidean.symm.continuous
#align euclidean.is_compact_closed_ball Euclidean.isCompact_closedBall

theorem isClosed_closedBall {x : E} {r : ℝ} : IsClosed (closedBall x r) :=
  isCompact_closedBall.IsClosed
#align euclidean.is_closed_closed_ball Euclidean.isClosed_closedBall

theorem closure_ball (x : E) {r : ℝ} (h : r ≠ 0) : closure (ball x r) = closedBall x r := by
  rw [ball_eq_preimage, ← to_euclidean.preimage_closure, closure_ball (toEuclidean x) h,
    closed_ball_eq_preimage]
#align euclidean.closure_ball Euclidean.closure_ball

theorem exists_pos_lt_subset_ball {R : ℝ} {s : Set E} {x : E} (hR : 0 < R) (hs : IsClosed s)
    (h : s ⊆ ball x R) : ∃ r ∈ Ioo 0 R, s ⊆ ball x r :=
  by
  rw [ball_eq_preimage, ← image_subset_iff] at h
  rcases exists_pos_lt_subset_ball hR (to_euclidean.is_closed_image.2 hs) h with ⟨r, hr, hsr⟩
  exact ⟨r, hr, image_subset_iff.1 hsr⟩
#align euclidean.exists_pos_lt_subset_ball Euclidean.exists_pos_lt_subset_ball

theorem nhds_basis_closedBall {x : E} : (𝓝 x).HasBasis (fun r : ℝ => 0 < r) (closedBall x) :=
  by
  rw [to_euclidean.to_homeomorph.nhds_eq_comap]
  exact metric.nhds_basis_closed_ball.comap _
#align euclidean.nhds_basis_closed_ball Euclidean.nhds_basis_closedBall

theorem closedBall_mem_nhds {x : E} {r : ℝ} (hr : 0 < r) : closedBall x r ∈ 𝓝 x :=
  nhds_basis_closedBall.mem_of_mem hr
#align euclidean.closed_ball_mem_nhds Euclidean.closedBall_mem_nhds

theorem nhds_basis_ball {x : E} : (𝓝 x).HasBasis (fun r : ℝ => 0 < r) (ball x) :=
  by
  rw [to_euclidean.to_homeomorph.nhds_eq_comap]
  exact metric.nhds_basis_ball.comap _
#align euclidean.nhds_basis_ball Euclidean.nhds_basis_ball

theorem ball_mem_nhds {x : E} {r : ℝ} (hr : 0 < r) : ball x r ∈ 𝓝 x :=
  nhds_basis_ball.mem_of_mem hr
#align euclidean.ball_mem_nhds Euclidean.ball_mem_nhds

end Euclidean

variable {F : Type _} [NormedAddCommGroup F] [NormedSpace ℝ F] {f g : F → E} {n : ℕ∞}

theorem ContDiff.euclidean_dist (hf : ContDiff ℝ n f) (hg : ContDiff ℝ n g) (h : ∀ x, f x ≠ g x) :
    ContDiff ℝ n fun x => Euclidean.dist (f x) (g x) :=
  by
  simp only [Euclidean.dist]
  apply @ContDiff.dist ℝ
  exacts[(@toEuclidean E _ _ _).ContDiff.comp hf, (@toEuclidean E _ _ _).ContDiff.comp hg, fun x =>
    to_euclidean.injective.ne (h x)]
#align cont_diff.euclidean_dist ContDiff.euclidean_dist


example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  cases h with hp hqr,
  show (p ∧ q) ∨ (p ∧ r),
  cases hqr with hq hr,
    have hpq : p ∧ q,
      from and.intro hp hq,
    left, exact hpq,
    have hpr : p ∧ r,
      from and.intro hp hr,
    right, exact hpr
end


/-
 These are my solutions to the Codewars katas in Lean (level 8kyu)
-/

import tactic
import data.nat.prime
import logic.function.basic

namespace kyu.multiply

 /-
  You are asked to figure out why this definition
  does not execute properly.

  -- def multiply (a, b ∈ ℕ) ∈ ℕ := a × b
 -/

 -- 01
 def multiply (a b : ℕ) := a * b

end kyu.multiply

namespace kyu.kata
 /-
  You are asked to prove the following
   ∀ (n : ℕ), 1 = 2 * n -> false
 -/

 -- 02
 lemma kata : ∀ (n : ℕ), 1 = 2 * n -> false :=
 begin
   refine forall_not_of_not_exists _,
   exact of_to_bool_ff rfl
 end
end kyu.kata

namespace kyu.not_not_not
 /-
  You are asked to prove that we have
   ¬¬¬P → ¬P
 -/

 -- 03
 theorem not_not_not
   (P : Prop) :
   ¬ ¬ ¬ P → ¬ P :=
 begin
   intros h hy,
   apply h,
   intros ye,
   apply ye,
   assumption
 end
end kyu.not_not_not

namespace kyu.bad_theorem
 /-
  You are asked to disprove the following proposition,
  i.e., that symmetry implies transitivity which in turn implies reflexivity
 -/
 def bad_theorem : Prop :=
   ∀ (α : Type) (r : α → α → Prop), symmetric r → transitive r → reflexive r

 --04
 theorem correct_version : ¬ bad_theorem :=
 begin
   simp [bad_theorem],
   refine ⟨_,_,_,_,_⟩,
    { exact Prop },
    { exact empty_relation },
    all_goals { simp [symmetric,transitive,reflexive,empty_relation] }
 end
end kyu.bad_theorem

namespace kyu.fermat_was_wrong
 /-
  You are asked to disprove the following conjecture that Fermat made,
  i.e., that we have 2^2^n + 1 is always prime
 -/

 -- 05
 theorem fermat_was_wrong : ¬ (∀ n : ℕ, nat.prime (2^2^n + 1)) :=
 by { refine not_forall_of_exists_not _, use 5, norm_num }
end kyu.fermat_was_wrong

namespace kyu.hello_world
 /-
  Here you are given some definitions and theorems on natural numbers and are asked to complete them
 -/

 -- this defines a natural number
 inductive mynat : Type
 | zero : mynat
 | succ : mynat → mynat

 open mynat

 -- this defines the number two
 def two : mynat := succ (succ zero)

 -- this defines the predecessor
 def pred : mynat → mynat :=
  λ n, mynat.cases_on n
    zero
    (λ n', n')

 -- this defines addition
 def add : mynat → mynat → mynat :=
  λ n m, mynat.rec_on m
    n
    (λ m' add_n_m', succ (add_n_m'))

 inductive myeq : Π {α : Type}, α → α → Prop
 | myrefl : ∀ {α : Type} {a : α}, myeq a a

 open myeq

 def this_is_free : myeq (succ zero) (succ zero) :=
  myrefl

 theorem this_is_almost_free :
  myeq (add two zero) (add zero two) :=
 begin
  apply myrefl
 end

 --06.1
 theorem cong : ∀ (f : mynat → mynat) (n m : mynat),
  myeq n m → myeq (f n) (f m) :=
 begin
  intros f n m hnm,
  cases hnm,
  exact myrefl
 end

 --06.2
 theorem add_n_zero : ∀ n : mynat, myeq (add n zero) n :=
 begin
   intro n,
  exact myrefl
 end

 --06.3
 theorem add_zero_n : ∀ n : mynat, myeq (add zero n) n :=
 begin

  intros n,
  induction n,
  case zero : {
    exact myrefl
  },
  case succ : n' ihn' {
    show myeq (succ (add zero n')) (succ n'),
    apply cong,
    exact ihn'
  }
 end

end kyu.hello_world

namespace kyu.inverse_function
 /-
  You are asked to prove that any inverse (left and right) of an involutive function is itself
 -/
 open function

 --07.1
 lemma left {α: Type} (f g : α → α)
  (hf : involutive f) (hfg : left_inverse g f) : f = g :=
 by { ext, exact (eq.symm (hfg (f x))).trans (congr_arg g (hf x)) }

 --07.2
 lemma right {α: Type} (f g : α → α)
  (hf : involutive f) (hfg : right_inverse g f) : f = g :=
 by { ext, exact (congr_arg f (eq.symm (hfg x))).trans (hf (g x)) }
end kyu.inverse_function


/- Quantifier identities -/

variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : (∃ x : α, r) → r :=
  fun h : ∃ x, r =>
    let (Exists.intro w hw) := h
      show r from hw

example (a : α) : r → (∃ x : α, r) :=
  fun h : r =>
    Exists.intro a h

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
  Iff.intro
    (fun h : ∃ x, p x ∧ r =>
      let (Exists.intro w (And.intro hp hr)) := h
      show (∃ x, p x) ∧ r from And.intro (Exists.intro w hp) hr)
    (fun h : (∃ x, p x) ∧ r =>
      let (Exists.intro w hw) := h.left
      show ∃ x, p x ∧ r from Exists.intro w (And.intro hw h.right))

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
  Iff.intro
    (fun h : ∃ x, p x ∨ q x =>
      let (Exists.intro w hw) := h
      Or.elim hw
        (fun hp : p w => show (∃ x, p x) ∨ (∃ x, q x) from Or.inl (Exists.intro w hp))
        (fun hq : q w => show (∃ x, p x) ∨ (∃ x, q x) from Or.inr (Exists.intro w hq)))
    (fun h : (∃ x, p x) ∨ (∃ x, q x) =>
      Or.elim h
        (fun hp : ∃ x, p x =>
          let (Exists.intro w hw) := hp
          show ∃ x, p x ∨ q x from Exists.intro w (Or.inl hw))
        (fun hq : ∃ x, q x =>
          let (Exists.intro w hw) := hq
          show ∃ x, p x ∨ q x from Exists.intro w (Or.inr hw)))

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) :=
  Iff.intro
    (fun h : ∀ x, p x =>
      Classical.byCases
        (fun he : ∃ x, ¬ p x =>
          let (Exists.intro w hnp) := he
          absurd (h w) hnp)
        (fun hne : ¬ (∃ x, ¬ p x) => hne))
    (fun h : ¬ (∃ x, ¬ p x) =>
      show ∀ x, p x from
        fun x =>
          Classical.byCases
          (fun hp : p x => hp)
          (fun hnp : ¬ p x =>
            have he : ∃ x, ¬ p x := Exists.intro x hnp
            absurd he h))

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) :=
  Iff.intro
    (fun h : ∃ x, p x =>
      let (Exists.intro w hp) := h
      Classical.byCases
        (fun hf : ∀ x, ¬ p x =>
          absurd hp (hf w) )
        (fun hnf : ¬ (∀ x, ¬ p x) => hnf))
    (fun h : ¬ (∀ x, ¬ p x) =>
      Classical.byContradiction
        (fun hne : ¬ (∃ x, p x) =>
          have h1 : ∀ x, ¬ p x :=
            fun w =>
              fun hp : p w =>
                have he : ∃ x, p x := Exists.intro w hp
                show False from hne he
          show False from h h1))

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) :=
  Iff.intro
    (fun h : ¬ ∃ x, p x =>
      show ∀ x, ¬ p x from
        (fun x =>
          fun hp : p x =>
            show False from h (Exists.intro x hp)))
    (fun h : ∀ x, ¬ p x =>
      Classical.byCases
        (fun he : ∃ x, p x =>
          let (Exists.intro w hp) := he
          absurd hp (h w))
        (fun hne : ¬ ∃ x, p x => hne))

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
  Iff.intro
    (fun h : ¬ ∀ x, p x =>
      Classical.byContradiction
        (fun hne : ¬ ∃ x, ¬ p x =>
          have hn : ∀ x, p x :=
            fun x =>
              Classical.byContradiction
                (fun hnp : ¬ p x =>
                  have he : ∃ x, ¬ p x := Exists.intro x hnp
                  show False from hne he)
          show False from h hn))
    (fun h : ∃ x, ¬ p x =>
      let (Exists.intro w hnp) := h
      Classical.byCases
        (fun hf : ∀ x, p x => absurd (hf w) hnp)
        (fun hnf : ¬ ∀ x, p x => hnf))

example : (∀ x, p x → r) ↔ (∃ x, p x) → r :=
  Iff.intro
    (fun h : ∀ x, p x → r =>
      fun he : ∃ x, p x =>
        let (Exists.intro w hp) := he
        show r from (h w) hp)
    (fun h : (∃ x, p x) → r =>
      show ∀ x, p x → r from
        fun x =>
          fun hp : p x => show r from h (Exists.intro x hp))

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
  Iff.intro
    (fun h : ∃ x, p x → r =>
      let (Exists.intro w hpr) := h
      fun hf : ∀ x, p x =>
        show r from hpr (hf w))
    (fun h : (∀ x, p x) → r =>
      show ∃ x, p x → r from
        Classical.byCases
          (fun hf : ∀ x, p x =>
            have hp : p a := hf a
            Exists.intro a (fun hp => (h hf)))
          (fun hnf : ¬ ∀ x, p x =>
            Classical.byContradiction
              (fun hne : ¬ ∃ x, p x → r =>
                have hf : ∀ x, p x :=
                  fun x =>
                    Classical.byContradiction
                      (fun hnp : ¬ p x =>
                        have he : ∃ x, p x → r := Exists.intro x (fun hp => absurd hp hnp)
                        show False from hne he)
                      show False from hnf hf)))

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
  Iff.intro
    (fun h : ∃ x, r → p x =>
      let (Exists.intro w hrpw) := h
      fun hr : r =>
        Exists.intro w (hrpw hr))
    (fun h : r → ∃ x, p x =>
      Classical.byCases
        (fun hr : r =>
          let (Exists.intro w hw) := h hr
          Exists.intro w (fun hr => hw))
        (fun hnr : ¬ r =>
          Exists.intro a (fun hr : r => absurd hr hnr)))

/- Equivalences -/

variable (α : Type) (p q : α → Prop)

example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
  Iff.intro
    (fun h : ∀ x, p x ∧ q x =>
      show (∀ x, p x) ∧ (∀ x, q x) from And.intro
        (fun x => (h x).left)
        (fun x => (h x).right))
    (fun h : (∀ x, p x) ∧ (∀ x, q x) =>
      fun x => show p x ∧ q x from And.intro (h.left x) (h.right x))

example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) :=
  fun h : ∀ x, p x → q x =>
    fun hfp : ∀ x, p x =>
      show ∀ x, q x from
        fun x => show q x from (h x) (hfp x)

example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x :=
  fun h : (∀ x, p x) ∨ (∀ x, q x) =>
    fun x => Or.elim h
      (fun hfp : ∀ x, p x => show p x ∨ q x from Or.inl (hfp x))
      (fun hfq : ∀ x, q x => show p x ∨ q x from Or.inr (hfq x))

/- Component outside of Universal Quantifier -/

variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : α → ((∀ x : α, r) ↔ r) :=
  fun a : α =>
    Iff.intro
      (fun h : ∀ x, r =>
        show r from h a)
      (fun h : r => show ∀ x, r from
        fun x => h)

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
  Iff.intro
    (fun h : ∀ x, p x ∨ r =>
      Classical.byCases
        (fun hr : r => show (∀ x, p x) ∨ r from Or.inr hr)
        (fun hnr : ¬r => show (∀ x, p x) ∨ r from Or.inl
          fun x => Or.elim (h x)
            (fun hp : p x => hp)
            (fun hr : r => absurd hr hnr)))
    (fun h : (∀ x, p x) ∨ r =>
      fun x =>
        Or.elim h
          (fun hf : ∀ x, p x => show p x ∨ r from Or.inl (hf x))
          (fun hr : r => show p x ∨ r from Or.inr hr))

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
  Iff.intro
    (fun h : ∀ x, r → p x =>
      fun hr : r =>
        fun x => (h x) hr)
    (fun h : r → ∀ x, p x =>
      fun x =>
        fun hr : r => (h hr) x)

/- Barber Paradox -/

variable (men : Type) (barber : men)
variable  (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False :=
  Classical.byCases
    (fun hb : shaves barber barber =>
      show False from ((Iff.mp (h barber)) hb) hb)
    (fun hnb : ¬ shaves barber barber =>
      show False from hnb ((Iff.mpr (h barber)) hnb))

/- Assertions -/

def even (n : Nat) : Prop :=
  ∃ x, n = 2 * x

def div (a b : Nat) : Prop :=
  ∃ x, b = a * x

def prime (n : Nat) : Prop :=
  ¬ ∃ p, p > 1 → div p n

def infinitely_many_primes : Prop :=
  ∀ n, ∃ p, prime p → n < p

def Fermat_prime (n : Nat) : Prop :=
  prime (Nat.pow 2 (Nat.pow 2 n))

def infinitely_many_Fermat_primes : Prop :=
  ∀ n, ∃ p, Fermat_prime p → n < p

def goldbach_conjecture : Prop :=
  ∀ n, even n → n > 2 → (∃ p q, prime p → prime q → n = p + q)

def Goldbach's_weak_conjecture : Prop :=
  ∀ n, ¬ even n → n > 5 → (∃ p q r, prime p → prime q → prime r → n = p + q + r)

def Fermat's_last_theorem {n a b c : Nat}: Prop :=
  ∀ n, n > 2 → ¬ ∃ a b c, (Nat.pow a n) + (Nat.pow b n) = (Nat.pow c n)

/- Divisibility -/

example : ∀ x, div x x :=
  fun x =>
    have h : x = x * 1 := by rw [Nat.mul_one]
    Exists.intro 1 h

example (hab : div a b) (hba : div b a) (ha : a > 0) (hb : b > 0) : a = b :=
  match hab, hba with
  | (Exists.intro m hm), (Exists.intro n hn) =>
      have : a = a * (m * n) := calc
        a = b * n := by rw [hn]
        _ = a * (m * n) := by simp [hm, Nat.mul_assoc]
      have : a * 1 = a * (m * n) := (Nat.mul_one a).symm ▸ this
      have : 1 = m * n := (Nat.eq_of_mul_eq_mul_left ha this)
      sorry

example (hab : div a b) (hbc : div b c) : div a c :=
  match hab, hbc with
  | (Exists.intro m hm), (Exists.intro n hn) =>
      have hac : c = a * (m * n) := calc
        c = b * n := by rw [hn]
        _ = (a * m) * n := by rw [hm]
        _ = a * (m * n) := by simp [Nat.mul_assoc]
      show div a c from Exists.intro (m * n) hac


/-
Copyright (c) 2022 Pierre-Alexandre Bazin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Pierre-Alexandre Bazin
-/
import algebra.module.dedekind_domain
import linear_algebra.free_module.pid
import algebra.module.projective
import algebra.category.Module.biproducts

/-!
# Structure of finitely generated modules over a PID

## Main statements

* `module.equiv_direct_sum_of_is_torsion` : A finitely generated torsion module over a PID is
  isomorphic to a direct sum of some `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.
* `module.equiv_free_prod_direct_sum` : A finitely generated module over a PID is isomorphic to the
  product of a free module (its torsion free part) and a direct sum of the form above (its torsion
  submodule).

## Notation

* `R` is a PID and `M` is a (finitely generated for main statements) `R`-module, with additional
  torsion hypotheses in the intermediate lemmas.
* `N` is a `R`-module lying over a higher type universe than `R`. This assumption is needed on the
  final statement for technical reasons.
* `p` is an irreducible element of `R` or a tuple of these.

## Implementation details

We first prove (`submodule.is_internal_prime_power_torsion_of_pid`) that a finitely generated
torsion module is the internal direct sum of its `p i ^ e i`-torsion submodules for some
(finitely many) prime powers `p i ^ e i`. This is proved in more generality for a Dedekind domain
at `submodule.is_internal_prime_power_torsion`.

Then we treat the case of a `p ^ ∞`-torsion module (that is, a module where all elements are
cancelled by scalar multiplication by some power of `p`) and apply it to the `p i ^ e i`-torsion
submodules (that are `p i ^ ∞`-torsion) to get the result for torsion modules.

Then we get the general result using that a torsion free module is free (which has been proved at
`module.free_of_finite_type_torsion_free'` at `linear_algebra/free_module/pid.lean`.)

## Tags

Finitely generated module, principal ideal domain, classification, structure theorem
-/

universes u v
open_locale big_operators

variables {R : Type u} [comm_ring R] [is_domain R] [is_principal_ideal_ring R]
variables {M : Type v} [add_comm_group M] [module R M]
variables {N : Type (max u v)} [add_comm_group N] [module R N]

open_locale direct_sum
open submodule

/--A finitely generated torsion module over a PID is an internal direct sum of its
`p i ^ e i`-torsion submodules for some primes `p i` and numbers `e i`.-/
theorem submodule.is_internal_prime_power_torsion_of_pid
  [module.finite R M] (hM : module.is_torsion R M) :
  ∃ (ι : Type u) [fintype ι] [decidable_eq ι] (p : ι → R) (h : ∀ i, irreducible $ p i) (e : ι → ℕ),
  by exactI direct_sum.is_internal (λ i, torsion_by R M $ p i ^ e i) :=
begin
  obtain ⟨P, dec, hP, e, this⟩ := is_internal_prime_power_torsion hM,
  refine ⟨P, infer_instance, dec, λ p, is_principal.generator (p : ideal R), _, e, _⟩,
  { rintro ⟨p, hp⟩,
    haveI := ideal.is_prime_of_prime (hP p hp),
    exact (is_principal.prime_generator_of_is_prime p (hP p hp).ne_zero).irreducible },
  { convert this, ext p : 1,
    rw [← torsion_by_span_singleton_eq, ideal.submodule_span_eq, ← ideal.span_singleton_pow,
      ideal.span_singleton_generator] }
end

namespace module
section p_torsion
variables {p : R} (hp : irreducible p) (hM : module.is_torsion' M (submonoid.powers p))
variables [dec : Π x : M, decidable (x = 0)]

open ideal submodule.is_principal
include dec

include hp hM
lemma _root_.ideal.torsion_of_eq_span_pow_p_order (x : M) :
  torsion_of R M x = span {p ^ p_order hM x} :=
begin
  dunfold p_order,
  rw [← (torsion_of R M x).span_singleton_generator, ideal.span_singleton_eq_span_singleton,
    ← associates.mk_eq_mk_iff_associated, associates.mk_pow],
  have prop : (λ n : ℕ, p ^ n • x = 0) =
    λ n : ℕ, (associates.mk $ generator $ torsion_of R M x) ∣ associates.mk p ^ n,
  { ext n, rw [← associates.mk_pow, associates.mk_dvd_mk, ← mem_iff_generator_dvd], refl },
  have := (is_torsion'_powers_iff p).mp hM x, rw prop at this,
  classical,
  convert associates.eq_pow_find_of_dvd_irreducible_pow ((associates.irreducible_mk p).mpr hp)
    this.some_spec,
end

open submodule.quotient

lemma exists_smul_eq_zero_and_mk_eq {z : M} (hz : module.is_torsion_by R M (p ^ p_order hM z))
  {k : ℕ} (f : (R ⧸ R ∙ p ^ k) →ₗ[R] M ⧸ R ∙ z) :
  ∃ x : M, p ^ k • x = 0 ∧ submodule.quotient.mk x = f 1 :=
begin
  have f1 := mk_surjective (R ∙ z) (f 1),
  have : p ^ k • f1.some ∈ R ∙ z,
  { rw [← quotient.mk_eq_zero, mk_smul, f1.some_spec, ← f.map_smul],
    convert f.map_zero, change _ • submodule.quotient.mk _ = _,
    rw [← mk_smul, quotient.mk_eq_zero, algebra.id.smul_eq_mul, mul_one],
    exact submodule.mem_span_singleton_self _ },
  obtain ⟨a, ha⟩ := p_pow_smul_lift hp hM hz this,
  refine ⟨f1.some - a • z, by rw [smul_sub, sub_eq_zero, ha], _⟩,
  rw [mk_sub, mk_smul, (quotient.mk_eq_zero _).mpr $ submodule.mem_span_singleton_self _,
    smul_zero, sub_zero, f1.some_spec]
end

open finset multiset
omit dec hM

/--A finitely generated `p ^ ∞`-torsion module over a PID is isomorphic to a direct sum of some
  `R ⧸ R ∙ (p ^ e i)` for some `e i`.-/
theorem torsion_by_prime_power_decomposition (hN : module.is_torsion' N (submonoid.powers p))
  [h' : module.finite R N] :
  ∃ (d : ℕ) (k : fin d → ℕ), nonempty $ N ≃ₗ[R] ⨁ (i : fin d), R ⧸ R ∙ (p ^ (k i : ℕ)) :=
begin
  obtain ⟨d, s, hs⟩ := @module.finite.exists_fin _ _ _ _ _ h', use d, clear h',
  unfreezingI { induction d with d IH generalizing N },
  { use λ i, fin_zero_elim i,
    rw [set.range_eq_empty, submodule.span_empty] at hs,
    haveI : unique N := ⟨⟨0⟩, λ x, by { rw [← mem_bot _, hs], trivial }⟩,
    exact ⟨0⟩ },
  { haveI : Π x : N, decidable (x = 0), classical, apply_instance,
    obtain ⟨j, hj⟩ := exists_is_torsion_by hN d.succ d.succ_ne_zero s hs,
    let s' : fin d → N ⧸ R ∙ s j := submodule.quotient.mk ∘ s ∘ j.succ_above,
    obtain ⟨k, ⟨f⟩⟩ := IH _ s' _; clear IH,
    { have : ∀ i : fin d, ∃ x : N,
        p ^ k i • x = 0 ∧ f (submodule.quotient.mk x) = direct_sum.lof R _ _ i 1,
      { intro i,
        let fi := f.symm.to_linear_map.comp (direct_sum.lof _ _ _ i),
        obtain ⟨x, h0, h1⟩ := exists_smul_eq_zero_and_mk_eq hp hN hj fi, refine ⟨x, h0, _⟩, rw h1,
        simp only [linear_map.coe_comp, f.symm.coe_to_linear_map, f.apply_symm_apply] },
      refine ⟨_, ⟨(((
        @lequiv_prod_of_right_split_exact _ _ _ _ _ _ _ _ _ _ _ _
          ((f.trans ulift.module_equiv.{u u v}.symm).to_linear_map.comp $ mkq _)
          ((direct_sum.to_module _ _ _ $ λ i, (liftq_span_singleton.{u u} (p ^ k i)
            (linear_map.to_span_singleton _ _ _) (this i).some_spec.left : R ⧸ _ →ₗ[R] _)).comp
            ulift.module_equiv.to_linear_map)
          (R ∙ s j).injective_subtype _ _).symm.trans $
        ((quot_torsion_of_equiv_span_singleton _ _ _).symm.trans $
          quot_equiv_of_eq _ _ $ ideal.torsion_of_eq_span_pow_p_order hp hN _).prod $
          ulift.module_equiv).trans $
        (@direct_sum.lequiv_prod_direct_sum R _ _ _
          (λ i, R ⧸ R ∙ p ^ @option.rec _ (λ _, ℕ) (p_order hN $ s j) k i) _ _).symm).trans $
        direct_sum.lequiv_congr_left R (fin_succ_equiv d).symm⟩⟩,
      { rw [range_subtype, linear_equiv.to_linear_map_eq_coe, linear_equiv.ker_comp, ker_mkq] },
      { rw [linear_equiv.to_linear_map_eq_coe, ← f.comp_coe, linear_map.comp_assoc,
          linear_map.comp_assoc, ← linear_equiv.to_linear_map_eq_coe,
          linear_equiv.to_linear_map_symm_comp_eq, linear_map.comp_id,
          ← linear_map.comp_assoc, ← linear_map.comp_assoc],
        suffices : (f.to_linear_map.comp (R ∙ s j).mkq).comp _ = linear_map.id,
        { rw [← f.to_linear_map_eq_coe, this, linear_map.id_comp] },
        ext i : 3,
        simp only [linear_map.coe_comp, function.comp_app, mkq_apply],
        rw [linear_equiv.coe_to_linear_map, linear_map.id_apply, direct_sum.to_module_lof,
          liftq_span_singleton_apply, linear_map.to_span_singleton_one,
          ideal.quotient.mk_eq_mk, map_one, (this i).some_spec.right] } },
    { exact (mk_surjective _).forall.mpr
      (λ x, ⟨(@hN x).some, by rw [← quotient.mk_smul, (@hN x).some_spec, quotient.mk_zero]⟩) },
    { have hs' := congr_arg (submodule.map $ mkq $ R ∙ s j) hs,
      rw [submodule.map_span, submodule.map_top, range_mkq] at hs', simp only [mkq_apply] at hs',
      simp only [s'], rw [set.range_comp (_ ∘ s), fin.range_succ_above],
      rw [← set.range_comp, ← set.insert_image_compl_eq_range _ j, function.comp_apply,
        (quotient.mk_eq_zero _).mpr (submodule.mem_span_singleton_self _), span_insert_zero] at hs',
      exact hs' } }
end
end p_torsion

/--A finitely generated torsion module over a PID is isomorphic to a direct sum of some
  `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.-/
theorem equiv_direct_sum_of_is_torsion [h' : module.finite R N] (hN : module.is_torsion R N) :
  ∃ (ι : Type u) [fintype ι] (p : ι → R) (h : ∀ i, irreducible $ p i) (e : ι → ℕ),
  nonempty $ N ≃ₗ[R] ⨁ (i : ι), R ⧸ R ∙ (p i ^ e i) :=
begin
  obtain ⟨I, fI, _, p, hp, e, h⟩ := submodule.is_internal_prime_power_torsion_of_pid hN,
  haveI := fI,
  have : ∀ i, ∃ (d : ℕ) (k : fin d → ℕ),
    nonempty $ torsion_by R N (p i ^ e i) ≃ₗ[R] ⨁ j, R ⧸ R ∙ (p i ^ k j),
  { haveI := is_noetherian_of_fg_of_noetherian' (module.finite_def.mp h'),
    haveI := λ i, is_noetherian_submodule' (torsion_by R N $ p i ^ e i),
    exact λ i, torsion_by_prime_power_decomposition (hp i)
      ((is_torsion'_powers_iff $ p i).mpr $ λ x, ⟨e i, smul_torsion_by _ _⟩) },
  classical,
  refine ⟨Σ i, fin (this i).some, infer_instance,
    λ ⟨i, j⟩, p i, λ ⟨i, j⟩, hp i, λ ⟨i, j⟩, (this i).some_spec.some j,
    ⟨(linear_equiv.of_bijective (direct_sum.coe_linear_map _) h).symm.trans $
      (dfinsupp.map_range.linear_equiv $ λ i, (this i).some_spec.some_spec.some).trans $
      (direct_sum.sigma_lcurry_equiv R).symm.trans
      (dfinsupp.map_range.linear_equiv $ λ i, quot_equiv_of_eq _ _ _)⟩⟩,
  cases i with i j, simp only
end

/--**Structure theorem of finitely generated modules over a PID** : A finitely generated
  module over a PID is isomorphic to the product of a free module and a direct sum of some
  `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.-/
theorem equiv_free_prod_direct_sum [h' : module.finite R N] :
  ∃ (n : ℕ) (ι : Type u) [fintype ι] (p : ι → R) (h : ∀ i, irreducible $ p i) (e : ι → ℕ),
  nonempty $ N ≃ₗ[R] (fin n →₀ R) × ⨁ (i : ι), R ⧸ R ∙ (p i ^ e i) :=
begin
  haveI := is_noetherian_of_fg_of_noetherian' (module.finite_def.mp h'),
  haveI := is_noetherian_submodule' (torsion R N),
  haveI := module.finite.of_surjective _ (torsion R N).mkq_surjective,
  obtain ⟨I, fI, p, hp, e, ⟨h⟩⟩ := equiv_direct_sum_of_is_torsion (@torsion_is_torsion R N _ _ _),
  obtain ⟨n, ⟨g⟩⟩ := @module.basis_of_finite_type_torsion_free' R _ _ _ (N ⧸ torsion R N) _ _ _ _,
  haveI : module.projective R (N ⧸ torsion R N) := module.projective_of_basis ⟨g⟩,
  obtain ⟨f, hf⟩ := module.projective_lifting_property _ linear_map.id (torsion R N).mkq_surjective,
  refine ⟨n, I, fI, p, hp, e,
    ⟨(lequiv_prod_of_right_split_exact (torsion R N).injective_subtype _ hf).symm.trans $
      (h.prod g).trans $ linear_equiv.prod_comm R _ _⟩⟩,
  rw [range_subtype, ker_mkq]
end
end module


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module data.enat.basic
! leanprover-community/mathlib commit ceb887ddf3344dab425292e497fa2af91498437c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.SuccPred
import Mathlib.Algebra.CharZero.Lemmas
import Mathlib.Algebra.Order.Sub.WithTop
import Mathlib.Algebra.Order.Ring.WithTop

/-!
# Definition and basic properties of extended natural numbers

In this file we define `ENat` (notation: `ℕ∞`) to be `WithTop ℕ` and prove some basic lemmas
about this type.
-/

/-- Extended natural numbers `ℕ∞ = WithTop ℕ`. -/
def ENat : Type :=
  WithTop ℕ
deriving Zero,
  -- AddCommMonoidWithOne,
  CanonicallyOrderedCommSemiring, Nontrivial,
  LinearOrder, Bot, Top, CanonicallyLinearOrderedAddMonoid, Sub,
  LinearOrderedAddCommMonoidWithTop, WellFoundedRelation, Inhabited
  -- OrderBot, OrderTop, OrderedSub,  SuccOrder, WellFoundedLt, CharZero
#align enat ENat

-- Porting Note: In `Data.Nat.ENatPart` proofs timed out when having
-- the `deriving AddCommMonoidWithOne`, and it seems to work without.

/-- Extended natural numbers `ℕ∞ = WithTop ℕ`. -/
notation "ℕ∞" => ENat

namespace ENat

--Porting note: instances that derive failed to find
instance : OrderBot ℕ∞ := WithTop.orderBot
instance : OrderTop ℕ∞ := WithTop.orderTop
instance : OrderedSub ℕ∞ := inferInstanceAs (OrderedSub (WithTop ℕ))
instance : SuccOrder ℕ∞ := inferInstanceAs (SuccOrder (WithTop ℕ))
instance : WellFoundedLT ℕ∞ := inferInstanceAs (WellFoundedLT (WithTop ℕ))
instance : CharZero ℕ∞ := inferInstanceAs (CharZero (WithTop ℕ))
instance : IsWellOrder ℕ∞ (· < ·) where

variable {m n : ℕ∞}

--Porting note: `simp` and `norm_cast` can prove it
--@[simp, norm_cast]
theorem coe_zero : ((0 : ℕ) : ℕ∞) = 0 :=
  rfl
#align enat.coe_zero ENat.coe_zero

--Porting note: `simp` and `norm_cast` can prove it
--@[simp, norm_cast]
theorem coe_one : ((1 : ℕ) : ℕ∞) = 1 :=
  rfl
#align enat.coe_one ENat.coe_one

--Porting note: `simp` and `norm_cast` can prove it
--@[simp, norm_cast]
theorem coe_add (m n : ℕ) : ↑(m + n) = (m + n : ℕ∞) :=
  rfl
#align enat.coe_add ENat.coe_add

@[simp, norm_cast]
theorem coe_sub (m n : ℕ) : ↑(m - n) = (m - n : ℕ∞) :=
  rfl
#align enat.coe_sub ENat.coe_sub

--Porting note: `simp` and `norm_cast` can prove it
--@[simp, norm_cast]
theorem coe_mul (m n : ℕ) : ↑(m * n) = (m * n : ℕ∞) :=
  WithTop.coe_mul
#align enat.coe_mul ENat.coe_mul

instance canLift : CanLift ℕ∞ ℕ (↑) fun n => n ≠ ⊤ :=
  WithTop.canLift
#align enat.can_lift ENat.canLift

/-- Conversion of `ℕ∞` to `ℕ` sending `∞` to `0`. -/
def toNat : MonoidWithZeroHom ℕ∞ ℕ
    where
  toFun := WithTop.untop' 0
  map_one' := rfl
  map_zero' := rfl
  map_mul' := WithTop.untop'_zero_mul
#align enat.to_nat ENat.toNat

@[simp]
theorem toNat_coe (n : ℕ) : toNat n = n :=
  rfl
#align enat.to_nat_coe ENat.toNat_coe

@[simp]
theorem toNat_top : toNat ⊤ = 0 :=
  rfl
#align enat.to_nat_top ENat.toNat_top

--Porting note: new definition copied from `WithTop`
/-- Recursor for `ENat` using the preferred forms `⊤` and `↑a`. -/
@[elab_as_elim]
def recTopCoe {C : ℕ∞ → Sort _} (h₁ : C ⊤) (h₂ : ∀ a : ℕ, C a) : ∀ n : ℕ∞, C n
| none => h₁
| Option.some a => h₂ a

--Porting note: new theorem copied from `WithTop`
@[simp]
theorem recTopCoe_top {C : ℕ∞ → Sort _} (d : C ⊤) (f : ∀ a : ℕ, C a) :
    @recTopCoe C d f ⊤ = d :=
  rfl

--Porting note: new theorem copied from `WithTop`
@[simp]
theorem recTopCoe_coe {C : ℕ∞ → Sort _} (d : C ⊤) (f : ∀ a : ℕ, C a) (x : ℕ) :
    @recTopCoe C d f ↑x = f x :=
  rfl

--Porting note: new theorem copied from `WithTop`
@[simp]
theorem top_ne_coe (a : ℕ) : ⊤ ≠ (a : ℕ∞) :=
  fun.

--Porting note: new theorem copied from `WithTop`
@[simp]
theorem coe_ne_top (a : ℕ) : (a : ℕ∞) ≠ ⊤ :=
  fun.

--Porting note: new theorem copied from `WithTop`
@[simp]
theorem top_sub_coe (a : ℕ) : (⊤ : ℕ∞) - a = ⊤ :=
  WithTop.top_sub_coe

--Porting note: new theorem copied from `WithTop`
theorem sub_top (a : ℕ∞) : a - ⊤ = 0 :=
  WithTop.sub_top

@[simp]
theorem coe_toNat_eq_self : ENat.toNat (n : ℕ∞) = n ↔ n ≠ ⊤ :=
  ENat.recTopCoe (by simp) (fun _ => by simp [toNat_coe]) n
#align enat.coe_to_nat_eq_self ENat.coe_toNat_eq_self

alias coe_toNat_eq_self ↔ _ coe_toNat
#align enat.coe_to_nat ENat.coe_toNat

theorem coe_toNat_le_self (n : ℕ∞) : ↑(toNat n) ≤ n :=
  ENat.recTopCoe le_top (fun _ => le_rfl) n
#align enat.coe_to_nat_le_self ENat.coe_toNat_le_self

theorem toNat_add {m n : ℕ∞} (hm : m ≠ ⊤) (hn : n ≠ ⊤) : toNat (m + n) = toNat m + toNat n := by
  lift m to ℕ using hm
  lift n to ℕ using hn
  rfl
#align enat.to_nat_add ENat.toNat_add

theorem toNat_sub {n : ℕ∞} (hn : n ≠ ⊤) (m : ℕ∞) : toNat (m - n) = toNat m - toNat n := by
  lift n to ℕ using hn
  induction m using ENat.recTopCoe
  · rw [top_sub_coe, toNat_top, zero_tsub]
  · rw [← coe_sub, toNat_coe, toNat_coe, toNat_coe]
#align enat.to_nat_sub ENat.toNat_sub

theorem toNat_eq_iff {m : ℕ∞} {n : ℕ} (hn : n ≠ 0) : toNat m = n ↔ m = n := by
  induction m using ENat.recTopCoe <;> simp [hn.symm]
#align enat.to_nat_eq_iff ENat.toNat_eq_iff

@[simp]
theorem succ_def (m : ℕ∞) : Order.succ m = m + 1 := by cases m <;> rfl
#align enat.succ_def ENat.succ_def

theorem add_one_le_of_lt (h : m < n) : m + 1 ≤ n :=
  m.succ_def ▸ Order.succ_le_of_lt h
#align enat.add_one_le_of_lt ENat.add_one_le_of_lt

theorem add_one_le_iff (hm : m ≠ ⊤) : m + 1 ≤ n ↔ m < n :=
  m.succ_def ▸ (Order.succ_le_iff_of_not_isMax <| by rwa [isMax_iff_eq_top])
#align enat.add_one_le_iff ENat.add_one_le_iff

theorem one_le_iff_pos : 1 ≤ n ↔ 0 < n :=
  add_one_le_iff WithTop.zero_ne_top
#align enat.one_le_iff_pos ENat.one_le_iff_pos

theorem one_le_iff_ne_zero : 1 ≤ n ↔ n ≠ 0 :=
  one_le_iff_pos.trans pos_iff_ne_zero
#align enat.one_le_iff_ne_zero ENat.one_le_iff_ne_zero

theorem le_of_lt_add_one (h : m < n + 1) : m ≤ n :=
  Order.le_of_lt_succ <| n.succ_def.symm ▸ h
#align enat.le_of_lt_add_one ENat.le_of_lt_add_one

@[elab_as_elim]
theorem nat_induction {P : ℕ∞ → Prop} (a : ℕ∞) (h0 : P 0) (hsuc : ∀ n : ℕ, P n → P n.succ)
    (htop : (∀ n : ℕ, P n) → P ⊤) : P a := by
  have A : ∀ n : ℕ, P n := fun n => Nat.recOn n h0 hsuc
  cases a
  . exact htop A
  . exact A _
#align enat.nat_induction ENat.nat_induction

end ENat


open tactic

lemma ex1 (a b c : nat) : a + 0 = 0 + a ∧ 0 + b = b ∧ c + b = b + c :=
begin
  repeat {any_goals {constructor}},
  show c + b = b + c, { apply add_comm }, -- third goal of three
  show a + 0 = 0 + a, { simp }, -- first of two
  show 0 + b = b,     { rw [zero_add] }
end

/- Same example, but the local context of each goal is different -/
lemma ex3 : (∀ a : nat, a + 0 = 0 + a) ∧ (∀ b : nat, 0 + b = b) ∧ (∀ b c : nat, c + b = b + c) :=
begin
  repeat {any_goals {constructor}}, all_goals {intros},
  show c + b = b + c, { apply add_comm },
  show a + 0 = 0 + a, { simp },
  show 0 + b = b,     { rw [zero_add] }
end

/- Same example, but the local context of each goal is different -/
lemma ex4 : (∀ a : nat, a + 0 = 0 + a) ∧ (∀ b : nat, 0 + b = b) ∧ (∀ b c : nat, c + b = b + c) :=
begin
  repeat {any_goals {constructor}}, all_goals {intros},
  show c + b = _,     { apply add_comm },
  show a + _ = 0 + a, { simp },
  show _ = b,         { rw [zero_add] }
end


import geometry.euclidean.basic
import basic

/-!
# Axiomas de incidencia

En este fichero se enuncian los axiomas de incidencia de la geometría euclídea
plana y se definen entidades y demuestran resultados que dependen de estos axiomas.

## Notaciones

- Se utiliza la notación A ~l para la relación de incidencia entre puntos y rectas

-/

/-- Geometría de incidencia, clase que engloba los axiomas para la relación de
 incidencia. -/
class incidence_geometry (Point Line : Type*) :=
  (lies_on : Point → Line → Prop)
  (infix ` ~ ` : 50 := lies_on)
  (I1 {A B : Point} (h : A ≠ B): ∃! l : Line, A ~ l ∧ B ~ l)  -- unicidad
  (I2 (l : Line) : ∃ A B : Point, A ≠ B ∧ A ~ l ∧ B ~ l)
  (I3 : ∃ A B C : Point, different3 A B C ∧ ¬ ∃ l : Line,  A ~ l ∧ B ~ l ∧ C ~ l)

namespace incidence_geometry

infix ` ~ ` : 50 := lies_on

/-- Conjunto de puntos de una línea. -/
def line_points (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l: Line) := { A : Point | A ~ l }

/-- Conjunto de puntos externos a una línea. -/
def outside_line_points (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l: Line) := { A : Point | ¬ A ~ l }

instance (Point Line : Type*) [incidence_geometry Point Line] : has_coe Line (set Point) := { coe := line_points Point }

lemma line_points_lift_eq (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l : Line) (A B : line_points Point l) : A = B ↔ (↑A : Point) = ↑B :=
begin
  exact subtype.ext_iff
end

lemma line_points_lift_ne (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l : Line) (A B : line_points Point l) : A ≠ B ↔ (↑A : Point) ≠ ↑B :=
begin
  rw [ne.def, line_points_lift_eq],
end

lemma outside_line_points_lift_eq (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l : Line) (A B : outside_line_points Point l) : A = B ↔ (↑A : Point) = ↑B :=
begin
  exact subtype.ext_iff
end

lemma outside_line_points_lift_ne (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l : Line) (A B : outside_line_points Point l) : A ≠ B ↔ (↑A : Point) ≠ ↑B :=
begin
  rw [ne.def, outside_line_points_lift_eq],
end

/-- Proposición que determina si dos puntos están en una línea dada. -/
def points_in_line {Point Line : Type*} [incidence_geometry Point Line] (A B : Point) (l : Line) :=
  A ~ l ∧ B ~ l

/-- Relación de colinearidad. Determina si tres puntos están en una misma línea. -/
def collinear {Point : Type*} (Line: Type*) [incidence_geometry Point Line] (A B C : Point) : Prop :=
  ∃ l : Line, A ~ l ∧ B ~ l ∧ C ~ l

@[simp] lemma collinear_comm {Point : Type*} (Line: Type*) [incidence_geometry Point Line] (A B C : Point) :
  collinear Line A B C ↔ collinear Line B A C :=
begin
  split,
  { intro h, cases h with l h, use l, tauto },
  { intro h, cases h with l h, use l, tauto },
end

@[simp] lemma collinear_comm2 {Point : Type*} (Line: Type*) [incidence_geometry Point Line] (A B C : Point) :
  collinear Line A B C ↔ collinear Line C B A :=
begin
  split,
  { intro h, cases h with l h, use l, tauto },
  { intro h, cases h with l h, use l, tauto },
end

namespace push_neg
lemma non_collinear {Point : Type*} (Line: Type*) [incidence_geometry Point Line] (A B C : Point) :
  ¬ collinear Line A B C ↔  ∀ x : Line, (¬ A ~ x ∨ ¬ B ~ x ∨ ¬ C ~ x)
:= begin
  rw [collinear, push_neg.not_exists_eq],
  split,
  { intros h x,
    specialize h x,
    rw [push_neg.not_and_distrib_eq, push_neg.not_and_distrib_eq] at h,
    exact h },
  { intros h x,
    specialize h x,
    rw [push_neg.not_and_distrib_eq, push_neg.not_and_distrib_eq],
    exact h }
end
end push_neg

/-- Determina si A es un punto común de dos líneas dadas -/
def is_common_point {Point Line : Type*} [incidence_geometry Point Line] (A : Point) (l m : Line) :=
  A ~ l ∧ A ~ m

/-- Determina si dos líneas tienen un punto en común -/
def have_common_point (Point : Type*) {Line : Type*} [incidence_geometry Point Line]
  (l m : Line) :=
  ∃ A : Point, is_common_point A l m

/-- Función que dados dos puntos distintos devuelve la línea que pasa por ellos. -/
noncomputable def line {Point : Type*} (Line : Type*) [incidence_geometry Point Line]
{A B : Point} (h : A ≠ B):
  { l : Line // A ~ l ∧  B ~ l } :=
begin
  let hAB := I1 h,
  rw exists_unique at hAB,
  let P := λ l : Line, A ~ l ∧  B ~ l,
  have hlP : ∃ l : Line, P l, { tauto },
  exact classical.indefinite_description P hlP,
end

/--
Función que dados dos puntos distintos devuelve la línea que pasa por ellos,
 con la propiedad de unicidad.
-/
noncomputable def line_unique {Point : Type*} (Line : Type*) [incidence_geometry Point Line]
{A B : Point} (h : A ≠ B):
  { l : Line // (A ~ l ∧ B ~ l) ∧ ∀ l' : Line, A ~ l' ∧ B ~ l' → l' = l } :=
begin
  let hAB := I1 h,
  rw exists_unique at hAB,
  let P := λ l : Line, (A ~ l ∧  B ~ l) ∧ ∀ l' : Line, A ~ l' ∧ B ~ l' → l' = l,
  have hlP : ∃ l : Line, P l, { tauto },
  exact classical.indefinite_description P hlP,
end

/-- Dos líneas distintas tienen como mucho un punto en común. -/
lemma disctinct_lines_one_common_point {Point Line : Type*} [ig : incidence_geometry Point Line] :
  ∀ l m : Line, l ≠ m → (∃! A : Point, is_common_point A l m) ∨ (¬ have_common_point Point l m) :=
begin
  intros l m,
  contrapose!,
  rintro ⟨not_unique, hlm⟩,
  rw [exists_unique, push_neg.not_exists_eq] at not_unique,
  push_neg at not_unique,
  choose A hA using hlm,
  rcases not_unique A hA with ⟨B, ⟨hB, hAB⟩⟩,
  rw ne_comm at hAB,
  let hABlm := and.intro hA hB,
  have hABlm : (A ~ l ∧ B ~ l) ∧ A ~ m ∧ B ~ m,
  { exact ⟨⟨hA.left,hB.left⟩,⟨hA.right,hB.right⟩⟩ },
  rw ← unique_of_exists_unique (ig.I1 hAB) hABlm.1 hABlm.2,
end

/-- Existen tres líneas distintas que no pasan por ningún punto común. -/
lemma disctinct_lines_not_concurrent {Point Line : Type*} [ig : incidence_geometry Point Line] :
  ∃ l m n: Line, (l ≠ m ∧ l ≠ n ∧ m ≠ n) ∧
  ¬ ∃ P : Point, is_common_point P l m ∧ is_common_point P l n ∧ is_common_point P m n
  :=
begin
  rcases ig.I3 with ⟨A, B, C, ⟨⟨hAB, hAC, hBC⟩, h_noncollinear⟩⟩,
  rw [← collinear, push_neg.non_collinear] at h_noncollinear,
  have AB := line Line hAB,
  have AC := line Line hAC,
  have BC := line Line hBC,
  use [AB, AC, BC],
  have hABAC : AB.val ≠ AC.val,
  { by_contra h,
    specialize h_noncollinear AB.val,
    rcases h_noncollinear with (h1 | h2 | h3),
    { exact h1 AB.property.left },
    { exact h2 AB.property.right },
    { rw h at h3, exact h3 AC.property.right }
  },
  have hABBC : AB.val ≠ BC.val,
  { by_contra h,
    specialize h_noncollinear AB.val,
    rcases h_noncollinear with (h1 | h2 | h3),
    { exact h1 AB.property.left },
    { exact h2 AB.property.right },
    { rw h at h3, exact h3 BC.property.right }},
  have hACBC : AC.val ≠ BC.val,
  { by_contra h,
    specialize h_noncollinear AC.val,
    rcases h_noncollinear with (h1 | h2 | h3),
    { exact h1 AC.property.left },
    { rw h at h2, exact h2 BC.property.left },
    { exact h3 AC.property.right }},
  refine ⟨⟨hABAC, hABBC, hACBC⟩, _⟩,
  by_contra h,
  cases h with P hP,
  repeat {rw is_common_point at hP},
  rcases hP with ⟨⟨hPAB, hPAC⟩, ⟨-, hPBC⟩, -⟩,
  have h : AB.val = AC.val,
  { by_cases hAP : A = P,
    { sorry },
    { let AP := line_unique Line hAP,
      let hAP1 := AP.property.right,
      specialize hAP1 AB.val ⟨AB.property.1, hPAB⟩,
      let hAP2 := AP.property.right,
      specialize hAP2 AC.val ⟨AC.property.1, hPAC⟩,
      rw [hAP1, hAP2],
      },
    },
  exact hABAC h
end

/-- Para cada línea existe un punto externo a ella. -/
lemma line_external_point {Point Line : Type*} [ig : incidence_geometry Point Line] :
  ∀ l : Line, ∃ A : Point, ¬ A ~ l :=
begin
  rcases ig.I3 with ⟨A, B, C, ⟨_, h1⟩⟩,
  by_contra h2,
  push_neg at h1,
  push_neg at h2,
  cases h2 with l hl,
  have hAl: A ~ l, { tauto },
  have hBl: B ~ l, { tauto },
  have hCl: C ~ l, { tauto },
  specialize h1 l hAl hBl,
  exact h1 hCl
end

/-- Para caada punto existe una línea que no pasa por él. -/
lemma point_external_line {Point Line : Type*} [ig : incidence_geometry Point Line]:
  ∀ A: Point, ∃ l: Line, ¬ A ~ l :=
begin
  intro A,
  rcases @disctinct_lines_not_concurrent Point Line ig with ⟨l, m, n, ⟨-, h⟩⟩,
  rw push_neg.not_exists_eq at h,
  specialize h A,
  repeat { rw is_common_point at h },
  repeat { rw push_neg.not_and_distrib_eq at h },
  have h : ¬ A ~ l ∨ ¬ A ~ m ∨ ¬ A ~ n, { tauto },
  rcases h with (h1 | h2 | h3),
  { use l },
  { use m },
  { use n },
end

/-- Para cada punto existen al menos dos líneas que pasan por él. -/
lemma point_has_two_lines {Point Line : Type*} [ig: incidence_geometry Point Line]:
  ∀ A: Point, ∃ l m: Line, l ≠ m ∧ A ~ l ∧ A ~ m :=
begin
  intro P,
  rcases ig.I3 with ⟨A, B, C, ⟨⟨hAB, hAC, hBC⟩, h_noncollinear⟩⟩,
  push_neg at h_noncollinear,
  let AB := line Line hAB,
  by_cases h1 : P ~ AB.val,
  {
    let h2 := h_noncollinear,
    specialize h2 AB AB.property.1 AB.property.2,
    have hCP : C ≠ P, { by_contra h', rw ← h' at h1, tauto },
    let CP := line Line hCP,
    use [AB, CP],
    refine ⟨_, h1, CP.property.right⟩,
    by_contra h3,
    have h3' : AB.val = CP.val, { tauto },
    let hlCP := CP.property,
    rw ← h3' at hlCP,
    tauto,
  },
  {
    -- IDEA: AP y BP pasan por P y deben ser distintas
    -- Ya que si AP = BP entonces A B y P son colineares
    -- y P ~ AB, lo que contradice la que ¬ P ~ AB.
    have hAP : A ≠ P, { sorry },
    have hBP : B ≠ P, { sorry },
    let AP := line Line hAP,
    let BP := line Line hBP,
    have h2 : AP.val ≠ BP.val, { sorry },
    use [AP, BP],
    exact ⟨h2, AP.property.2, BP.property.2⟩ },
end

end incidence_geometry