import analysis.inner_product_space.basic
import data.matrix.notation
import linear_algebra.bilinear_form
import linear_algebra.matrix
import tactic

universes u v
noncomputable theory

namespace lftcm

section exercise1

namespace module

open _root_.module

variables (R M : Type*) [comm_semiring R] [add_comm_monoid M] [module R M]

/- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  Exercise 1: defining modules and submodules
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -/

/- The endomorphisms of an `R`-module `M` are the `R`-linear maps from `M` to `M` are defined as:
`def End := M →ₗ[R] M`
-/

/-- The following line tells Lean we can apply `f : End R M` as if it was a function. -/
instance : has_coe_to_fun (End R M) (λ _, M → M) := ⟨linear_map.to_fun⟩

/-- Endomorphisms inherit the pointwise addition operator from linear maps. -/
instance : add_comm_monoid (End R M) := linear_map.add_comm_monoid

/- Define the identity endomorphism `id`. -/
def End.id : End R M :=
-- sorry
{ to_fun := λ x, x,
  map_add' := λ x y, rfl,
  map_smul' := λ s x, rfl }
-- sorry

/-
Show that the endomorphisms of `M` form a module over `R`.

Hint: we can re-use the scalar multiplication of linear maps using the `refine` tactic:
```
refine { smul := linear_map.has_scalar.smul, .. },
```
This will fill in the `smul` field of the `module` structure with the given value.
The remaining fields become goals that you can fill in yourself.

Hint: Prove the equalities using the module structure on `M`.
If `f` and `g` are linear maps, the `ext` tactic turns the goal `f = g` into `∀ x, f x = g x`.
-/
instance : module R (End R M) :=
begin
-- sorry
  refine { smul := linear_map.has_smul.smul, ..},
  { intros f, ext x, apply one_smul },
  { intros a b f, ext x, apply mul_smul },
  { intros a, ext x, apply smul_zero },
  { intros a f g, ext x, apply smul_add },
  { intros a b f, ext x, apply add_smul },
  { intros f, ext x, apply zero_smul }
  -- or:
  -- refine { smul := linear_map.has_scalar.smul, ..}; intros; ext; simp
  -- sorry
end

variables {R M}

/- Bonus exercise: define the submodule of `End R M` consisting of the scalar multiplications.
That is, `f ∈ homothety R M` iff `f` is of the form `λ (x : M), s • x` for some `s : R`.

Hints:
  * You could specify the carrier subset and show it is closed under the operations.
  * You could instead use library functions: try `submodule.map` or `linear_map.range`.
-/
def homothety : submodule R (End R M) :=
-- sorry
{ carrier := { f | ∃ (s : R), (∀ (x : M), f x = s • x) },
  zero_mem' := ⟨0, by simp⟩,
  add_mem' := λ f g hf hg, begin
    obtain ⟨r, hr⟩ := hf,
    obtain ⟨s, hs⟩ := hg,
    use r + s,
    intro x,
    simp [hr, hs, add_smul]
  end,
  smul_mem' := λ c f hf, begin
    obtain ⟨r, hr⟩ := hf,
    use c * r,
    simp [hr, mul_smul]
  end }

-- or:
def smulₗ (s : R) : End R M :=
{ to_fun := λ x, s • x,
  map_smul' := smul_comm s,
  map_add' := smul_add s }

def to_homothety : R →ₗ[R] End R M :=
{ to_fun := smulₗ,
  map_smul' := by { intros, ext, simp [smulₗ, mul_smul] },
  map_add' := by { intros, ext, simp [smulₗ, add_smul] } }

def homothety' : submodule R (End R M) :=
linear_map.range (to_homothety : R →ₗ[R] End R M)

-- or:
def homothety'' : submodule R (End R M) :=
linear_map.range (algebra.lsmul R M : R →ₐ[R] module.End R M).to_linear_map
-- sorry

end module

end exercise1

section exercise2

namespace matrix
open _root_.matrix

variables {m n R M : Type} [fintype m] [fintype n] [comm_ring R] [add_comm_group M] [module R M]

/- The following line allows us to write `⬝` (`\cdot`) and `ᵀ` (`\^T`) for
matrix multiplication and transpose. -/
open_locale matrix

/- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  Exercise 2: working with matrices
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -/

/-- Prove the following four lemmas, that used to be missing from `mathlib`.

Hints:
  * Look up the definition of `vec_mul` and `mul_vec`.
  * Search the library for useful lemmas about the function used in that definition.
-/
@[simp] lemma add_vec_mul (v w : m → R) (M : matrix m n R) :
  vec_mul (v + w) M = vec_mul v M + vec_mul w M :=
-- sorry
by { ext, apply add_dot_product }
-- sorry

@[simp] lemma smul_vec_mul (x : R) (v : m → R) (M : matrix m n R) :
vec_mul (x • v) M = x • vec_mul v M :=
-- sorry
by { ext, apply smul_dot_product }
-- sorry

@[simp] lemma mul_vec_add (M : matrix m n R) (v w : n → R) :
  mul_vec M (v + w) = mul_vec M v + mul_vec M w :=
-- sorry
by { ext, apply dot_product_add }
-- sorry

@[simp] lemma mul_vec_smul (M : matrix m n R) (x : R) (v : n → R) :
  mul_vec M (x • v) = x • mul_vec M v :=
-- sorry
by { ext, apply dot_product_smul }
-- sorry

/- Define the canonical map from bilinear forms to matrices.
We assume `R` has a basis `v` indexed by `ι`.

Hint: Follow your nose, the types will guide you.
A matrix `A : matrix ι ι R` is not much more than a function `ι → ι → R`,
and a bilinear form is not much more than a function `M → M → R`. -/
def bilin_form_to_matrix {ι : Type*} [fintype ι] (v : ι → M)
  (B : bilin_form R M) : matrix ι ι R :=
-- sorry
λ i j, B (v i) (v j)
-- sorry

/-- Define the canonical map from matrices to bilinear forms.

For a matrix `A`, `to_bilin_form A` should take two vectors `v`, `w`
and multiply `A` by `v` on the left and `v` on the right.
-/
def matrix_to_bilin_form (A : matrix n n R) : bilin_form R (n → R) :=
-- sorry
{ bilin := λ v w, dot_product v (mul_vec A w),
  bilin_add_left := by { intros, rw [add_dot_product] },
  bilin_add_right := by { intros, rw [mul_vec_add, dot_product_add] },
  bilin_smul_left := by { intros, rw [smul_dot_product], refl },
  bilin_smul_right := by { intros, rw [mul_vec_smul, dot_product_smul], refl } }
-- sorry

/- Can you define a bilinear form directly that is equivalent to this matrix `A`?
Don't use `bilin_form_to_matrix`, give the map explicitly in the form `λ v w, _`.
Check your definition by putting your cursor on the lines starting with `#eval`.

Hints:
  * Use the `simp` tactic to simplify `(x + y) i` to `x i + y i` and `(s • x) i` to `s * x i`.
  * To deal with equalities containing many `+` and `*` symbols, use the `ring` tactic.
-/
def A : matrix (fin 2) (fin 2) R := ![![1, 0], ![-2, 1]]
def your_bilin_form : bilin_form R (fin 2 → R) :=
-- sorry
{ bilin := λ v w, v 0 * w 0 + v 1 * w 1 - 2 * v 1 * w 0,
  bilin_add_left := by { intros, simp, ring },
  bilin_add_right := by { intros, simp, ring },
  bilin_smul_left := by { intros, simp, ring },
  bilin_smul_right := by { intros, simp, ring } }
-- sorry

/- Check your definition here, by uncommenting the #eval lines: -/
def v : fin 2 → ℤ := ![1, 3]
def w : fin 2 → ℤ := ![2, 4]
-- #eval matrix_to_bilin_form A v w
-- #eval your_bilin_form v w

end matrix

end exercise2

section exercise3

namespace pi

variables {n : Type*} [fintype n]

open _root_.matrix

/- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Exercise 3: inner product spaces
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -/

/- Use the `dot_product` function to put an inner product on `n → R`.

Hints:
* Try the lemmas `finset.sum_nonneg`, `finset.sum_eq_zero_iff_of_nonneg`,
  `mul_self_nonneg` and `mul_self_eq_zero`.
-/
noncomputable instance : inner_product_space ℝ (n → ℝ) :=
inner_product_space.of_core
-- sorry
{ inner := dot_product,
  nonneg_re := λ x, finset.sum_nonneg (λ i _, mul_self_nonneg _),
  definite := λ x hx, funext (λ i, mul_self_eq_zero.mp
    ((finset.sum_eq_zero_iff_of_nonneg (λ i _, mul_self_nonneg (x i))).mp hx i (finset.mem_univ i))),
  conj_sym := λ x y, dot_product_comm _ _,
  add_left := λ x y z, add_dot_product _ _ _,
  smul_left := λ s x y, smul_dot_product _ _ _ }
-- sorry

end pi

end exercise3

section exercise4

namespace pi

variables (R n : Type) [comm_ring R] [fintype n] [decidable_eq n]

/- Enable sum and product notation with `∑` and `∏`. -/
open_locale big_operators

/- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  Exercise 4: basis and dimension
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -/

/-- The `i`'th vector in the standard basis of `n → R` is `1` at the `i`th entry
and `0` otherwise. -/
def std_basis_fun (i : n) : (n → R) := λ j, if i = j then 1 else 0

/- Bonus exercise: Show the standard basis of `n → R` is a basis.
This is a difficult exercise, so feel free to skip some parts.

Hints for showing linear independence:
  * Try using the lemma `linear_independent_iff` or `linear_independent_iff'`.
  * To derive `f x = 0` from `h : f = 0`, use a tactic `have := congr_fun h x`.
  * Take a term out of a sum by combining `finset.insert_erase` and `finset.sum_insert`.

Hints for showing it spans the whole module:
  * To show equality of set-like terms, apply the `ext` tactic.
  * First show `x = ∑ i, x i • std_basis R n i`, then rewrite with this equality.
-/
lemma linear_independent_std_basis : linear_independent R (std_basis_fun R n) :=
-- sorry
begin
  apply linear_independent_iff'.mpr,
  intros s v hs i hi,
  have hs : s.sum (λ (i : n), v i • std_basis_fun R n i) i = 0 := congr_fun hs i,
  unfold std_basis_fun at hs,
  rw [←finset.insert_erase hi, finset.sum_insert (finset.not_mem_erase i s)] at hs,
  simpa using hs
end
-- sorry

lemma range_std_basis : submodule.span R (set.range (std_basis_fun R n)) = ⊤ :=
-- sorry
begin
  ext,
  simp only [submodule.mem_top, iff_true],
  rw (show x = ∑ i, x i • std_basis_fun R n i, by { ext, simp [std_basis_fun] }),
  refine submodule.sum_mem _ (λ i _, _),
  refine submodule.smul_mem _ _ _,
  apply submodule.subset_span,
  apply set.mem_range_self
end
-- sorry

/- Bases in mathlib are bundled, i.e., the data of a basis is given as an isomorphism
between the vector space and the space of finitely supported functions on the basis. This turns
out to be a convenient way to work out most arguments using bases. Of course, one can construct
such a bundled basis from the data that a family of vectors is linearly independent and spans
the whole space, as follows. -/

def std_basis : basis n R (n → R) :=
basis.mk (linear_independent_std_basis R n) (range_std_basis R n).ge

variables {K : Type} [field K]

/-
Instead of the dimension of a vector space, `mathlib` chooses to use the more general
notion of rank of a module.

If you want the rank/dimension as a potentially infinite cardinal number, you
can use `module.rank`. If you want the rank/dimension as a finite natural
number, you can use `finite_dimensional.finrank`. (If `module.rank` is infinite,
`finrank` is defined to be equal to `0`.)
-/

/-
Conclude `n → K` is a finite dimensional vector space for each field `K`
and the dimension of `n → K` over `K` is the cardinality of `n`.
You don't need to complete `std_basis_is_basis` to prove these two lemmas.

Hint: search the library for appropriate lemmas.
-/
lemma finite_dimensional : finite_dimensional K (n → K) :=
-- sorry
finite_dimensional.of_fintype_basis (std_basis K n)
-- sorry

lemma finrank_eq : finite_dimensional.finrank K (n → K) = fintype.card n :=
-- sorry
finite_dimensional.finrank_eq_card_basis (std_basis K n)
-- sorry

end pi

end exercise4

end lftcm


/-
Copyright (c) 2022 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import section14polynomials.sheet04more_aux_ideal

/-

Recall that we know `aux_ideal I n` is an increasing function of `n`.
In this file we define `aux_ideal2 I` to be the union over all `n`
of `aux_ideal I n`. Note that it is an ideal of `R`, so if `R` is
Noetherian then it's going to be finitely-generated. This is a key
ingredient im the proof.

-/

variables {R : Type} [comm_ring R] (I : ideal (polynomial R))

open polynomial

/-

Recall the key API for `⋃` is `set.mem_Union`
-/

/-- An auxiliary ideal used in the proof of Hilbert's Basis Theorem.
It's equal to the elements of `R` which are either 0, or the
leading coefficient of an element of `I`. Showing that this is an
ideal is made much easier by the fact that it can also be thought
of as a union of the increasing sequence of ideals `aux_ideal I n`. -/
def aux_ideal2 (I : ideal (polynomial R)) : ideal R :=
{ carrier := ⋃ n, aux_ideal I n,
  zero_mem' := begin
    sorry,
  end,
  add_mem' := begin
    sorry,
  end,
  smul_mem' := begin
    sorry,
  end }

namespace aux_ideal2

-- we make some helpful API.

lemma mem (I : ideal (polynomial R)) (j : R) (hj : j ∈ aux_ideal2 I) :
  ∃ m, j ∈ aux_ideal I m :=
begin
  sorry
end

lemma mem_iff (I : ideal (polynomial R)) (j : R) :
 j ∈ aux_ideal2 I ↔ ∃ m, j ∈ aux_ideal I m :=
begin
  sorry
end

/-

Assume `R` is Noetherian. Because `aux_ideal2 I` is finitely-generated,
the increasing chain of ideals `aux_ideal I 0 ≤ aux_ideal I 1 ≤ aux_ideal I 2 ≤ ...`
must stabilise.

Helpful API: `finset.sup`. Don't forget to use the `classical` tactic
if you run into decidability issues.

-/
lemma canonical_N (hR : is_noetherian_ring R) :
  ∃ N, ∀ m, N ≤ m → aux_ideal2 I = aux_ideal I m :=
begin
  sorry,
end

end aux_ideal2


import Lib.Logic.Classical
import Lib.Tactic

namespace Nat

attribute [auto] Nat.le_of_lt Nat.le_add_right Nat.zero_le
attribute [auto] Nat.le_add_left Nat.le_add_right
attribute [auto] Nat.add_le_add_right Nat.add_le_add_left
attribute [simp] Nat.add_succ Nat.succ_sub_succ Nat.lt_succ_self
attribute [simp] Nat.pow_succ Nat.pow_zero
attribute [simp] Nat.add_sub_cancel_left Nat.add_sub_of_le
attribute [simp] Nat.add_sub_add_left Nat.add_sub_add_right

theorem succ_inj {m n : Nat} (h : m.succ = n.succ) : m = n :=
by cases h; refl

theorem ne_symm {x y : Nat} : x ≠ y → y ≠ x :=
by intros h h'; subst h'; apply h; rfl

theorem add_lt_of_lt_sub_r {m n k : Nat} :
  m < n - k → m + k < n := by
induction k generalizing n with
| zero =>
  simp; apply id
| succ k ih =>
  simp
  cases n <;> simp
  { intros h; cases h }
  simp [succ_sub_succ, add_succ]
  intros h; apply succ_lt_succ
  apply ih; assumption

theorem add_succ_eq_succ_add (m n : Nat) :
  m + succ n = succ m + n := by
simp [Nat.add_succ, Nat.succ_add]

theorem add_lt_of_lt_sub_l {m n k : Nat} :
  m < n - k → k + m < n := by
rw [Nat.add_comm]; apply add_lt_of_lt_sub_r

@[auto]
theorem le_add_of_le_l {m n k : Nat}
        (h : m ≤ n) :
  m ≤ n + k :=
by trans n <;> auto

@[auto]
theorem le_add_of_le_r {m n k : Nat}
        (h : m ≤ k) :
  m ≤ n + k :=
by trans k <;> auto

@[simp]
theorem succ_lt_succ_iff {n m : Nat} : succ n < succ m ↔ n < m :=
⟨ lt_of_succ_lt_succ, succ_lt_succ ⟩

@[simp]
theorem zero_lt_sub_iff_lt {x y : Nat} :
  0 < y - x ↔ x < y := by
induction x generalizing y <;>
  cases y <;> simp [*]
intros h; cases h

theorem sub_ne_zero {x y : Nat} :
  x < y → y - x ≠ 0 := by
intros h
have h' : 0 < y - x := by simp [*]
intros h''; rewrite [h''] at h'; clear h''
apply Nat.lt_irrefl _ h'

@[simp]
theorem sub_add_assoc {x y z : Nat} :
  x - (y + z) = x - y - z :=
by induction z <;> simp [Nat.sub_succ, *]

@[auto]
theorem le_of_not_gt {x y : Nat} (h : ¬ y < x) : x ≤ y := by
byContradiction h;
cases (Nat.lt_or_ge y x) <;> contradiction

theorem min_lt_min_l {x x' y y' : Nat}
  (Hx : x < x')
  (Hy : y < y') :
  min x y < min x' y' := by
simp [min]
split <;> split <;> try assumption
. apply Nat.lt_of_le_of_lt <;> assumption
next h₀ _ =>
  have h₀ : y < x := Nat.gt_of_not_le h₀
  apply Nat.lt_trans <;> assumption

theorem max_lt_max {x x' y y' : Nat}
  (Hx : x < x')
  (Hy : y < y') :
  max x y < max x' y' := by
simp [max]
split <;> split <;> try assumption
focus
  apply Nat.lt_of_lt_of_le Hx
  auto [Nat.le_of_not_gt]
focus
  trans y' <;> assumption

@[simp]
theorem succ_le_succ_iff {p q : Nat} :
  p.succ ≤ q.succ ↔ p ≤ q := by
constructor
. apply Nat.le_of_succ_le_succ
. apply Nat.succ_le_succ

theorem succ_le_iff_le_pred {p q : Nat}
  (h : 0 < q) :
  Nat.succ p ≤ q ↔ p ≤ Nat.pred q := by
induction q
focus cases h
focus
  simp [Nat.succ_le_succ, Nat.pred]

theorem pred_sub {p q} : Nat.pred p - q = Nat.pred (p - q) := by
simp [(.-.), Sub.sub]; induction q
. apply Nat.sub_zero
. simp [Nat.sub,sub_succ, *]

theorem strong_ind {P : Nat → Prop} :
  (∀ x, (∀ y, y < x → P y) → P x) → ∀ a, P a :=
by intros h x; apply Nat.lt_wfRel.wf.induction (C := P) x h

theorem le_of_not_lt {x y : Nat}
        (h : ¬ y < x) :
  x ≤ y := by
cases Nat.lt_or_ge y x <;> auto

@[auto]
theorem not_lt_of_le {x y : Nat}
        (h : y ≤ x) :
  ¬ x < y := by
intros h'
apply Nat.not_le_of_gt h' h

theorem add_le_iff_l {p q z : Nat}
  (Hq : z ≤ q) :
  z + p ≤ q ↔ p ≤ q - z := by
induction z generalizing q;
focus simp
next z ih =>
  have : 0 < q := by
    apply Nat.le_trans _ Hq
    apply Nat.succ_le_succ
    apply Nat.zero_le
  have : z ≤ Nat.pred q := by
    rw [← Nat.succ_le_iff_le_pred] <;> assumption
  simp [Nat.succ_add, Nat.sub_succ, Nat.succ_le_iff_le_pred, *, Nat.pred_sub]

theorem add_le_iff_r {p q z : Nat}
  (Hq : z ≤ q) :
  p + z ≤ q ↔ p ≤ q - z :=
by rw [Nat.add_comm]; simp [add_le_iff_l, *]

section max_min

variable {x y z : Nat}

theorem eq_iff_forall_le_iff :
  x = y ↔ ∀ z, x ≤ z ↔ y ≤ z := by
constructor <;> intros h
. subst h; intros; exact Iff.rfl
focus
  apply Nat.le_antisymm
  . rw [h]; refl
  . rw [← h]; refl

theorem eq_iff_forall_ge_iff :
  x = y ↔ ∀ z, z ≤ x ↔ z ≤ y := by
constructor <;> intros h
. subst h; intros; exact Iff.rfl
focus
  apply Nat.le_antisymm
  . rw [← h]; refl
  . rw [h]; refl

theorem le_iff_forall_le_implies :
  x ≤ y ↔ ∀ z, y ≤ z → x ≤ z := by
constructor <;> intros h
. intros z h₁; trans y <;> assumption
apply h <;> refl

theorem le_iff_forall_ge_implies :
  x ≤ y ↔ ∀ z, z ≤ x → z ≤ y := by
constructor <;> intros h
. intros z h₁; trans x <;> assumption
apply h <;> refl

@[simp]
theorem max_le_iff :
  max x y ≤ z ↔ x ≤ z ∧ y ≤ z := by
simp [max]; split
next h =>
  constructor <;> intros h'
  focus
    constructor <;> try assumption
    trans _
    . apply Nat.le_of_lt h
    . assumption
  focus
    cases h'; assumption
next h =>
  have : x ≤ y := by
    rewrite [← Classical.not_not (x ≤ y)]
    intros h'; apply h; apply gt_of_not_le h'
  constructor <;> intros h'
  focus
    constructor <;> try assumption
    trans _ <;> assumption
  focus
    cases h'; assumption

@[simp]
theorem le_min_iff :
  x ≤ min y z ↔ x ≤ y ∧ x ≤ z := by
simp [min]; split
next h =>
  constructor <;> intros h'
  focus
    constructor <;> try assumption
    trans _ <;> assumption
  focus
    cases h'; assumption
next h =>
  have : z ≤ y := by
    cases Nat.le_total z y <;> trivial
  constructor <;> intros h'
  focus
    constructor <;> try assumption
    trans _ <;> assumption
  focus
    cases h'; assumption

theorem max_comm : max x y = max y x := by
simp [eq_iff_forall_le_iff]; auto with 6

theorem min_comm : min x y = min y x := by
simp [eq_iff_forall_ge_iff]; auto with 6

theorem le_max_l : x ≤ y → x ≤ max y z := by
intros h
rewrite [le_iff_forall_le_implies]; intros z
rewrite [max_le_iff]; intros h; cases h
trans _ <;> assumption

theorem le_max_r : x ≤ z → x ≤ max y z := by
rw [max_comm]; apply le_max_l
-- intros h
-- rewrite [le_iff_forall_le_implies]; intros z
-- rewrite [max_le_iff]; intros h; cases h
-- trans _ <;> assumption

theorem lt_max_l : x < y → x < max y z := by
apply le_max_l

theorem lt_max_r : x < z → x < max y z := by
apply le_max_r

theorem add_lt_add_r : y < z → x + y < x + z := by
intros h
induction x <;> simp [*, succ_add]

theorem min_le_l : x ≤ z → min x y ≤ z := by
intros h
rewrite [le_iff_forall_ge_implies]; intros z
rewrite [le_min_iff]; intros h; cases h
trans x <;> assumption

theorem min_le_r : y ≤ z → min x y ≤ z := by
rw [min_comm]; apply min_le_l

@[auto] theorem self_le_max_l : x ≤ max x y := le_max_l $ by refl
@[auto] theorem self_le_max_r : y ≤ max x y := le_max_r $ by refl
@[auto] theorem min_le_self_l : min x y ≤ x := min_le_l $ by refl
@[auto] theorem min_le_self_r : min x y ≤ y := min_le_r $ by refl

@[simp] theorem min_eq_iff_le_l : min x y = x ↔ x ≤ y := by
  constructor <;> intros h
  . rw [← h]; auto
  focus
    apply Nat.le_antisymm
    . auto
    . simp; auto

@[simp] theorem min_eq_iff_le_r : min x y = y ↔ y ≤ x := by
  rw [min_comm, min_eq_iff_le_l]; refl

@[simp] theorem max_eq_iff_le_l : max x y = x ↔ y ≤ x := by
  constructor <;> intros h
  . rw [← h]; auto
  focus
    apply Nat.le_antisymm
    . simp; auto
    . auto

@[simp] theorem max_eq_iff_le_r : max x y = y ↔ x ≤ y := by
  rw [max_comm, max_eq_iff_le_l]; refl

@[simp]
theorem min_self : min x x = x := by
rw [min_eq_iff_le_r]; refl

@[simp]
theorem max_self : max x x = x := by
rw [max_eq_iff_le_r]; refl

@[simp]
theorem lt_min_iff :
  x < min y z ↔ x < y ∧ x < z := by
constructor
focus
  intros h; constructor
  . apply Nat.lt_of_lt_of_le h; auto
  . apply Nat.lt_of_lt_of_le h; auto
focus
  intros h; cases h with | intro h₀ h₁ =>
  rw [← min_self (x := x)]
  apply min_lt_min_l <;> assumption

@[simp]
theorem lt_max_iff :
  max x y < z ↔ x < z ∧ y < z := by
constructor
focus
  intros h; constructor
  <;> apply Nat.lt_of_le_of_lt _ h <;> auto
focus
  intros h; cases h with | intro h₀ h₁ =>
  rw [← max_self (x := z)]
  apply max_lt_max <;> assumption

@[simp]
theorem max_add {p q₀ q₁ : Nat} :
  max (p + q₀) (p + q₁) = p + max q₀ q₁ := by
simp [Nat.eq_iff_forall_le_iff]; intros z
by_cases h : p ≤ z
. simp [Nat.add_le_iff_l, *]
focus
  have : ∀ q, ¬ p + q ≤ z := by
    intros q h'; apply h; clear h
    trans _; case second => assumption
    auto
  simp [*]
end max_min

end Nat

namespace Nat

theorem lt_iff_not_le {x y : Nat} :
  x < y ↔ ¬ y ≤ x :=
by auto [Nat.gt_of_not_le, Nat.not_le_of_gt]

theorem le_iff_not_lt {x y : Nat} :
  x ≤ y ↔ ¬ y < x :=
by auto [Nat.le_of_not_gt, Nat.not_lt_of_le]

@[auto]
theorem div_gcd_self_l : d / gcd n d > 0 :=
sorry

theorem gcd_mul p q n : gcd p q * n = gcd (p * n) (q * n) :=
sorry

theorem mul_inj (h : n > 0) : p * n = q * n → p = q :=
sorry

def divides (p q : Nat) :=
∃ k, p * k = q

infix:65 " ∣ " => divides

@[simp]
theorem div_mul_self (h : p ∣ q) :
  q / p * p = q := sorry

@[simp]
theorem gcd_divides_l : gcd p q ∣ p :=
sorry

@[simp]
theorem gcd_divides_r : gcd p q ∣ q :=
sorry

theorem sub_lt_of_lt_add {x y : Nat} (h₀ : y ≤ x) :
  x < z + y →
  x - y < z := by
intros h
apply Nat.gt_of_not_le
intros h'
apply Nat.not_le_of_gt h; clear h
rw [add_le_iff_r]
<;> auto

theorem sub_add_self {a b : Nat} (h : b ≤ a) :
  (a - b) + b = a := by
rw [Nat.add_comm, ← Nat.add_sub_assoc, Nat.add_sub_self_left]
<;> assumption

theorem le_add_of_sub_le_l {m n k : Nat} :
  n - k ≤ m → n ≤ k + m := by
rw [le_iff_not_lt, le_iff_not_lt]
intros h h'
apply h; clear h
apply Nat.lt_of_le_of_lt (m := (k + m) - k)
next =>
  rw [add_sub_self_left]; refl
next =>
  apply sub_lt_of_lt_add; auto
  rw [Nat.sub_add_self]; auto
  trans k + m <;> auto

@[simp]
theorem add_sub_cancel_l {x y : Nat} :
  x + y - y = x := by
rw [eq_iff_forall_ge_iff]; intro z
rw [← add_le_iff_r]
constructor
focus
  apply Nat.le_of_add_le_add_right
focus
  auto
focus
  apply Nat.le_add_left

theorem succ_le_iff {x y : Nat} (h : 0 < y) :
  succ x ≤ y ↔ x ≤ pred y := by
induction y
. cases h
. simp [pred]

section div

theorem div_sub_self {x y : Nat} :
  (x - y) / y = pred (x / y) := by
rw [div_eq x y]; split
. refl
next h =>
  have : ¬ (0 < y ∧ y ≤ x - y) := by
    intros h'; cases h'
    apply h; clear h
    constructor; assumption
    trans (x - y)
    <;> auto [Nat.sub_le]
  rw [div_eq]; simp [*]

theorem mul_le_iff_le_div {x y k : Nat} (h : 1 ≤ k) :
  x*k ≤ y ↔ x ≤ y / k := by
induction x generalizing y with
| zero => simp [zero_le]
| succ x =>
  simp [succ_mul]
  have Hy := div_eq y k
  revert Hy; split <;> intro Hy
  next h =>
    cases h
    have : 0 < y / k := by
      simp [Hy, zero_lt_succ]
    clear Hy
    simp [succ_le_iff, add_le_iff_r, div_sub_self, *]
    done
  next h =>
    have h : ¬ k ≤ y := by
      intro h₀; apply h; auto
    simp [Hy, Classical.iff_iff_and_or_and]
    next =>
      intros h'; apply h; clear h
      trans x * k + k <;>  auto [Nat.le_add_left]

theorem div_lt {x k : Nat} (h : k > 1) (h' : 0 < x) :
  x / k < x := by
rw [lt_iff_not_le, ← mul_le_iff_le_div]
focus
  intros h
  have h' : x * k ≤ x * 1 := sorry
  -- have := mul_inj _ h'
  admit
admit

theorem div_le_div {x y k : Nat} (h : x ≤ y) :
  x / k ≤ y / k :=
sorry

end div

section pow

@[simp]
theorem one_pow {x : Nat} : 1^x = 1 := by
induction x <;> simp; assumption

@[auto]
theorem one_le_pow {x y : Nat} (h : 1 ≤ x) :
  1 ≤ x^y := by
suffices 1^y ≤ x^y by
  simp [one_pow] at this; auto
auto [pow_le_pow_of_le_left]

end pow

section log2

theorem log2_def n :
  log2 n =
  if h : n ≥ 2 then log2 (n / 2) + 1 else 0 :=
WellFounded.fix_eq _ _ _

@[simp]
theorem log2_one : log2 1 = 0 := by
have h₀ : ¬ 2 ≤ 1 :=
  by intros h; cases h with
     | step h  => apply Nat.not_succ_le_zero _ h
rw [log2_def]; simp [*]

@[simp]
theorem log2_2 : log2 2 = 1 := by
have h₀ : 2 ≤ 2 := by refl
rw [log2_def]; simp [*]

theorem log2_div_2 {x : Nat} : log2 (x / 2) = log2 x - 1 := by
rw [log2_def x]
split
. rw [add_sub_cancel_l]
next h' =>
have : ¬ 2 ≤ x / 2 := by
  intros h₀; apply h'
  admit
  -- trans x / 2 <;> try auto
  -- apply Nat.le_of_lt
  -- apply div_lt
  -- . repeat constructor
  -- apply gt_of_not_le
  -- intro h; have h := Nat.le_antisymm h (zero_le _)
  -- subst h; cases h₀
rw [log2_def]; simp [*]

theorem log2_le_log2 {x y : Nat} (h : x ≤ y) :
  log2 x ≤ log2 y := by
induction x using Nat.strong_ind generalizing y;
next x ih =>
  rw [log2_def x,log2_def y]
  split
  next h₀ =>
    have : 2 ≤ y := by
      trans x <;> assumption
    simp [*]; apply ih
    focus
      have h₁ : 0 < 2 := by repeat constructor
      have h₂ : 1 < 2 := by repeat constructor
      apply Nat.div_lt h₂
      apply Nat.lt_of_lt_of_le h₁ h₀
    focus
      auto [Nat.div_le_div]
  focus auto

theorem pow_le_iff_le_log {x y : Nat} (h : 1 ≤ y) :
  2^x ≤ y ↔ x ≤ log2 y := by
induction x generalizing y;
. simp [*, Nat.zero_le]
by_cases h : 1 ≤ y / 2
focus
  have h' : 1 ≤ log2 y := by
    rw [← mul_le_iff_le_div] at h
    have h := log2_le_log2 h
    simp at h; all_goals auto
  simp [*, Nat.zero_le, mul_le_iff_le_div, log2_div_2, ← add_le_iff_r]
next n ih _ =>
  have h' : y = 1 := by
    admit
    -- rw [← mul_le_iff_le_div] at h
    -- apply Nat.le_antisymm
    -- all_goals auto
  have h'' : succ n ≤ 0 ↔ False :=
    by auto [Nat.not_succ_le_zero]
  subst y; simp [mul_le_iff_le_div, *]
  apply Nat.not_le_of_gt
  change 1 /2 with 0
  auto [pos_pow_of_pos]

end log2

end Nat


structure Graph(V: Type) (E: Type) where
  null : E
  init : E → V
  bar : E → E
  barInv : bar ∘ bar = id
  barNoFP : ∀ e: E, bar e ≠ e

variable {V: Type}{E: Type}[DecidableEq V][DecidableEq E]{x₁ x₂ : V}

@[inline] def term (graph: Graph V E): E → V :=
  fun e => graph.init (graph.bar e)

inductive EdgePath (graph: Graph V E): V → V → Type where
  | single : (x: V) → EdgePath graph x x
  | cons : {x y z : V} → (e : E) → graph.init e = x → term graph e = y →
        EdgePath graph y z → EdgePath graph x z

def EdgePath.length {graph: Graph V E}{x y: V}: EdgePath graph x y → Nat
  | EdgePath.single x => 0
  | EdgePath.cons  _ _ _ path => length path + 1

open EdgePath

-- concatenates two edgepaths
def multiply {G : Graph V E} {x y z : V}: (EdgePath G x y) → (EdgePath G y z) → (EdgePath G x z) := by
intro p q
match p with
| single x => exact q
| cons ex h1 h2 exy => exact (cons ex h1 h2 (multiply exy q))

--proves that the endpoint of the reverse of an edge is the start point of the edge
theorem term_bar_equals_init {G : Graph V E} {x : V}{e : E}: G.init e = x → (term G (G.bar e) = x) :=
by
intro h
have h₁ : G.bar (G.bar e) = e := congr G.barInv (Eq.refl e)
have h₂ : G.init (G.bar (G.bar e)) = G.init e := congrArg G.init h₁
apply Eq.trans h₂ h

--proves that initial vertex of reversed edge is the terminal vertex of the original edge
theorem init_bar_equals_term {G : Graph V E} {x :V} {e : E}: (term G e = x) → G.init (G.bar e) = x:= by
intro hyp
have : G.init (G.bar e) = term G e := by rfl
exact Eq.trans this hyp

-- proves associativity of path multiplication
theorem mult_assoc {G : Graph V E} (p : EdgePath G w x) (q : EdgePath G x y) (r : EdgePath G y z):
      (multiply (multiply p q) r) = (multiply p (multiply q r)) := by
      induction p with
      | single w => simp[multiply]
      | cons ex h1 h2 exy ih => simp[multiply, ih]

--proves that "single x" is an identity element for multiplication
theorem mult_const {G : Graph V E} {p : EdgePath G x y} :
      (multiply p (single y)) = p := by
      induction p with
      | single x => simp [multiply]
      | cons ex h1 h2 exy ih => simp[multiply, ih]

-- reverses an edgepath
def inverse {G : Graph V E} {x y : V}: (EdgePath G x y) → (EdgePath G y x)
| single x => single x
| cons ex h₁ h₂ exy => multiply (inverse exy) (cons (G.bar (ex)) h₂ (term_bar_equals_init h₁) (single x))

--helper function for reducePath, that reduces the first two edges of the path
def reducePath0 {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : { rp : EdgePath G x z // rp.length ≤ (cons ex h₁ h₂ exy).length} := by
cases exy with
 | single x => exact ⟨cons ex h₁ h₂ (single y), by simp⟩
 | cons ey h₃ h₄ eyz =>
   apply
  if c : (x = term G ey) ∧ (ey = G.bar (ex)) then
  ⟨ Eq.symm (Eq.trans (And.left c) h₄) ▸ eyz, by
      have h₅ : (Eq.symm (Eq.trans (And.left c) h₄) ▸ eyz).length = eyz.length := by
        let ih := Eq.symm (Eq.trans (And.left c) h₄)
        cases ih with
        | refl => rfl
      simp[EdgePath.length, h₅, Nat.le_trans (Nat.le_succ (length eyz)) (Nat.le_succ (length eyz +1))]
  ⟩
  else
  ⟨ cons ex h₁ h₂ (cons ey h₃ h₄ (eyz)), by apply Nat.le_refl⟩

-- reduces given path such that no two consecutive edges are inverses of each other
def reducePath {G : Graph V E} : (p : EdgePath G x y ) →
  {rp : EdgePath G x y // rp.length ≤ p.length}
| single x => ⟨single x, by simp⟩
| cons ex h₁ h₂ ey'y =>
 -- have h5': length ey'y < length (cons ex h1 h2 ey'y) := by simp[EdgePath.length, Nat.lt_succ_self]
  let ⟨ey'z, ih1⟩ := reducePath ey'y
  let ⟨ ez, ih⟩ := reducePath0 ex h₁ h₂ ey'z
  ⟨ ez , by
          have : length (cons ex h₁ h₂ ey'z) = length ey'z + 1 := by simp[length]
          let k := this ▸ ih
          have pr : length ey'z +1 ≤ length ey'y +1 := by apply Nat.succ_le_succ ih1
          simp[length, Nat.le_trans k pr] ⟩

  termination_by _ _ _ _ p => p.length
  decreasing_by
  simp_wf
  simp[EdgePath.length, Nat.lt_succ_self]

--defines moves allowing homotopy of edgepaths
inductive basicht {G : Graph V E} : EdgePath G x y → EdgePath G x y → Sort where
  | consht : (x : V) → (basicht (single x) (single x)) -- constant homotopy
  | cancel : (ex ex' : E) → { x w y : V} → (p : EdgePath G x y) → -- cancelling consecutive opposite edges from a path
            (h : G.init ex = x) → (h' : term G ex = w) → (t : G.bar ex = ex') →
            basicht p (cons ex h h' (cons ex' (t ▸ init_bar_equals_term h') (t ▸ term_bar_equals_init h) p))
  | mult : {x y z : V} → {p q : EdgePath G y z} →   -- adding an edge to homotopic paths
          basicht p q → (ex : E) →(h' : G.init ex = x) → ( h : term G ex = y)→
          basicht (cons ex h' h p) (cons ex h' h q)

--defines the set of homotopy classes of edgepaths from x to y
def ht (G : Graph V E) (x y : V) := Quot (@basicht V E G x y )

def htclass {G : Graph V E} {x y : V} ( p : EdgePath G x y) : ht G x y :=
  Quot.mk (@basicht V E G x y ) p

def homotopy {G : Graph V E} {x y : V} ( p' q' : EdgePath G x y) : Prop :=
  htclass p' = htclass q'

--proves that homotopy is a transitive relation
theorem homotopy_trans {G : Graph V E} {x y : V} (p q r : EdgePath G x y) : homotopy p q → homotopy q r → homotopy p r := by
  intro h₁ h₂
  simp[homotopy, htclass]
  have p₁ : Quot.mk basicht p = Quot.mk basicht q := by apply h₁
  have p₂ : Quot.mk basicht q = Quot.mk basicht r := by apply h₂
  apply Eq.trans p₁ p₂

--proves that homotopy is preserved by multiplying an edge to the left
theorem homotopy_left_mult_edge {G : Graph V E} {x y z : V}: (p q : EdgePath G y z) → homotopy p q → (ex : E) →(h1 : G.init ex = x) → ( h : term G ex = y)→ homotopy (cons ex h1 h p) (cons ex h1 h q) := by
  intro p q h ex h1 h2
  let func (r : EdgePath G y z) : ht G x z := htclass (cons ex h1 h2 r)
  have g : (r₁ r₂ : EdgePath G y z) →  basicht r₁ r₂ → func r₁ = func r₂ := by
     intro r₁ r₂ h₁
     let t := basicht.mult h₁ ex h1 h2
     have : htclass (cons ex h1 h2 r₁) = htclass (cons ex h1 h2 r₂) := by simp[htclass]; apply Quot.sound t
     simp[this]
  simp[homotopy]
  let k := Quot.lift func g
  apply congrArg k h

--proves that homotopy is left multiplicative
theorem homotopy_left_mult {G : Graph V E} {x y z : V} (p1 p2 : EdgePath G y z) (q : EdgePath G x y) (h :homotopy p1 p2):
         (homotopy (multiply q p1) (multiply q p2)) := by
         induction q with
        | single w  =>
          simp [multiply, h]
        | cons ex h1 h2 exy ih =>
          let c := ih p1 p2 h
          have t₁ : multiply (cons ex h1 h2 exy) p1 = cons ex h1 h2 (multiply exy p1) := by simp[multiply, mult_assoc]
          have t₂ : multiply (cons ex h1 h2 exy) p2 = cons ex h1 h2 (multiply exy p2) := by simp[multiply, mult_assoc]
          rw[t₁, t₂]
          simp[homotopy_left_mult_edge, c]

--defines multiplication of homotopy class with a path to its left
def homotopy_left_multiplication {G :Graph V E} {x y z : V} (p₁ : EdgePath G x y) : ht G y z →  ht G x z := by
  let func: EdgePath G y z → ht G x z := by intro p ; exact htclass (multiply p₁ p)
  have g : (q₁ q₂ : EdgePath G y z) → basicht q₁ q₂ → func q₁ = func q₂ := by
          intro q₁ q₂ h
          simp
          have h' : homotopy q₁ q₂ := by simp[homotopy, htclass, Quot.sound h ]
          apply homotopy_left_mult q₁ q₂ p₁ h'
  apply Quot.lift func g

--proves that the multiplication defined above equals homotopy class of multiplied paths
theorem homotopy_left_multiplication_class {G :Graph V E} {x y z : V} (p₁ : EdgePath G x y) (p₂ : EdgePath G y z): homotopy_left_multiplication p₁ (htclass p₂) = htclass (multiply p₁ p₂) := by
  simp[htclass, homotopy_left_multiplication]

--proves that reducePath0 preserves the homotopy class
theorem homotopy_reducePath0 {G : Graph V E} {x y z : V} (ex : E) (h₁ : G.init ex = x) (h₂ : term G ex = y) (exy : EdgePath G y z) : homotopy (cons ex h₁ h₂ exy) (reducePath0 ex h₁ h₂ exy) := by
simp[homotopy, htclass]
cases exy with
| single y =>
    have : reducePath0 ex h₁ h₂ (single y) = cons ex h₁ h₂ (single y) := by rfl
    rfl
| cons ey h₃ h₄ eyz => apply
  if c : (x = term G ey) ∧ (ey = G.bar (ex)) then by
     let ih := Eq.symm (Eq.trans (And.left c) h₄)
     cases ih with
     |refl =>
        have : basicht (ih ▸ eyz)  (cons ex h₁ h₂ (cons ey h₃ h₄ eyz))  := by
          let j := @basicht.cancel V E G ex ey x y _ (ih ▸ eyz) h₁ h₂ (Eq.symm c.2)
          apply j
        have pr : (reducePath0 ex h₁ h₂ (cons ey h₃ h₄ eyz)).1 = (ih ▸ eyz) := by simp[reducePath0, c]
        let k := Quot.sound (Eq.symm pr ▸ this)
        exact (Eq.symm k)
  else by
    have : reducePath0 ex h₁ h₂ (cons ey h₃ h₄ eyz) = cons ex h₁ h₂ (cons ey h₃ h₄ (eyz)) := by simp[reducePath0, c]
    simp [this]

--proves that reducePath preserves the homotopy class
theorem homotopy_reducePath {G : Graph V E} {x y : V} (p₁ : EdgePath G x y): homotopy p₁ (reducePath p₁) := by
        induction p₁ with
        | single x =>
          simp[homotopy, htclass]
          have h₁ : ( @reducePath V E _ _ x x G (single x)).1 = single x  := by rfl
          have h₂ : single x = (reducePath (single x)).1 := by exact (Eq.symm h₁)
          apply Quot.sound (h₂ ▸ basicht.consht x)

        | cons ex h₁ h₂ exy ih' =>
          let p₃ := reducePath exy
          let q := p₃.1
          let p₄ := reducePath0 ex h₁ h₂ q
          have : p₄.1 = (reducePath (cons ex h₁ h₂ exy)).1 := by rfl
          have t₁ : homotopy (cons ex h₁ h₂ q) (p₄.1) := by apply homotopy_reducePath0 ex h₁ h₂ q
          have t₂ : homotopy exy q := by apply ih'
          have t₃ : homotopy (cons ex h₁ h₂ exy) (cons ex h₁ h₂ q) := by apply homotopy_left_mult_edge exy q t₂ ex h₁ h₂
          apply homotopy_trans (cons ex h₁ h₂ exy) (cons ex h₁ h₂ q) (reducePath (cons ex h₁ h₂ exy)) t₃ (this ▸ t₁)


import ia.groups.axioms

namespace notes

open group

-- Structures for homomorphisms and specific types

@[ext]
structure hom (G H : Type*) [group G] [group H] :=
(to_fun : G → H)
(map_mul : ∀ x y, to_fun (x * y) = to_fun x * to_fun y)

@[ext]
structure add_hom (G H : Type*) [add_group G] [add_group H] :=
(to_fun : G → H)
(map_add : ∀ x y, to_fun (x + y) = to_fun x + to_fun y)

attribute [to_additive add_hom] hom

infixr ` →* `:25 := hom
infixr ` →+ `:25 := add_hom

-- `hom_class F A B` states that `F` is a type of multiplication-preserving morphisms.
class hom_class (F : Type*) (A B : out_param $ Type*) [group A] [group B]
  extends fun_like F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (x * y) = (f x) * (f y))

-- `add_hom_class F A B` states that `F` is a type of addition-preserving morphisms.
class add_hom_class (F : Type*) (A B : out_param $ Type*) [add_group A] [add_group B]
  extends fun_like F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (x + y) = (f x) + (f y))

attribute [to_additive add_hom_class] hom_class

@[ext, ancestor hom]
structure hom.mono (G H : Type*) [group G] [group H] extends hom G H :=
(inj : function.injective to_fun)

@[ext, ancestor add_hom]
structure add_hom.mono (G H : Type*) [add_group G] [add_group H] extends add_hom G H :=
(inj : function.injective to_fun)

@[ext, ancestor hom]
structure hom.epi (G H : Type*) [group G] [group H] extends hom G H :=
(surj : function.surjective to_fun)

@[ext, ancestor add_hom]
structure add_hom.epi (G H : Type*) [add_group G] [add_group H] extends add_hom G H :=
(surj : function.surjective to_fun)

@[ext, ancestor hom]
structure hom.iso (G H : Type*) [group G] [group H] extends hom G H :=
(bij : function.bijective to_fun)

@[ext, ancestor add_hom]
structure add_hom.iso (G H : Type*) [add_group G] [add_group H] extends add_hom G H :=
(bij : function.bijective to_fun)

attribute [to_additive] hom.mono
attribute [to_additive] hom.epi
attribute [to_additive] hom.iso

class hom.mono_class (F : Type*) (A B : out_param $ Type*) [group A] [group B]
  extends hom_class F A B :=
(inj : ∀ (f : F), function.injective f)

class add_hom.mono_class (F : Type*) (A B : out_param $ Type*) [add_group A] [add_group B]
  extends add_hom_class F A B :=
(inj : ∀ (f : F), function.injective f)

class hom.epi_class (F : Type*) (A B : out_param $ Type*) [group A] [group B]
  extends hom_class F A B :=
(surj : ∀ (f : F), function.surjective f)

class add_hom.epi_class (F : Type*) (A B : out_param $ Type*) [add_group A] [add_group B]
  extends add_hom_class F A B :=
(surj : ∀ (f : F), function.surjective f)

class hom.iso_class (F : Type*) (A B : out_param $ Type*) [group A] [group B]
  extends hom_class F A B :=
(bij : ∀ (f : F), function.bijective f)

class add_hom.iso_class (F : Type*) (A B : out_param $ Type*) [add_group A] [add_group B]
  extends add_hom_class F A B :=
(bij : ∀ (f : F), function.bijective f)

attribute [to_additive] hom.mono_class
attribute [to_additive] hom.epi_class
attribute [to_additive] hom.iso_class

infixr ` ↪* `:25 := hom.mono
infixr ` ↠* `:25 := hom.epi
infix ` ≅* `:25 := hom.iso
infixr ` ↪+ `:25 := add_hom.add_mono
infixr ` ↠+ `:25 := hom.add_epi
infix ` ≅+ `:25 := add_hom.iso

@[reducible, to_additive]
def hom.ex_iso (A B : Type*) [group A] [group B] : Prop := nonempty (A ≅* B)

infix ` ∃≅* `:25 := hom.ex_iso
infix ` ∃≅+ `:25 := add_hom.ex_iso

namespace hom

variables {G H K L : Type*} [group G] [group H] [group K] [group L] -- groups
variables {Φ Ψ Χ : Type*} -- homomorphisms (note: Χ is a capital χ not a Latin capital x)

@[simp, to_additive] lemma map_op [hom_class Φ G H]
  (φ : Φ) (x y : G) : φ (x * y) = (φ x) * (φ y) :=
hom_class.map_op φ x y

@[simp, to_additive] lemma hom_coe_def [hom_class Φ G H]
  (φ : Φ) (x : G) : fun_like.coe φ x = φ x := rfl

@[to_additive]
instance to_hom_class {G H : Type*} [group G] [group H] : hom_class (G →* H) G H :=
{ coe := hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := hom.map_mul }

@[to_additive]
instance to_mono_class : mono_class (G ↪* H) G H := {
  coe := λ φ, φ.to_fun,
  coe_injective' := begin
    intros f g h,
    dsimp at h,
    ext,
    rw h
  end,
  map_op := λ φ, φ.map_mul,
  inj := begin
    intros φ x y,
    apply φ.inj
  end,
}

@[to_additive]
instance to_epi_class : epi_class (G ↠* H) G H := {
  coe := λ φ, φ.to_fun,
  coe_injective' := begin
    intros f g h,
    dsimp at h,
    ext,
    rw h
  end,
  map_op := λ φ, φ.map_mul,
  surj := begin
    intros φ x,
    apply φ.surj
  end,
}

@[to_additive]
instance to_iso_class : iso_class (G ≅* H) G H := {
  coe := λ φ, φ.to_fun,
  coe_injective' := begin
    intros f g h,
    dsimp at h,
    ext,
    rw h
  end,
  map_op := λ φ, φ.map_mul,
  bij := begin
    intro φ,
    split,
    { intros x y,
      apply φ.bij.1 },
    { intro x,
      apply φ.bij.2 }
  end,
}

@[simp, to_additive]
lemma mono_inj [mono_class Φ G H] (φ : Φ) : function.injective φ :=
mono_class.inj φ

@[simp, to_additive]
lemma epi_surj [epi_class Φ G H] (φ : Φ) : function.surjective φ :=
epi_class.surj φ

@[simp, to_additive]
lemma iso_bij [iso_class Φ G H] (φ : Φ) : function.bijective φ :=
iso_class.bij φ

@[to_additive, priority 100]
instance mono_of_iso [iso_class Φ G H] : mono_class Φ G H := {
  inj := λ f, (iso_bij f).1
}

@[to_additive, priority 100]
instance epi_of_iso [iso_class Φ G H] : epi_class Φ G H := {
  surj := λ f, (iso_bij f).2
}

-- TODO: make is_iso and so on

@[to_additive]
def iso_of_mono_surj [mono_class Φ G H] {φ : Φ} (h : function.surjective φ) :
Σ' (ψ : G ≅* H), fun_like.coe ψ = fun_like.coe φ := ⟨
  ⟨⟨fun_like.coe φ, λ x y, by simp⟩,
  ⟨by simp, h⟩⟩,
  rfl
⟩

-- Basic lemmas about homomorphisms

@[to_additive]
lemma map_one [hom_class Φ G H] (φ : Φ) : φ 1 = 1 :=
begin
  have : φ (1 * 1) = φ 1 * φ 1 := by rw map_op,
  rw one_mul at this,
  let k := φ 1,
  exact group.eq_one_of_mul_right_cancel _ this.symm
end

@[to_additive]
lemma map_inv [hom_class Φ G H] (φ : Φ) (x : G) : φ x⁻¹ = (φ x)⁻¹ :=
begin
  apply group.eq_inv_of_mul_eq_one,
  rw ← map_op,
  rw mul_left_inv,
  rw map_one
end

-- Homomorphism composition

@[to_additive]
def comp [hom_class Φ G H] [hom_class Ψ H K] (ψ : Ψ) (φ : Φ) : G →* K :=
⟨ψ ∘ φ, begin
  intros x y,
  dsimp,
  rw map_op,
  rw map_op
end⟩

infixr ` ∘* `:90 := hom.comp

@[simp, to_additive]
lemma comp_app [hom_class Φ G H] [hom_class Ψ H K] (ψ : Ψ) (φ : Φ) (a : G) :
(ψ ∘* φ) a = ψ (φ a) := rfl

@[simp, to_additive]
lemma comp_app' [hom_class Φ G H] [hom_class Ψ H K] (ψ : Ψ) (φ : Φ) (a : G) :
(ψ ∘* φ).to_fun a = ψ (φ a) := rfl

@[simp, to_additive]
lemma comp_assoc [hom_class Φ G H] [hom_class Ψ H K] [hom_class Χ K L]
(χ : Χ) (ψ : Ψ) (φ : Φ) :
χ ∘* (ψ ∘* φ) = (χ ∘* ψ) ∘* φ := rfl

@[to_additive]
def mono_comp [mono_class Φ G H] [mono_class Ψ H K] (ψ : Ψ) (φ : Φ) : G ↪* K :=
⟨ψ ∘* φ, λ x y h, mono_inj φ (mono_inj ψ h)⟩

@[to_additive]
def epi_comp [epi_class Φ G H] [epi_class Ψ H K] (ψ : Ψ) (φ : Φ) : G ↠* K :=
⟨ψ ∘* φ, begin
  intro x,
  obtain ⟨a, ha⟩ := epi_surj ψ x,
  obtain ⟨b, hb⟩ := epi_surj φ a,
  refine ⟨b, _⟩,
  simp,
  rw [hb, ha]
end⟩

@[to_additive]
def iso_comp [iso_class Φ G H] [iso_class Ψ H K] (ψ : Ψ) (φ : Φ) : G ≅* K :=
⟨ψ ∘* φ, (mono_comp ψ φ).2, (epi_comp ψ φ).2⟩

-- Common homomorphisms

@[to_additive]
def trivial_hom (G H : Type*) [group G] [group H] : G →* H :=
⟨λ x, 1, λ x y, by rw one_mul⟩

@[to_additive]
def iso_self (G : Type*) [group G] : G ≅* G :=
⟨⟨id, λ a b, rfl⟩, λ φ a, id, λ g, ⟨g, rfl⟩⟩

@[to_additive]
def inclusion_mono {G : Type*} [group G] (H : subgroup G) : H.carrier ↪* G :=
⟨⟨λ x, x, λ x y, rfl⟩, begin
  intros x y h,
  dsimp at h,
  ext,
  exact h
end⟩

-- Isomorphism is an equivalence relation.
-- Reflexivity and transitivity are handled by iso_self and iso_comp.

@[to_additive]
noncomputable def iso_symm [iso_class Φ G H] (φ : Φ) : H ≅* G :=
⟨⟨function.surj_inv (iso_class.bij φ).2,
begin
  intros x y,
  apply (iso_class.bij φ).1,
  rw map_op,
  repeat { rw function.surj_inv_eq (iso_class.bij φ).2 }
end⟩,
begin
  intros x y h,
  dsimp at h,
  have : φ (function.surj_inv _ x) = φ (function.surj_inv _ y) := by rw h,
  repeat { rwa function.surj_inv_eq (iso_class.bij φ).2 at this },
end,
begin
  intro x,
  refine ⟨φ x, _⟩,
  dsimp,
  apply function.left_inverse_surj_inv
end⟩

-- Images and kernels

@[to_additive]
def image [hom_class Φ G H] (φ : Φ) : subgroup H := {
  carrier := φ '' set.univ,
  mul_mem := begin
    rintros a b ⟨c, hc₁, hc₂⟩ ⟨d, hd₁, hd₂⟩,
    rw ← hc₂,
    rw ← hd₂,
    rw ← map_op,
    exact ⟨c * d, ⟨set.mem_univ _, rfl⟩⟩
  end,
  one_mem := ⟨1, ⟨set.mem_univ _, map_one _⟩⟩,
  inv_mem := begin
    rintros a ⟨b, hb₁, hb₂⟩,
    refine ⟨b⁻¹, ⟨set.mem_univ _, _⟩⟩,
    rw ← hb₂,
    rw map_inv
  end
}

@[simp, to_additive]
def image_def [hom_class Φ G H] (φ : Φ) : (image φ).carrier = φ '' set.univ := rfl

@[to_additive]
def kernel [hom_class Φ G H] (φ : Φ) : subgroup G := {
  carrier := {x | φ x = 1},
  mul_mem := begin
    intros a b ha hb,
    dsimp at *,
    rw map_op,
    rw ha,
    rw hb,
    simp
  end,
  one_mem := map_one φ,
  inv_mem := begin
    intros a h,
    dsimp at *,
    rw map_inv,
    rw group.inv_eq_iff_inv_eq,
    rw group.one_inv,
    exact h.symm
  end
}

@[simp, to_additive]
def kernel_def [hom_class Φ G H] (φ : Φ) : (kernel φ).carrier = {x | φ x = 1} := rfl

@[simp, to_additive]
def mem_kernel_iff [hom_class Φ G H] (x : G) (φ : Φ) : x ∈ kernel φ ↔ φ x = 1 :=
iff.rfl

@[simp, to_additive]
def kernel_trivial [hom_class Φ G H] {φ : Φ} : kernel φ = subgroup.trivial ↔ ∀ x, φ x = 1 → x = 1 :=
begin
  split,
  { intros trivial x h,
    have : x ∈ kernel φ := (mem_kernel_iff x φ).mpr h,
    rw trivial at this,
    rw ← subgroup.mem_carrier at this,
    simp at this,
    exact this },
  { intro h,
    ext,
    simp,
    split,
    { exact h x },
    { intro g, rw g, rw map_one } }
end

@[to_additive]
lemma surj_of_image_eq_univ [hom_class Φ G H] {φ : Φ} (h : image φ = subgroup.univ) : function.surjective φ :=
begin
  intro x,
  have h₁ : φ '' set.univ = set.univ,
  { rw ← subgroup.subgroup_ext_iff at h,
    exact h },
  have := set.mem_univ x,
  rw ← h₁ at this,
  obtain ⟨a, ha₁, ha₂⟩ := this,
  refine ⟨a, ha₂⟩
end

@[simp, to_additive]
theorem surj_iff_image_eq_univ [hom_class Φ G H] {φ : Φ} : function.surjective φ ↔ image φ = subgroup.univ :=
begin
  split,
  { intro h,
    rw ← subgroup.subgroup_ext_iff,
    rw subgroup.univ_def,
    rw image_def,
    exact set.image_univ_of_surjective h },
  { exact surj_of_image_eq_univ }
end

@[to_additive]
lemma inj_of_kernel_trivial [hom_class Φ G H] {φ : Φ} (h : kernel φ = subgroup.trivial) : function.injective φ :=
begin
  intros x y h₁,
  have : φ (x * y⁻¹) = 1,
  { rw [map_op, map_inv, h₁, mul_right_inv] },
  rw ← subgroup.subgroup_ext_iff at h,
  simp at h,
  rw set.ext_iff at h,
  have := (h (x * y⁻¹)).mp this,
  simp at this,
  rwa ← group.mul_inv_eq_one
end

@[simp, to_additive]
theorem inj_iff_kernel_trivial [hom_class Φ G H] {φ : Φ} : function.injective φ ↔ kernel φ = subgroup.trivial :=
begin
  split,
  { intro h,
    ext,
    simp,
    have : φ 1 = 1 := map_one φ,
    exact function.injective.eq_iff' h this },
  { exact inj_of_kernel_trivial }
end

end hom

end notes


/-
Copyright (c) 2019 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.equiv.list

/-!
# W types

Given `α : Type` and `β : α → Type`, the W type determined by this data, `W_type β`, is the
inductively defined type of trees where the nodes are labeled by elements of `α` and the children of
a node labeled `a` are indexed by elements of `β a`.

This file is currently a stub, awaiting a full development of the theory. Currently, the main result
is that if `α` is an encodable fintype and `β a` is encodable for every `a : α`, then `W_type β` is
encodable. This can be used to show the encodability of other inductive types, such as those that
are commonly used to formalize syntax, e.g. terms and expressions in a given language. The strategy
is illustrated in the example found in the file `prop_encodable` in the `archive/examples` folder of
mathlib.

## Implementation details

While the name `W_type` is somewhat verbose, it is preferable to putting a single character
identifier `W` in the root namespace.
-/

/--
Given `β : α → Type*`, `W_type β` is the type of finitely branching trees where nodes are labeled by
elements of `α` and the children of a node labeled `a` are indexed by elements of `β a`.
-/
inductive W_type {α : Type*} (β : α → Type*)
| mk (a : α) (f : β a → W_type) : W_type

instance : inhabited (W_type (λ (_ : unit), empty)) :=
⟨W_type.mk unit.star empty.elim⟩

namespace W_type

variables {α : Type*} {β : α → Type*}

/-- The canonical map to the corresponding sigma type, returning the label of a node as an
  element `a` of `α`, and the children of the node as a function `β a → W_type β`. -/
def to_sigma : W_type β → Σ a : α, β a → W_type β
| ⟨a, f⟩ := ⟨a, f⟩

/-- The canonical map from the sigma type into a `W_type`. Given a node `a : α`, and
  its children as a function `β a → W_type β`, return the corresponding tree. -/
def of_sigma : (Σ a : α, β a → W_type β) → W_type β
| ⟨a, f⟩ := W_type.mk a f

@[simp] lemma of_sigma_to_sigma : Π (w : W_type β),
  of_sigma (to_sigma w) = w
| ⟨a, f⟩ := rfl

@[simp] lemma to_sigma_of_sigma : Π (s : Σ a : α, β a → W_type β),
  to_sigma (of_sigma s) = s
| ⟨a, f⟩ := rfl

variable (β)

/-- The canonical bijection with the sigma type, showing that `W_type` is a fixed point of
  the polynomial `Σ a : α, β a → W_type β`.  -/
@[simps] def equiv_sigma : W_type β ≃ Σ a : α, β a → W_type β :=
{ to_fun := to_sigma,
  inv_fun := of_sigma,
  left_inv := of_sigma_to_sigma,
  right_inv := to_sigma_of_sigma }

variable {β}

/-- The canonical map from `W_type β` into any type `γ` given a map `(Σ a : α, β a → γ) → γ`. -/
def elim (γ : Type*) (fγ : (Σ a : α, β a → γ) → γ) : W_type β → γ
| ⟨a, f⟩ := fγ ⟨a, λ b, elim (f b)⟩

lemma elim_injective (γ : Type*) (fγ : (Σ a : α, β a → γ) → γ)
  (fγ_injective : function.injective fγ) :
  function.injective (elim γ fγ)
| ⟨a₁, f₁⟩ ⟨a₂, f₂⟩ h := begin
  obtain ⟨rfl, h⟩ := sigma.mk.inj (fγ_injective h),
  congr' with x,
  exact elim_injective (congr_fun (eq_of_heq h) x : _),
end

instance [hα : is_empty α] : is_empty (W_type β) :=
⟨λ w, W_type.rec_on w (is_empty.elim hα)⟩

lemma infinite_of_nonempty_of_is_empty (a b : α) [ha : nonempty (β a)]
  [he : is_empty (β b)] : infinite (W_type β) :=
⟨begin
  introsI hf,
  have hba : b ≠ a, from λ h, ha.elim (is_empty.elim' (show is_empty (β a), from h ▸ he)),
  refine not_injective_infinite_fintype
    (λ n : ℕ, show W_type β, from nat.rec_on n
      ⟨b, is_empty.elim' he⟩
      (λ n ih, ⟨a, λ _, ih⟩)) _,
  intros n m h,
  induction n with n ih generalizing m h,
  { cases m with m; simp * at * },
  { cases m with m,
    { simp * at * },
    { refine congr_arg nat.succ (ih _),
      simp [function.funext_iff, *] at * } }
end⟩

variables [Π a : α, fintype (β a)]

/-- The depth of a finitely branching tree. -/
def depth : W_type β → ℕ
| ⟨a, f⟩ := finset.sup finset.univ (λ n, depth (f n)) + 1

lemma depth_pos (t : W_type β) : 0 < t.depth :=
by { cases t, apply nat.succ_pos }

lemma depth_lt_depth_mk (a : α) (f : β a → W_type β) (i : β a) :
  depth (f i) < depth ⟨a, f⟩ :=
nat.lt_succ_of_le (finset.le_sup (finset.mem_univ i))

end W_type

/-
Show that W types are encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable.

We define an auxiliary type `W_type' β n` of trees of depth at most `n`, and then we show by
induction on `n` that these are all encodable. These auxiliary constructions are not interesting in
and of themselves, so we mark them as `private`.
-/

namespace encodable

@[reducible] private def W_type' {α : Type*} (β : α → Type*)
    [Π a : α, fintype (β a)] [Π a : α, encodable (β a)] (n : ℕ) :=
{ t : W_type β // t.depth ≤ n}

variables {α : Type*} {β : α → Type*} [Π a : α, fintype (β a)] [Π a : α, encodable (β a)]

private def encodable_zero : encodable (W_type' β 0) :=
let f    : W_type' β 0 → empty := λ ⟨x, h⟩, false.elim $ not_lt_of_ge h (W_type.depth_pos _),
    finv : empty → W_type' β 0 := by { intro x, cases x} in
have ∀ x, finv (f x) = x, from λ ⟨x, h⟩, false.elim $ not_lt_of_ge h (W_type.depth_pos _),
encodable.of_left_inverse f finv this

private def f (n : ℕ) : W_type' β (n + 1) → Σ a : α, β a → W_type' β n
| ⟨t, h⟩ :=
  begin
    cases t with a f,
    have h₀ : ∀ i : β a, W_type.depth (f i) ≤ n,
      from λ i, nat.le_of_lt_succ (lt_of_lt_of_le (W_type.depth_lt_depth_mk a f i) h),
    exact ⟨a, λ i : β a, ⟨f i, h₀ i⟩⟩
  end

private def finv (n : ℕ) :
  (Σ a : α, β a → W_type' β n) → W_type' β (n + 1)
| ⟨a, f⟩ :=
  let f' := λ i : β a, (f i).val in
  have W_type.depth ⟨a, f'⟩ ≤ n + 1,
    from add_le_add_right (finset.sup_le (λ b h, (f b).2)) 1,
  ⟨⟨a, f'⟩, this⟩

variables [encodable α]

private def encodable_succ (n : nat) (h : encodable (W_type' β n)) :
  encodable (W_type' β (n + 1)) :=
encodable.of_left_inverse (f n) (finv n) (by { rintro ⟨⟨_, _⟩, _⟩, refl })

/-- `W_type` is encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable. -/
instance : encodable (W_type β) :=
begin
  haveI h' : Π n, encodable (W_type' β n) :=
    λ n, nat.rec_on n encodable_zero encodable_succ,
  let f    : W_type β → Σ n, W_type' β n   := λ t, ⟨t.depth, ⟨t, le_refl _⟩⟩,
  let finv : (Σ n, W_type' β n) → W_type β := λ p, p.2.1,
  have : ∀ t, finv (f t) = t, from λ t, rfl,
  exact encodable.of_left_inverse f finv this
end

end encodable


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.upper_lower.basic
import topology.sets.closeds

/-!
# Clopen upper sets

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

In this file we define the type of clopen upper sets.
-/

open set topological_space

variables {α β : Type*} [topological_space α] [has_le α] [topological_space β] [has_le β]

/-! ### Compact open sets -/

/-- The type of clopen upper sets of a topological space. -/
structure clopen_upper_set (α : Type*) [topological_space α] [has_le α] extends clopens α :=
(upper' : is_upper_set carrier)

namespace clopen_upper_set

instance : set_like (clopen_upper_set α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

lemma upper (s : clopen_upper_set α) : is_upper_set (s : set α) := s.upper'
lemma clopen (s : clopen_upper_set α) : is_clopen (s : set α) := s.clopen'

/-- Reinterpret a upper clopen as an upper set. -/
@[simps] def to_upper_set (s : clopen_upper_set α) : upper_set α := ⟨s, s.upper⟩

@[ext] protected lemma ext {s t : clopen_upper_set α} (h : (s : set α) = t) : s = t :=
set_like.ext' h

@[simp] lemma coe_mk (s : clopens α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (clopen_upper_set α) :=
⟨λ s t, ⟨s.to_clopens ⊔ t.to_clopens, s.upper.union t.upper⟩⟩
instance : has_inf (clopen_upper_set α) :=
⟨λ s t, ⟨s.to_clopens ⊓ t.to_clopens, s.upper.inter t.upper⟩⟩
instance : has_top (clopen_upper_set α) := ⟨⟨⊤, is_upper_set_univ⟩⟩
instance : has_bot (clopen_upper_set α) := ⟨⟨⊥, is_upper_set_empty⟩⟩

instance : lattice (clopen_upper_set α) :=
set_like.coe_injective.lattice _ (λ _ _, rfl) (λ _ _, rfl)

instance : bounded_order (clopen_upper_set α) :=
bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

@[simp] lemma coe_sup (s t : clopen_upper_set α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf (s t : clopen_upper_set α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top : (↑(⊤ : clopen_upper_set α) : set α) = univ := rfl
@[simp]

instance : inhabited (clopen_upper_set α) := ⟨⊥⟩

end clopen_upper_set