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

import tactic
import ring_theory.unique_factorization_domain -- UFDs
import ring_theory.principal_ideal_domain -- PIDs
import data.mv_polynomial.comm_ring -- multivariable polys
import ring_theory.polynomial.basic
/-

# Unique Factorization Domains

Thanks to Yael on the Discord for explaining to me how to write "let R be a UFD"
in Lean! It looks like this.

-/

-- let R be a UFD
variables (R : Type) [comm_ring R] [is_domain R] [unique_factorization_monoid R]

/-

The reason we're seeing `unique_factorization_monoid` here is that
the definition of unique factorization domain never mentions addition!
So it makes sense for monoids.

-/

-- a PID is a UFD (so ℤ, k[X] etc are UFDs)
example (R : Type) [comm_ring R] [is_domain R] [is_principal_ideal_ring R] :
  unique_factorization_monoid R := by apply_instance

-- multivariate polynomials over a field in a set of variables
-- indexed by a (possibly infinite) index set I are a UFD
example (k : Type) [field k] (I : Type) :
  unique_factorization_monoid (mv_polynomial I k) := infer_instance

/-

Under the hood, the definition of UFD is a bit weird. But

A binary relation ★ is *well-founded* if you can't have an infinite decreasing
sequence a₂ ★ a₁, a₃ ★ a₂, a₄ ★ a₃, ... . For example `<` is well-founded
on the naturals, but `≤` is not, and `<` is not well-founded on the integers.

If `R` is a commutative ring, let's define `a ★ b` to mean "a strictly divides b",
i.e. that there exists a non-unit `c` such that `b = a * c`. The mathlib folks
in their wisdom decided to call `R` a `wf_dvd_monoid` ("a well-founded monoid under division")
if this relation is well-founded. For example the integers are a `wf_dvd_monoid`,
because (for example) 24 ★ 0, 12 ★ 24, 3 ★ 12, 1 ★ 3, but there's no solution to `x ★ 1`.

-/

example : wf_dvd_monoid ℤ := by apply_instance

-- In fact (if you know what this means): any Noetherian integral domain is a `wf_dvd_monoid`:

example (R : Type) [comm_ring R] [is_domain R] [is_noetherian_ring R] : wf_dvd_monoid R :=
by apply_instance

/-

...and in particular any PID is a `wf_dvd_monoid`.

The point about well-founded orders is that you can do well-founded induction
on them, which is what mathematicians often call "strong induction". In other words,
if `S` is a set and `★` is a well-founded binary relation on `S`, and if
you can prove "for all `s : S`, if `P(t)` is true for all `t ★ s` then `P(s)` is true",
then you can deduce "for all `a : S`, `P(a)` is true" (proof: if `P(a)` is not
true for all `a`, then choose some `a₁` for which it's false, and then by
hypothesis there must be `a₂ ★ a₁` for which `P(a₂)` is false, and go on
like this to obtain a contradiction to well-foundedness).

As a consequence, we can deduce that in an integral which is
a `wf_dvd_monoid`, everything nonzero factors as a unit multiplied by a product of irreducibles.
For by well-founded induction all we have to do is to check that if all proper
divisors of a nonzero element `s` factor as unit times irreducibles, then `s` does
too. If `s` is a unit or irreducible then we're done, and if it isn't then
by definition of irreducible it factors as `s = ab` with `a ★ s` and `b ★ s`;
both `a` and `b` factor into irreducibles, so `s` does too.

(Note that this argument proves that every nonzero element of every Noetherian
integral domain factors into irreducibles)

However, the factorization might not be unique (take for example `ℤ[√-5]` or your
favourite non-UFD domain which is Noetherian. The problem is that the concept of prime
and irreducible don't coincide in general integral domains.
In Lean it turns out that the definition of UFD is "`wf_dvd_monoid`, and irreducible ↔ prime",
and it's a theorem that this is mathematically equivalent to the usual definition.
The reason for this is that "irreducible ↔ prime" is precisely what you need
to get the proof that two factorizations are equivalent (pull an irreducible off
one factorization, and then use that it's prime to show that it shows up in the
other factorization).

## A theorem

Here's a theorem about UFDs.

The *height* of a prime ideal `P` in a commutative ring `R` is
the largest `n` such that there exists a strictly increasing
chain of prime ideals `P₀ ⊂ P₁ ⊂ ⋯ ⊂ Pₙ = P` (or +∞ if there
are chains of arbitrary length). The claim is that in a UFD,
all height one primes are principal.

-/

-- out of laziness we don't define height n primes in a general
-- commutative ring but just height one primes in an integral
-- domain

/-- An ideal of an integral domain is a height one prime if it's prime, it's
nonzero, and the only strictly smaller prime ideal is the zero ideal. -/
def is_height_one_prime {R : Type} [comm_ring R] [is_domain R] (P : ideal R) : Prop :=
  P.is_prime ∧ P ≠ 0 ∧ ∀ Q : ideal R, Q.is_prime ∧ Q < P → Q = 0

lemma ideal.mem_iff_associated {R : Type} [comm_ring R] (I : ideal R) {a b : R}
  (hab : associated a b) :
  a ∈ I ↔ b ∈ I :=
begin
  rcases hab with ⟨u, rfl⟩,
  refine ⟨I.mul_mem_right _, _⟩,
  intro h,
  convert I.mul_mem_right (u⁻¹ : Rˣ) h,
  simp,
end

lemma ideal.is_prime.not_one_mem {R : Type} [comm_ring R] {P : ideal R}
  (hI : P.is_prime) : (1 : R) ∉ P :=
begin
  intro h,
  apply hI.ne_top,
  rwa ideal.eq_top_iff_one,
end

lemma ideal.is_prime.mem_of_prod_mem {R : Type} [comm_ring R] {P : ideal R}
  (hP : P.is_prime) {L : multiset R} : L.prod ∈ P → ∃ x : R, x ∈ L ∧ x ∈ P :=
begin
  apply multiset.induction_on L,
  { intro h,
    rw multiset.prod_zero at h,
    cases hP.not_one_mem h, },
  { intros a L IH h,
    simp only [multiset.prod_cons] at h,
    rcases hP.mem_or_mem h with ha | hL,
    { exact ⟨a, by simp, ha⟩, },
    { obtain ⟨x, hxL, hxP⟩ := IH hL,
      exact ⟨x, multiset.mem_cons_of_mem hxL, hxP⟩, } }
end

lemma prime.ideal_span_singleton_is_prime {R : Type} [comm_ring R] {p : R}
  (hp : prime p) : (ideal.span {p} : ideal R).is_prime :=
begin
  rwa ideal.span_singleton_prime,
  exact hp.ne_zero,
end

-- All height one primes are principal in a UFD.
example (R : Type) [comm_ring R] [is_domain R] [unique_factorization_monoid R]
  (P : ideal R) : is_height_one_prime P → P.is_principal :=
begin
  rintro ⟨hPprime, hPnonzero, hht1⟩,
  -- P is nonzero so choose nonzero x ∈ P
  have hnonzero : ∃ x ∈ P, x ≠ (0 : R),
  { by_contra' h,
    apply hPnonzero,
    ext,
    simp only [ideal.zero_eq_bot, ideal.mem_bot],
    refine ⟨h x, _⟩,
    rintro rfl,
    apply zero_mem,
  },
  -- Now factor x
  rcases hnonzero with ⟨x, hxP, hx0⟩,
  -- let L be its list of prime factors (up to units)
  obtain ⟨L, hLprime, hLx⟩ := unique_factorization_monoid.exists_prime_factors x hx0,
  -- The product of the prime factors is in P
  rw ← P.mem_iff_associated hLx at hxP,
  -- so one of the prime factors (call it pi) is in P
  rcases hPprime.mem_of_prod_mem hxP with ⟨pi, hpiL, hpiP⟩,
  -- so (pi) ⊆ P
  have hpiP : ideal.span {pi} ≤ P,
  { rwa ideal.span_singleton_le_iff_mem, },
  -- So either (pi)=P or (pi) ⊂ P
  rw le_iff_eq_or_lt at hpiP,
  rcases hpiP with rfl | hcontra,
  { -- if (pi)=P we're done
    use pi,
    refl, },
  { -- and if not then pi is prime
    have hpiprime : prime pi := hLprime pi hpiL,
    -- so the ideal (pi) is prime
    have hpi : (ideal.span {pi}).is_prime := hpiprime.ideal_span_singleton_is_prime,
    -- so by our height 1 assumption (pi)=0
    specialize hht1 _ ⟨hpi, hcontra⟩,
    change _ = ⊥ at hht1,
    -- which is a contradiction as pi≠0
    rw ideal.span_eq_bot at hht1,
    specialize hht1 pi (set.mem_singleton pi),
    cases hpiprime.ne_zero hht1, }
end


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

! This file was ported from Lean 3 source module analysis.locally_convex.weak_dual
! 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.Topology.Algebra.Module.WeakDual
import Mathbin.Analysis.Normed.Field.Basic
import Mathbin.Analysis.LocallyConvex.WithSeminorms

/-!
# Weak Dual in Topological Vector Spaces

We prove that the weak topology induced by a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜` is locally
convex and we explicit give a neighborhood basis in terms of the family of seminorms `λ x, ‖B x y‖`
for `y : F`.

## Main definitions

* `linear_map.to_seminorm`: turn a linear form `f : E →ₗ[𝕜] 𝕜` into a seminorm `λ x, ‖f x‖`.
* `linear_map.to_seminorm_family`: turn a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜` into a map
`F → seminorm 𝕜 E`.

## Main statements

* `linear_map.has_basis_weak_bilin`: the seminorm balls of `B.to_seminorm_family` form a
neighborhood basis of `0` in the weak topology.
* `linear_map.to_seminorm_family.with_seminorms`: the topology of a weak space is induced by the
family of seminorm `B.to_seminorm_family`.
* `weak_bilin.locally_convex_space`: a spaced endowed with a weak topology is locally convex.

## References

* [Bourbaki, *Topological Vector Spaces*][bourbaki1987]

## Tags

weak dual, seminorm
-/

variable {𝕜 E F ι : Type _}

open Topology

section BilinForm

namespace LinearMap

variable [NormedField 𝕜] [AddCommGroup E] [Module 𝕜 E] [AddCommGroup F] [Module 𝕜 F]

/-- Construct a seminorm from a linear form `f : E →ₗ[𝕜] 𝕜` over a normed field `𝕜` by
`λ x, ‖f x‖` -/
def toSeminorm (f : E →ₗ[𝕜] 𝕜) : Seminorm 𝕜 E :=
  (normSeminorm 𝕜 𝕜).comp f
#align linear_map.to_seminorm LinearMap.toSeminorm

theorem coe_toSeminorm {f : E →ₗ[𝕜] 𝕜} : ⇑f.toSeminorm = fun x => ‖f x‖ :=
  rfl
#align linear_map.coe_to_seminorm LinearMap.coe_toSeminorm

@[simp]
theorem toSeminorm_apply {f : E →ₗ[𝕜] 𝕜} {x : E} : f.toSeminorm x = ‖f x‖ :=
  rfl
#align linear_map.to_seminorm_apply LinearMap.toSeminorm_apply

theorem toSeminorm_ball_zero {f : E →ₗ[𝕜] 𝕜} {r : ℝ} :
    Seminorm.ball f.toSeminorm 0 r = { x : E | ‖f x‖ < r } := by
  simp only [Seminorm.ball_zero_eq, to_seminorm_apply]
#align linear_map.to_seminorm_ball_zero LinearMap.toSeminorm_ball_zero

theorem toSeminorm_comp (f : F →ₗ[𝕜] 𝕜) (g : E →ₗ[𝕜] F) :
    f.toSeminorm.comp g = (f.comp g).toSeminorm :=
  by
  ext
  simp only [Seminorm.comp_apply, to_seminorm_apply, coe_comp]
#align linear_map.to_seminorm_comp LinearMap.toSeminorm_comp

/-- Construct a family of seminorms from a bilinear form. -/
def toSeminormFamily (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) : SeminormFamily 𝕜 E F := fun y =>
  (B.flip y).toSeminorm
#align linear_map.to_seminorm_family LinearMap.toSeminormFamily

@[simp]
theorem toSeminormFamily_apply {B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜} {x y} : (B.toSeminormFamily y) x = ‖B x y‖ :=
  rfl
#align linear_map.to_seminorm_family_apply LinearMap.toSeminormFamily_apply

end LinearMap

end BilinForm

section Topology

variable [NormedField 𝕜] [AddCommGroup E] [Module 𝕜 E] [AddCommGroup F] [Module 𝕜 F]

variable [Nonempty ι]

variable {B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜}

theorem LinearMap.hasBasis_weakBilin (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) :
    (𝓝 (0 : WeakBilin B)).HasBasis B.toSeminormFamily.basis_sets id :=
  by
  let p := B.to_seminorm_family
  rw [nhds_induced, nhds_pi]
  simp only [map_zero, LinearMap.zero_apply]
  have h := @Metric.nhds_basis_ball 𝕜 _ 0
  have h' := Filter.hasBasis_pi fun i : F => h
  have h'' := Filter.HasBasis.comap (fun x y => B x y) h'
  refine' h''.to_has_basis _ _
  · rintro (U : Set F × (F → ℝ)) hU
    cases' hU with hU₁ hU₂
    simp only [id.def]
    let U' := hU₁.to_finset
    by_cases hU₃ : U.fst.nonempty
    · have hU₃' : U'.nonempty := hU₁.to_finset_nonempty.mpr hU₃
      refine'
        ⟨(U'.sup p).ball 0 <| U'.inf' hU₃' U.snd,
          p.basis_sets_mem _ <|
            (Finset.lt_inf'_iff _).2 fun y hy => hU₂ y <| hU₁.mem_to_finset.mp hy,
          fun x hx y hy => _⟩
      simp only [Set.mem_preimage, Set.mem_pi, mem_ball_zero_iff]
      rw [Seminorm.mem_ball_zero] at hx
      rw [← LinearMap.toSeminormFamily_apply]
      have hyU' : y ∈ U' := (Set.Finite.mem_toFinset hU₁).mpr hy
      have hp : p y ≤ U'.sup p := Finset.le_sup hyU'
      refine' lt_of_le_of_lt (hp x) (lt_of_lt_of_le hx _)
      exact Finset.inf'_le _ hyU'
    rw [set.not_nonempty_iff_eq_empty.mp hU₃]
    simp only [Set.empty_pi, Set.preimage_univ, Set.subset_univ, and_true_iff]
    exact Exists.intro ((p 0).ball 0 1) (p.basis_sets_singleton_mem 0 one_pos)
  rintro U (hU : U ∈ p.basis_sets)
  rw [SeminormFamily.basisSets_iff] at hU
  rcases hU with ⟨s, r, hr, hU⟩
  rw [hU]
  refine' ⟨(s, fun _ => r), ⟨by simp only [s.finite_to_set], fun y hy => hr⟩, fun x hx => _⟩
  simp only [Set.mem_preimage, Set.mem_pi, Finset.mem_coe, mem_ball_zero_iff] at hx
  simp only [id.def, Seminorm.mem_ball, sub_zero]
  refine' Seminorm.finset_sup_apply_lt hr fun y hy => _
  rw [LinearMap.toSeminormFamily_apply]
  exact hx y hy
#align linear_map.has_basis_weak_bilin LinearMap.hasBasis_weakBilin

theorem LinearMap.weakBilinWithSeminorms (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) :
    WithSeminorms (LinearMap.toSeminormFamily B : F → Seminorm 𝕜 (WeakBilin B)) :=
  SeminormFamily.withSeminormsOfHasBasis _ B.hasBasis_weakBilin
#align linear_map.weak_bilin_with_seminorms LinearMap.weakBilinWithSeminorms

end Topology

section LocallyConvex

variable [NormedField 𝕜] [AddCommGroup E] [Module 𝕜 E] [AddCommGroup F] [Module 𝕜 F]

variable [Nonempty ι] [NormedSpace ℝ 𝕜] [Module ℝ E] [IsScalarTower ℝ 𝕜 E]

instance {B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜} : LocallyConvexSpace ℝ (WeakBilin B) :=
  B.weakBilinWithSeminorms.toLocallyConvexSpace

end LocallyConvex


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.clifford_algebra.basic
import data.zmod.basic
import ring_theory.graded_algebra.basic

/-!
# Results about the grading structure of the clifford algebra

The main result is `clifford_algebra.graded_algebra`, which says that the clifford algebra is a
ℤ₂-graded algebra (or "superalgebra").
-/

namespace clifford_algebra
variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]
variables {Q : quadratic_form R M}

open_locale direct_sum

variables (Q)

/-- The even or odd submodule, defined as the supremum of the even or odd powers of
`(ι Q).range`. `even_odd 0` is the even submodule, and `even_odd 1` is the odd submodule. -/
def even_odd (i : zmod 2) : submodule R (clifford_algebra Q) :=
⨆ (j : {n : ℕ // ↑n = i}), (ι Q).range ^ (j : ℕ)

lemma one_le_even_odd_zero : 1 ≤ even_odd Q 0 :=
begin
  refine le_trans _ (le_supr _ ⟨0, nat.cast_zero⟩),
  exact (pow_zero _).ge,
end

lemma range_ι_le_even_odd_one : (ι Q).range ≤ even_odd Q 1 :=
begin
  refine le_trans _ (le_supr _ ⟨1, nat.cast_one⟩),
  exact (pow_one _).ge,
end

lemma ι_mem_even_odd_one (m : M) : ι Q m ∈ even_odd Q 1 :=
range_ι_le_even_odd_one Q $ linear_map.mem_range_self _ m

lemma ι_mul_ι_mem_even_odd_zero (m₁ m₂ : M) :
  ι Q m₁ * ι Q m₂ ∈ even_odd Q 0 :=
submodule.mem_supr_of_mem ⟨2, rfl⟩ begin
  rw [subtype.coe_mk, pow_two],
  exact submodule.mul_mem_mul ((ι Q).mem_range_self m₁) ((ι Q).mem_range_self m₂),
end

lemma even_odd_mul_le (i j : zmod 2) : even_odd Q i * even_odd Q j ≤ even_odd Q (i + j) :=
begin
  simp_rw [even_odd, submodule.supr_eq_span, submodule.span_mul_span],
  apply submodule.span_mono,
  intros z hz,
  obtain ⟨x, y, hx, hy, rfl⟩ := hz,
  obtain ⟨xi, hx'⟩ := set.mem_Union.mp hx,
  obtain ⟨yi, hy'⟩ := set.mem_Union.mp hy,
  refine set.mem_Union.mpr ⟨⟨xi + yi, by simp only [nat.cast_add, xi.prop, yi.prop]⟩, _⟩,
  simp only [subtype.coe_mk, nat.cast_add, pow_add],
  exact submodule.mul_mem_mul hx' hy',
end

instance even_odd.graded_monoid : set_like.graded_monoid (even_odd Q) :=
{ one_mem := submodule.one_le.mp (one_le_even_odd_zero Q),
  mul_mem := λ i j p q hp hq, submodule.mul_le.mp (even_odd_mul_le Q _ _) _ hp _ hq }

/-- A version of `clifford_algebra.ι` that maps directly into the graded structure. This is
primarily an auxiliary construction used to provide `clifford_algebra.graded_algebra`. -/
def graded_algebra.ι : M →ₗ[R] ⨁ i : zmod 2, even_odd Q i :=
direct_sum.lof R (zmod 2) (λ i, ↥(even_odd Q i)) 1 ∘ₗ (ι Q).cod_restrict _ (ι_mem_even_odd_one Q)

lemma graded_algebra.ι_apply (m : M) :
  graded_algebra.ι Q m = direct_sum.of (λ i, ↥(even_odd Q i)) 1 (⟨ι Q m, ι_mem_even_odd_one Q m⟩) :=
rfl

lemma graded_algebra.ι_sq_scalar (m : M) :
  graded_algebra.ι Q m * graded_algebra.ι Q m = algebra_map R _ (Q m) :=
begin
  rw [graded_algebra.ι_apply, direct_sum.of_mul_of, direct_sum.algebra_map_apply],
  refine direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext rfl $ ι_sq_scalar _ _),
end

/-- The clifford algebra is graded by the even and odd parts. -/
instance graded_algebra : graded_algebra (even_odd Q) :=
graded_algebra.of_alg_hom _
  (lift _ $ ⟨graded_algebra.ι Q, graded_algebra.ι_sq_scalar Q⟩)
  -- the proof from here onward is mostly similar to the `tensor_algebra` case, with some extra
  -- handling for the `supr` in `even_odd`.
  (begin
    ext m,
    dsimp only [linear_map.comp_apply, alg_hom.to_linear_map_apply, alg_hom.comp_apply,
      alg_hom.id_apply],
    rw [lift_ι_apply, graded_algebra.ι_apply, direct_sum.submodule_coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i' x', begin
    cases x' with x' hx',
    dsimp only [subtype.coe_mk, direct_sum.lof_eq_of],
    refine submodule.supr_induction' _ (λ i x hx, _) _ (λ x y hx hy ihx ihy, _) hx',
    { obtain ⟨i, rfl⟩ := i,
      dsimp only [subtype.coe_mk] at hx,
      refine submodule.pow_induction_on' _
        (λ r, _) (λ x y i hx hy ihx ihy, _) (λ m hm i x hx ih, _) hx,
      { rw [alg_hom.commutes, direct_sum.algebra_map_apply], refl },
      { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
      { obtain ⟨_, rfl⟩ := hm,
        rw [alg_hom.map_mul, ih, lift_ι_apply, graded_algebra.ι_apply, direct_sum.of_mul_of],
        refine direct_sum.of_eq_of_graded_monoid_eq (sigma.subtype_ext _ _),
          dsimp only [graded_monoid.mk, subtype.coe_mk],
        { rw [nat.succ_eq_add_one, add_comm], refl },
        refl } },
    { rw alg_hom.map_zero,
      apply eq.symm,
      apply dfinsupp.single_eq_zero.mpr, refl, },
    { rw [alg_hom.map_add, ihx, ihy, ←map_add], refl },
  end)

lemma supr_ι_range_eq_top : (⨆ i : ℕ, (ι Q).range ^ i) = ⊤ :=
begin
  rw [← (graded_algebra.is_internal $ λ i, even_odd Q i).supr_eq_top, eq_comm],
  dunfold even_odd,
  calc    (⨆ (i : zmod 2) (j : {n // ↑n = i}), (ι Q).range ^ ↑j)
        = (⨆ (i : Σ i : zmod 2, {n : ℕ // ↑n = i}), (ι Q).range ^ (i.2 : ℕ)) : by rw supr_sigma
    ... = (⨆ (i : ℕ), (ι Q).range ^ i)
        : function.surjective.supr_congr (λ i, i.2) (λ i, ⟨⟨_, i, rfl⟩, rfl⟩) (λ _, rfl),
end

lemma even_odd_is_compl : is_compl (even_odd Q 0) (even_odd Q 1) :=
(graded_algebra.is_internal (even_odd Q)).is_compl zero_ne_one $ begin
  have : (finset.univ : finset (zmod 2)) = {0, 1} := rfl,
  simpa using congr_arg (coe : finset (zmod 2) → set (zmod 2)) this,
end

/-- To show a property is true on the even or odd part, it suffices to show it is true on the
scalars or vectors (respectively), closed under addition, and under left-multiplication by a pair
of vectors. -/
@[elab_as_eliminator]
lemma even_odd_induction (n : zmod 2) {P : Π x, x ∈ even_odd Q n → Prop}
  (hr : ∀ v (h : v ∈ (ι Q).range ^ n.val),
    P v (submodule.mem_supr_of_mem ⟨n.val, n.nat_cast_zmod_val⟩ h))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add n ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q n) : P x hx :=
begin
  apply submodule.supr_induction' _ _ (hr 0 (submodule.zero_mem _)) @hadd,
  refine subtype.rec _,
  simp_rw [subtype.coe_mk, zmod.nat_coe_zmod_eq_iff, add_comm n.val],
  rintros n' ⟨k, rfl⟩ xv,
  simp_rw [pow_add, pow_mul],
  refine submodule.mul_induction_on' _ _,
  { intros a ha b hb,
    refine submodule.pow_induction_on' ((ι Q).range ^ 2) _ _ _ ha,
    { intro r,
      simp_rw ←algebra.smul_def,
      exact hr _ (submodule.smul_mem _ _ hb), },
    { intros x y n hx hy,
      simp_rw add_mul,
      apply hadd, },
    { intros x hx n y hy ihy,
      revert hx,
      simp_rw pow_two,
      refine submodule.mul_induction_on' _ _,
      { simp_rw linear_map.mem_range,
        rintros _ ⟨m₁, rfl⟩ _ ⟨m₂, rfl⟩,
        simp_rw mul_assoc _ y b,
        refine hιι_mul _ _ ihy, },
      { intros x hx y hy ihx ihy,
        simp_rw add_mul,
        apply hadd ihx ihy } } },
  { intros x y hx hy,
    apply hadd }
end

/-- To show a property is true on the even parts, it suffices to show it is true on the
scalars, closed under addition, and under left-multiplication by a pair of vectors. -/
@[elab_as_eliminator]
lemma even_induction  {P : Π x, x ∈ even_odd Q 0 → Prop}
  (hr : ∀ r : R, P (algebra_map _ _ r) (set_like.has_graded_one.algebra_map_mem _ _))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add 0 ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q 0) : P x hx :=
begin
  refine even_odd_induction Q 0 (λ rx, _) @hadd hιι_mul x hx,
  simp_rw [zmod.val_zero, pow_zero],
  rintro ⟨r, rfl⟩,
  exact hr r,
end

/-- To show a property is true on the odd parts, it suffices to show it is true on the
vectors, closed under addition, and under left-multiplication by a pair of vectors. -/
@[elab_as_eliminator]
lemma odd_induction {P : Π x, x ∈ even_odd Q 1 → Prop}
  (hι : ∀ v, P (ι Q v) (ι_mem_even_odd_one _ _))
  (hadd : ∀ {x y hx hy}, P x hx → P y hy → P (x + y) (submodule.add_mem _ hx hy))
  (hιι_mul : ∀ m₁ m₂ {x hx}, P x hx → P (ι Q m₁ * ι Q m₂ * x)
    (zero_add (1 : zmod 2) ▸ set_like.graded_monoid.mul_mem (ι_mul_ι_mem_even_odd_zero Q m₁ m₂) hx))
  (x : clifford_algebra Q) (hx : x ∈ even_odd Q 1) : P x hx :=
begin
  refine even_odd_induction Q 1 (λ ιv, _) @hadd hιι_mul x hx,
  simp_rw [zmod.val_one, pow_one],
  rintro ⟨v, rfl⟩,
  exact hι v,
end

end clifford_algebra


import group.theorems -- basic interface for groups
import for_mathlib.finsum
import group.group_powers
/-!

Basic definitions for subgroups in group theory.
Not for the mathematician beginner.

-/

-- We're always overwriting group theory here so we always work in
-- a namespace
namespace mygroup

open mygroup.group

/- subgroups (bundled) -/

/-- A subgroup of a group G is a subset containing 1
and closed under multiplication and inverse. -/
structure subgroup (G : Type) [group G] :=
(carrier : set G)
(one_mem' : (1 : G) ∈ carrier)
(mul_mem' {x y} : x ∈ carrier → y ∈ carrier → x * y ∈ carrier)
(inv_mem' {x} : x ∈ carrier → x⁻¹ ∈ carrier)

-- Defintion of normal subgroup (in a bundled form)
structure normal (G : Type) [group G] extends subgroup G :=
(conj_mem' : ∀ n, n ∈ carrier → ∀ g : G, g * n * g⁻¹ ∈ carrier)

-- we put dashes in all the names, because we'll define
-- non-dashed versions which don't mention `carrier` at all
-- and just talk about elements of the subgroup.

namespace subgroup

variables {G : Type} [group G] (H : subgroup G)

-- a subgroup can be thought of as a subset.
-- Let's not use this for now.
-- instance : has_coe (subgroup G) (set G) := ⟨subgroup.carrier⟩

-- Instead let's define ∈ directly
instance : has_mem G (subgroup G) := ⟨λ m H, m ∈ H.carrier⟩

-- subgroups form a lattice and we might want to prove this
-- later on?
instance : has_le (subgroup G) := ⟨λ S T, S.carrier ⊆ T.carrier⟩

/-- Two subgroups are equal if the underlying subsets are equal. -/
theorem ext' {H K : subgroup G} (h : H.carrier = K.carrier) : H = K :=
by cases H; cases K; congr'

/-- Two subgroups are equal if they have the same elements. -/
theorem ext {H K : subgroup G}
  (h : ∀ x, x ∈ H ↔ x ∈ K) : H = K := ext' $ set.ext h

lemma mem_coe {g : G} : g ∈ H.carrier ↔ g ∈ H := iff.rfl

/-- Two subgroups are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {H K : subgroup G} :
  H.carrier = K.carrier ↔ H = K :=
⟨ext', λ h, h ▸ rfl⟩

attribute [ext] subgroup.ext

/-- A subgroup contains the group's 1. -/
theorem one_mem : (1 : G) ∈ H := H.one_mem'

/-- A subgroup is closed under multiplication. -/
theorem mul_mem {x y : G} : x ∈ H → y ∈ H → x * y ∈ H := subgroup.mul_mem' _

/-- A subgroup is closed under inverse -/
theorem inv_mem {x : G} : x ∈ H → x⁻¹ ∈ H := subgroup.inv_mem' _

theorem pow_mem {x : G} {n : ℤ} : x ∈ H → ⦃n⦄^x ∈ H :=
begin
  intro hx,
  apply int.induction_on n,
  { rw group.zero_pow, exact H.one_mem },
  { intros i hi,
    convert H.mul_mem hi hx,
    rw group.pow_add,
    rw group.one_pow,
  },
  { intros i hi,
    convert H.mul_mem hi (H.inv_mem hx),
    rw ←group.pow_neg_one_inv,
    rw ←group.pow_add,
    congr'
  }
end

@[simp] theorem inv_mem_iff {x :G} : x⁻¹ ∈ H ↔ x ∈ H := ⟨λ hx, group.inv_inv x ▸ H.inv_mem hx , H.inv_mem ⟩

-- Coersion to group
-- Coercion from subgroup to underlying type

instance : has_coe (subgroup G) (set G) := ⟨subgroup.carrier⟩

lemma mem_coe' {g : G} : g ∈ (H : set G) ↔ g ∈ H := iff.rfl

instance of_subgroup (K : subgroup G) : group ↥K :=
{ mul := λ a b, ⟨a.1 * b.1, K.mul_mem' a.2 b.2⟩,
  one := ⟨1, K.one_mem'⟩,
  inv := λ a, ⟨a⁻¹, K.inv_mem' a.2⟩,
  mul_assoc := λ a b c, by { cases a, cases b, cases c, refine subtype.ext _,
    apply group.mul_assoc },
  one_mul := λ a, by { cases a, apply subtype.ext, apply group.one_mul },
  mul_left_inv := λ a, by { cases a, apply subtype.ext,
    apply group.mul_left_inv } }

-- This is so I can write K : subgroup G
instance normal_to_subgroup : has_coe (normal G) (subgroup G) :=
  ⟨λ K, K.to_subgroup⟩

-- This saves me from writting m ∈ (K : subgroup G) every time
instance normal_has_mem : has_mem G (normal G) := ⟨λ m K, m ∈ K.carrier⟩

instance normal_to_set : has_coe (normal G) (set G) := ⟨λ K, K.carrier⟩

/-- Returns index of a subgroup in a group -/
noncomputable def index (H : subgroup G) : ℕ := fincard G / fincard H

/-- `index' H J` returns the index of J in H -/
noncomputable def index'(H : subgroup G) (J : subgroup G): ℕ := fincard H / fincard J

-- Defining cosets thats used in some lemmas
def lcoset (g : G) (K : subgroup G) := {s : G | ∃ k ∈ K, s = g * k}
def rcoset (g : G) (K : subgroup G) := {s : G | ∃ k ∈ K, s = k * g}
notation g ` ⋆ ` :70 H :70 := lcoset g H
notation H ` ⋆ ` :70 g :70 := rcoset g H

attribute [reducible] lcoset rcoset

-- Defining the the center of a group is a subgroup
/- Should probably define it as a normal subgroup
def center (G : Type) [group G] : subgroup G :=
{ carrier  := {g : G | ∀ k : G, k * g = g * k},
  one_mem' := λ k, by simp,
  mul_mem' := λ x y hx hy k, by rw [←group.mul_assoc, hx, group.mul_assoc, hy, ←group.mul_assoc],
  inv_mem' := λ x hx k,
  begin
    apply group.mul_left_cancel x,
    iterate 2 {rw ←group.mul_assoc},
    rw [←hx, group.mul_right_inv, group.mul_assoc, group.mul_right_inv], simp
  end
} -/

end subgroup

namespace normal

variables {G : Type} [group G]

lemma conj_mem  (N : normal G) (n : G) (hn : n ∈ N) (g : G) :
  g * n * g⁻¹ ∈ N := N.conj_mem' n hn g

@[ext] lemma ext (A B : normal G) (h : ∀ g, g ∈ A ↔ g ∈ B) : A = B :=
begin
  cases A with A, cases B with B, cases A with A, cases B with B,
  suffices : A = B,
    simp * at *,
  ext x, exact h x
end

instance of_normal (N : normal G) : group ↥N :=
  subgroup.of_subgroup (N : subgroup G)

end normal

end mygroup


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

import group_theory.submonoid.pointwise

/-!

# Submonoid of inverses

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

Given a submonoid `N` of a monoid `M`, we define the submonoid `N.left_inv` as the submonoid of
left inverses of `N`. When `M` is commutative, we may define `from_comm_left_inv : N.left_inv →* N`
since the inverses are unique. When `N ≤ is_unit.submonoid M`, this is precisely
the pointwise inverse of `N`, and we may define `left_inv_equiv : S.left_inv ≃* S`.

For the pointwise inverse of submonoids of groups, please refer to
`group_theory.submonoid.pointwise`.

## TODO

Define the submonoid of right inverses and two-sided inverses.
See the comments of #10679 for a possible implementation.

-/
variables {M : Type*}

namespace submonoid

@[to_additive]
noncomputable instance [monoid M] : group (is_unit.submonoid M) :=
{ inv := λ x, ⟨_, (x.prop.unit⁻¹).is_unit⟩,
  mul_left_inv := λ x, subtype.eq x.prop.unit.inv_val,
 ..(show monoid (is_unit.submonoid M), by apply_instance) }

@[to_additive]
noncomputable instance [comm_monoid M] : comm_group (is_unit.submonoid M) :=
{ mul_comm := λ a b, mul_comm a b,
 ..(show group (is_unit.submonoid M), by apply_instance) }

@[to_additive] lemma is_unit.submonoid.coe_inv [monoid M] (x : is_unit.submonoid M) :
  ↑(x⁻¹) = (↑x.prop.unit⁻¹ : M) := rfl

section monoid

variables [monoid M] (S : submonoid M)

/-- `S.left_inv` is the submonoid containing all the left inverses of `S`. -/
@[to_additive "`S.left_neg` is the additive submonoid containing all the left additive inverses
of `S`."]
def left_inv : submonoid M :=
{ carrier := { x : M | ∃ y : S, x * y = 1 },
  one_mem' := ⟨1, mul_one 1⟩,
  mul_mem' := λ a b ⟨a', ha⟩ ⟨b', hb⟩,
    ⟨b' * a', by rw [coe_mul, ← mul_assoc, mul_assoc a, hb, mul_one, ha]⟩ }

@[to_additive]

@[to_additive]
lemma unit_mem_left_inv (x : Mˣ) (hx : (x : M) ∈ S) : ((x⁻¹ : _) : M) ∈ S.left_inv :=
⟨⟨x, hx⟩, x.inv_val⟩

@[to_additive]
lemma left_inv_left_inv_eq (hS : S ≤ is_unit.submonoid M) : S.left_inv.left_inv = S :=
begin
  refine le_antisymm S.left_inv_left_inv_le _,
  intros x hx,
  have : x = ((hS hx).unit⁻¹⁻¹ : Mˣ) := by { rw [inv_inv (hS hx).unit], refl },
  rw this,
  exact S.left_inv.unit_mem_left_inv _ (S.unit_mem_left_inv _ hx)
end

/-- The function from `S.left_inv` to `S` sending an element to its right inverse in `S`.
This is a `monoid_hom` when `M` is commutative. -/
@[to_additive "The function from `S.left_add` to `S` sending an element to its right additive
inverse in `S`. This is an `add_monoid_hom` when `M` is commutative."]
noncomputable
def from_left_inv : S.left_inv → S := λ x, x.prop.some

@[simp, to_additive]
lemma mul_from_left_inv (x : S.left_inv) : (x : M) * S.from_left_inv x = 1 :=
x.prop.some_spec

@[simp, to_additive] lemma from_left_inv_one : S.from_left_inv 1 = 1 :=
(one_mul _).symm.trans (subtype.eq $ S.mul_from_left_inv 1)

end monoid

section comm_monoid

variables [comm_monoid M] (S : submonoid M)

@[simp, to_additive]
lemma from_left_inv_mul (x : S.left_inv) : (S.from_left_inv x : M) * x = 1 :=
by rw [mul_comm, mul_from_left_inv]

@[to_additive]
lemma left_inv_le_is_unit : S.left_inv ≤ is_unit.submonoid M :=
λ x ⟨y, hx⟩, ⟨⟨x, y, hx, mul_comm x y ▸ hx⟩, rfl⟩

@[to_additive]
lemma from_left_inv_eq_iff (a : S.left_inv) (b : M) :
  (S.from_left_inv a : M) = b ↔ (a : M) * b = 1 :=
by rw [← is_unit.mul_right_inj (left_inv_le_is_unit _ a.prop), S.mul_from_left_inv, eq_comm]

/-- The `monoid_hom` from `S.left_inv` to `S` sending an element to its right inverse in `S`. -/
@[to_additive "The `add_monoid_hom` from `S.left_neg` to `S` sending an element to its
right additive inverse in `S`.", simps]
noncomputable
def from_comm_left_inv : S.left_inv →* S :=
{ to_fun := S.from_left_inv,
  map_one' := S.from_left_inv_one,
  map_mul' := λ x y, subtype.ext $
    by rw [from_left_inv_eq_iff, mul_comm x, submonoid.coe_mul, submonoid.coe_mul, mul_assoc,
      ← mul_assoc (x : M), mul_from_left_inv, one_mul, mul_from_left_inv] }

variable (hS : S ≤ is_unit.submonoid M)

include hS

/-- The submonoid of pointwise inverse of `S` is `mul_equiv` to `S`. -/
@[to_additive "The additive submonoid of pointwise additive inverse of `S` is
`add_equiv` to `S`.", simps apply]
noncomputable
def left_inv_equiv : S.left_inv ≃* S :=
{ inv_fun := λ x, by { choose x' hx using (hS x.prop), exact ⟨x'.inv, x, hx ▸ x'.inv_val⟩ },
  left_inv := λ x, subtype.eq $ begin
      dsimp, generalize_proofs h, rw ← h.some.mul_left_inj,
      exact h.some.inv_val.trans ((S.mul_from_left_inv x).symm.trans (by rw h.some_spec)),
  end,
  right_inv := λ x, by { dsimp, ext, rw [from_left_inv_eq_iff], convert (hS x.prop).some.inv_val,
    exact (hS x.prop).some_spec.symm },
  ..S.from_comm_left_inv }

@[simp, to_additive] lemma from_left_inv_left_inv_equiv_symm (x : S) :
  S.from_left_inv ((S.left_inv_equiv hS).symm x) = x := (S.left_inv_equiv hS).right_inv x

@[simp, to_additive] lemma left_inv_equiv_symm_from_left_inv (x : S.left_inv) :
  (S.left_inv_equiv hS).symm (S.from_left_inv x) = x := (S.left_inv_equiv hS).left_inv x

@[to_additive]
lemma left_inv_equiv_mul (x : S.left_inv) : (S.left_inv_equiv hS x : M) * x = 1 := by simp

@[to_additive]
lemma mul_left_inv_equiv (x : S.left_inv) : (x : M) * S.left_inv_equiv hS x = 1 := by simp

@[simp, to_additive] lemma left_inv_equiv_symm_mul (x : S) :
  ((S.left_inv_equiv hS).symm x : M) * x = 1 :=
by { convert S.mul_left_inv_equiv hS ((S.left_inv_equiv hS).symm x), simp }

@[simp, to_additive] lemma mul_left_inv_equiv_symm (x : S) :
  (x : M) * (S.left_inv_equiv hS).symm x = 1 :=
by { convert S.left_inv_equiv_mul hS ((S.left_inv_equiv hS).symm x), simp }

end comm_monoid

section group

variables [group M] (S : submonoid M)

open_locale pointwise

@[to_additive] lemma left_inv_eq_inv : S.left_inv = S⁻¹ :=
submonoid.ext $ λ x,
  ⟨λ h, submonoid.mem_inv.mpr ((inv_eq_of_mul_eq_one_right h.some_spec).symm ▸ h.some.prop),
    λ h, ⟨⟨_, h⟩, mul_right_inv _⟩⟩

@[simp, to_additive] lemma from_left_inv_eq_inv (x : S.left_inv) :
  (S.from_left_inv x : M) = x⁻¹ :=
by rw [← mul_right_inj (x : M), mul_right_inv, mul_from_left_inv]

end group

section comm_group

variables [comm_group M] (S : submonoid M) (hS : S ≤ is_unit.submonoid M)

@[simp, to_additive] lemma left_inv_equiv_symm_eq_inv (x : S) :
  ((S.left_inv_equiv hS).symm x : M) = x⁻¹ :=
by rw [← mul_right_inj (x : M), mul_right_inv, mul_left_inv_equiv_symm]

end comm_group

end submonoid


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.algebra.classes
! leanprover-community/mathlib commit 31f3a46d7c18d6b2255a72df4f9d62644145d83b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Logic
import Leanbin.Init.Data.Ordering.Basic

universe u v

/-!
# Unbundled algebra classes

These classes and the `@[algebra]` attribute are part of an incomplete refactor described
[here on the github Wiki](https://github.com/leanprover/lean/wiki/Refactoring-structures#encoding-the-algebraic-hierarchy-1).

By themselves, these classes are not good replacements for the `monoid` / `group` etc structures
provided by mathlib, as they are not discoverable by `simp` unlike the current lemmas due to there
being little to index on. The Wiki page linked above describes an algebraic normalizer, but it is not
implemented.
-/

#print IsSymmOp /-
class IsSymmOp (α : Type u) (β : outParam (Type v)) (op : α → α → β) : Prop where
  symm_op : ∀ a b, op a b = op b a
#align is_symm_op IsSymmOp
-/

#print IsCommutative /-
class IsCommutative (α : Type u) (op : α → α → α) : Prop where
  comm : ∀ a b, op a b = op b a
#align is_commutative IsCommutative
-/

#print isSymmOp_of_isCommutative /-
instance (priority := 100) isSymmOp_of_isCommutative (α : Type u) (op : α → α → α)
    [IsCommutative α op] : IsSymmOp α α op where symm_op := IsCommutative.comm
#align is_symm_op_of_is_commutative isSymmOp_of_isCommutative
-/

#print IsAssociative /-
class IsAssociative (α : Type u) (op : α → α → α) : Prop where
  and_assoc : ∀ a b c, op (op a b) c = op a (op b c)
#align is_associative IsAssociative
-/

#print IsLeftId /-
class IsLeftId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  left_id : ∀ a, op o a = a
#align is_left_id IsLeftId
-/

#print IsRightId /-
class IsRightId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  right_id : ∀ a, op a o = a
#align is_right_id IsRightId
-/

class IsLeftNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  left_null : ∀ a, op o a = o
#align is_left_null IsLeftNull

class IsRightNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  right_null : ∀ a, op a o = o
#align is_right_null IsRightNull

#print IsLeftCancel /-
class IsLeftCancel (α : Type u) (op : α → α → α) : Prop where
  left_cancel : ∀ a b c, op a b = op a c → b = c
#align is_left_cancel IsLeftCancel
-/

#print IsRightCancel /-
class IsRightCancel (α : Type u) (op : α → α → α) : Prop where
  right_cancel : ∀ a b c, op a b = op c b → a = c
#align is_right_cancel IsRightCancel
-/

#print IsIdempotent /-
class IsIdempotent (α : Type u) (op : α → α → α) : Prop where
  idempotent : ∀ a, op a a = a
#align is_idempotent IsIdempotent
-/

class IsLeftDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
  left_distrib : ∀ a b c, op₁ a (op₂ b c) = op₂ (op₁ a b) (op₁ a c)
#align is_left_distrib IsLeftDistrib

class IsRightDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
  right_distrib : ∀ a b c, op₁ (op₂ a b) c = op₂ (op₁ a c) (op₁ b c)
#align is_right_distrib IsRightDistrib

class IsLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
  Prop where
  left_inv : ∀ a, op (inv a) a = o
#align is_left_inv IsLeftInv

class IsRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
  Prop where
  right_inv : ∀ a, op a (inv a) = o
#align is_right_inv IsRightInv

class IsCondLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
  (p : outParam <| α → Prop) : Prop where
  left_inv : ∀ a, p a → op (inv a) a = o
#align is_cond_left_inv IsCondLeftInv

class IsCondRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
  (p : outParam <| α → Prop) : Prop where
  right_inv : ∀ a, p a → op a (inv a) = o
#align is_cond_right_inv IsCondRightInv

class IsDistinct (α : Type u) (a : α) (b : α) : Prop where
  distinct : a ≠ b
#align is_distinct IsDistinct

#print IsIrrefl /-
/-
-- The following type class doesn't seem very useful, a regular simp lemma should work for this.
class is_inv (α : Type u) (β : Type v) (f : α → β) (g : out β → α) : Prop :=
(inv : ∀ a, g (f a) = a)

-- The following one can also be handled using a regular simp lemma
class is_idempotent (α : Type u) (f : α → α) : Prop :=
(idempotent : ∀ a, f (f a) = f a)
-/
/-- `is_irrefl X r` means the binary relation `r` on `X` is irreflexive (that is, `r x x` never
holds). -/
class IsIrrefl (α : Type u) (r : α → α → Prop) : Prop where
  irrefl : ∀ a, ¬r a a
#align is_irrefl IsIrrefl
-/

#print IsRefl /-
/-- `is_refl X r` means the binary relation `r` on `X` is reflexive. -/
class IsRefl (α : Type u) (r : α → α → Prop) : Prop where
  refl : ∀ a, r a a
#align is_refl IsRefl
-/

#print IsSymm /-
/-- `is_symm X r` means the binary relation `r` on `X` is symmetric. -/
class IsSymm (α : Type u) (r : α → α → Prop) : Prop where
  symm : ∀ a b, r a b → r b a
#align is_symm IsSymm
-/

#print isSymmOp_of_isSymm /-
/-- The opposite of a symmetric relation is symmetric. -/
instance (priority := 100) isSymmOp_of_isSymm (α : Type u) (r : α → α → Prop) [IsSymm α r] :
    IsSymmOp α Prop r where symm_op a b := propext <| Iff.intro (IsSymm.symm a b) (IsSymm.symm b a)
#align is_symm_op_of_is_symm isSymmOp_of_isSymm
-/

#print IsAsymm /-
/-- `is_asymm X r` means that the binary relation `r` on `X` is asymmetric, that is,
`r a b → ¬ r b a`. -/
class IsAsymm (α : Type u) (r : α → α → Prop) : Prop where
  asymm : ∀ a b, r a b → ¬r b a
#align is_asymm IsAsymm
-/

#print IsAntisymm /-
/-- `is_antisymm X r` means the binary relation `r` on `X` is antisymmetric. -/
class IsAntisymm (α : Type u) (r : α → α → Prop) : Prop where
  antisymm : ∀ a b, r a b → r b a → a = b
#align is_antisymm IsAntisymm
-/

#print IsTrans /-
/-- `is_trans X r` means the binary relation `r` on `X` is transitive. -/
class IsTrans (α : Type u) (r : α → α → Prop) : Prop where
  trans : ∀ a b c, r a b → r b c → r a c
#align is_trans IsTrans
-/

#print IsTotal /-
/-- `is_total X r` means that the binary relation `r` on `X` is total, that is, that for any
`x y : X` we have `r x y` or `r y x`.-/
class IsTotal (α : Type u) (r : α → α → Prop) : Prop where
  Total : ∀ a b, r a b ∨ r b a
#align is_total IsTotal
-/

#print IsPreorder /-
/-- `is_preorder X r` means that the binary relation `r` on `X` is a pre-order, that is, reflexive
and transitive. -/
class IsPreorder (α : Type u) (r : α → α → Prop) extends IsRefl α r, IsTrans α r : Prop
#align is_preorder IsPreorder
-/

#print IsTotalPreorder /-
/-- `is_total_preorder X r` means that the binary relation `r` on `X` is total and a preorder. -/
class IsTotalPreorder (α : Type u) (r : α → α → Prop) extends IsTrans α r, IsTotal α r : Prop
#align is_total_preorder IsTotalPreorder
-/

#print isTotalPreorder_isPreorder /-
/-- Every total pre-order is a pre-order. -/
instance isTotalPreorder_isPreorder (α : Type u) (r : α → α → Prop) [s : IsTotalPreorder α r] :
    IsPreorder α r where
  trans := s.trans
  refl a := Or.elim (@IsTotal.total _ r _ a a) id id
#align is_total_preorder_is_preorder isTotalPreorder_isPreorder
-/

#print IsPartialOrder /-
/-- `is_partial_order X r` means that the binary relation `r` on `X` is a partial order, that is,
`is_preorder X r` and `is_antisymm X r`. -/
class IsPartialOrder (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsAntisymm α r : Prop
#align is_partial_order IsPartialOrder
-/

#print IsLinearOrder /-
/-- `is_linear_order X r` means that the binary relation `r` on `X` is a linear order, that is,
`is_partial_order X r` and `is_total X r`. -/
class IsLinearOrder (α : Type u) (r : α → α → Prop) extends IsPartialOrder α r, IsTotal α r : Prop
#align is_linear_order IsLinearOrder
-/

#print IsEquiv /-
/-- `is_equiv X r` means that the binary relation `r` on `X` is an equivalence relation, that
is, `is_preorder X r` and `is_symm X r`. -/
class IsEquiv (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsSymm α r : Prop
#align is_equiv IsEquiv
-/

/-- `is_per X r` means that the binary relation `r` on `X` is a partial equivalence relation, that
is, `is_symm X r` and `is_trans X r`. -/
class IsPer (α : Type u) (r : α → α → Prop) extends IsSymm α r, IsTrans α r : Prop
#align is_per IsPer

#print IsStrictOrder /-
/-- `is_strict_order X r` means that the binary relation `r` on `X` is a strict order, that is,
`is_irrefl X r` and `is_trans X r`. -/
class IsStrictOrder (α : Type u) (r : α → α → Prop) extends IsIrrefl α r, IsTrans α r : Prop
#align is_strict_order IsStrictOrder
-/

#print IsIncompTrans /-
/-- `is_incomp_trans X lt` means that for `lt` a binary relation on `X`, the incomparable relation
`λ a b, ¬ lt a b ∧ ¬ lt b a` is transitive. -/
class IsIncompTrans (α : Type u) (lt : α → α → Prop) : Prop where
  incomp_trans : ∀ a b c, ¬lt a b ∧ ¬lt b a → ¬lt b c ∧ ¬lt c b → ¬lt a c ∧ ¬lt c a
#align is_incomp_trans IsIncompTrans
-/

#print IsStrictWeakOrder /-
/-- `is_strict_weak_order X lt` means that the binary relation `lt` on `X` is a strict weak order,
that is, `is_strict_order X lt` and `is_incomp_trans X lt`. -/
class IsStrictWeakOrder (α : Type u) (lt : α → α → Prop) extends IsStrictOrder α lt,
  IsIncompTrans α lt : Prop
#align is_strict_weak_order IsStrictWeakOrder
-/

#print IsTrichotomous /-
/-- `is_trichotomous X lt` means that the binary relation `lt` on `X` is trichotomous, that is,
either `lt a b` or `a = b` or `lt b a` for any `a` and `b`. -/
class IsTrichotomous (α : Type u) (lt : α → α → Prop) : Prop where
  trichotomous : ∀ a b, lt a b ∨ a = b ∨ lt b a
#align is_trichotomous IsTrichotomous
-/

#print IsStrictTotalOrder /-
/-- `is_strict_total_order X lt` means that the binary relation `lt` on `X` is a strict total order,
that is, `is_trichotomous X lt` and `is_strict_order X lt`. -/
class IsStrictTotalOrder (α : Type u) (lt : α → α → Prop) extends IsTrichotomous α lt,
  IsStrictOrder α lt : Prop
#align is_strict_total_order IsStrictTotalOrder
-/

#print eq_isEquiv /-
/-- Equality is an equivalence relation. -/
instance eq_isEquiv (α : Type u) : IsEquiv α (· = ·)
    where
  symm := @Eq.symm _
  trans := @Eq.trans _
  refl := Eq.refl
#align eq_is_equiv eq_isEquiv
-/

section

variable {α : Type u} {r : α → α → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => r

#print irrefl /-
theorem irrefl [IsIrrefl α r] (a : α) : ¬a≺a :=
  IsIrrefl.irrefl a
#align irrefl irrefl
-/

#print refl /-
theorem refl [IsRefl α r] (a : α) : a≺a :=
  IsRefl.refl a
#align refl refl
-/

#print trans /-
theorem trans [IsTrans α r] {a b c : α} : a≺b → b≺c → a≺c :=
  IsTrans.trans _ _ _
#align trans trans
-/

#print symm /-
theorem symm [IsSymm α r] {a b : α} : a≺b → b≺a :=
  IsSymm.symm _ _
#align symm symm
-/

#print antisymm /-
theorem antisymm [IsAntisymm α r] {a b : α} : a≺b → b≺a → a = b :=
  IsAntisymm.antisymm _ _
#align antisymm antisymm
-/

#print asymm /-
theorem asymm [IsAsymm α r] {a b : α} : a≺b → ¬b≺a :=
  IsAsymm.asymm _ _
#align asymm asymm
-/

#print trichotomous /-
theorem trichotomous [IsTrichotomous α r] : ∀ a b : α, a≺b ∨ a = b ∨ b≺a :=
  IsTrichotomous.trichotomous
#align trichotomous trichotomous
-/

#print incomp_trans /-
theorem incomp_trans [IsIncompTrans α r] {a b c : α} : ¬a≺b ∧ ¬b≺a → ¬b≺c ∧ ¬c≺b → ¬a≺c ∧ ¬c≺a :=
  IsIncompTrans.incomp_trans _ _ _
#align incomp_trans incomp_trans
-/

#print isAsymm_of_isTrans_of_isIrrefl /-
instance (priority := 90) isAsymm_of_isTrans_of_isIrrefl [IsTrans α r] [IsIrrefl α r] :
    IsAsymm α r :=
  ⟨fun a b h₁ h₂ => absurd (trans h₁ h₂) (irrefl a)⟩
#align is_asymm_of_is_trans_of_is_irrefl isAsymm_of_isTrans_of_isIrrefl
-/

section ExplicitRelationVariants

variable (r)

#print irrefl_of /-
@[elab_without_expected_type]
theorem irrefl_of [IsIrrefl α r] (a : α) : ¬a≺a :=
  irrefl a
#align irrefl_of irrefl_of
-/

#print refl_of /-
@[elab_without_expected_type]
theorem refl_of [IsRefl α r] (a : α) : a≺a :=
  refl a
#align refl_of refl_of
-/

#print trans_of /-
@[elab_without_expected_type]
theorem trans_of [IsTrans α r] {a b c : α} : a≺b → b≺c → a≺c :=
  trans
#align trans_of trans_of
-/

#print symm_of /-
@[elab_without_expected_type]
theorem symm_of [IsSymm α r] {a b : α} : a≺b → b≺a :=
  symm
#align symm_of symm_of
-/

#print asymm_of /-
@[elab_without_expected_type]
theorem asymm_of [IsAsymm α r] {a b : α} : a≺b → ¬b≺a :=
  asymm
#align asymm_of asymm_of
-/

#print total_of /-
@[elab_without_expected_type]
theorem total_of [IsTotal α r] (a b : α) : a≺b ∨ b≺a :=
  IsTotal.total _ _
#align total_of total_of
-/

#print trichotomous_of /-
@[elab_without_expected_type]
theorem trichotomous_of [IsTrichotomous α r] : ∀ a b : α, a≺b ∨ a = b ∨ b≺a :=
  trichotomous
#align trichotomous_of trichotomous_of
-/

#print incomp_trans_of /-
@[elab_without_expected_type]
theorem incomp_trans_of [IsIncompTrans α r] {a b c : α} : ¬a≺b ∧ ¬b≺a → ¬b≺c ∧ ¬c≺b → ¬a≺c ∧ ¬c≺a :=
  incomp_trans
#align incomp_trans_of incomp_trans_of
-/

end ExplicitRelationVariants

end

namespace StrictWeakOrder

section

parameter {α : Type u}{r : α → α → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => r

def Equiv (a b : α) : Prop :=
  ¬a≺b ∧ ¬b≺a
#align strict_weak_order.equiv StrictWeakOrder.Equiv

parameter [IsStrictWeakOrder α r]

-- mathport name: equiv
local infixl:50 " ≈ " => Equiv

theorem erefl (a : α) : a ≈ a :=
  ⟨irrefl a, irrefl a⟩
#align strict_weak_order.erefl StrictWeakOrder.erefl

theorem esymm {a b : α} : a ≈ b → b ≈ a := fun ⟨h₁, h₂⟩ => ⟨h₂, h₁⟩
#align strict_weak_order.esymm StrictWeakOrder.esymm

theorem etrans {a b c : α} : a ≈ b → b ≈ c → a ≈ c :=
  incomp_trans
#align strict_weak_order.etrans StrictWeakOrder.etrans

theorem not_lt_of_equiv {a b : α} : a ≈ b → ¬a≺b := fun h => h.1
#align strict_weak_order.not_lt_of_equiv StrictWeakOrder.not_lt_of_equiv

theorem not_lt_of_equiv' {a b : α} : a ≈ b → ¬b≺a := fun h => h.2
#align strict_weak_order.not_lt_of_equiv' StrictWeakOrder.not_lt_of_equiv'

instance isEquiv : IsEquiv α Equiv where
  refl := erefl
  trans := @etrans
  symm := @esymm
#align strict_weak_order.is_equiv StrictWeakOrder.isEquiv

end

-- mathport name: «expr ≈[ ] »
notation:50 -- Notation for the equivalence relation induced by lt
a " ≈[" lt "]" b:50 => @Equiv _ lt a b

end StrictWeakOrder

#print isStrictWeakOrder_of_isTotalPreorder /-
theorem isStrictWeakOrder_of_isTotalPreorder {α : Type u} {le : α → α → Prop} {lt : α → α → Prop}
    [DecidableRel le] [s : IsTotalPreorder α le] (h : ∀ a b, lt a b ↔ ¬le b a) :
    IsStrictWeakOrder α lt :=
  { trans := fun a b c hab hbc =>
      have nba : ¬le b a := Iff.mp (h _ _) hab
      have ncb : ¬le c b := Iff.mp (h _ _) hbc
      have hab : le a b := Or.resolve_left (total_of le b a) nba
      have nca : ¬le c a := fun hca : le c a =>
        have hcb : le c b := trans_of le hca hab
        absurd hcb ncb
      Iff.mpr (h _ _) nca
    irrefl := fun a hlt => absurd (refl_of le a) (Iff.mp (h _ _) hlt)
    incomp_trans := fun a b c ⟨nab, nba⟩ ⟨nbc, ncb⟩ =>
      have hba : le b a := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nab)
      have hab : le a b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nba)
      have hcb : le c b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nbc)
      have hbc : le b c := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) ncb)
      have hac : le a c := trans_of le hab hbc
      have hca : le c a := trans_of le hcb hba
      And.intro (fun n => absurd hca (Iff.mp (h _ _) n)) fun n => absurd hac (Iff.mp (h _ _) n) }
#align is_strict_weak_order_of_is_total_preorder isStrictWeakOrder_of_isTotalPreorder
-/

#print lt_of_lt_of_incomp /-
theorem lt_of_lt_of_incomp {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, lt a b → ¬lt b c ∧ ¬lt c b → lt a c :=
  fun a b c hab ⟨nbc, ncb⟩ =>
  have nca : ¬lt c a := fun hca => absurd (trans_of lt hca hab) ncb
  Decidable.by_contradiction fun nac : ¬lt a c =>
    have : ¬lt a b ∧ ¬lt b a := incomp_trans_of lt ⟨nac, nca⟩ ⟨ncb, nbc⟩
    absurd hab this.1
#align lt_of_lt_of_incomp lt_of_lt_of_incomp
-/

#print lt_of_incomp_of_lt /-
theorem lt_of_incomp_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, ¬lt a b ∧ ¬lt b a → lt b c → lt a c :=
  fun a b c ⟨nab, nba⟩ hbc =>
  have nca : ¬lt c a := fun hca => absurd (trans_of lt hbc hca) nba
  Decidable.by_contradiction fun nac : ¬lt a c =>
    have : ¬lt b c ∧ ¬lt c b := incomp_trans_of lt ⟨nba, nab⟩ ⟨nac, nca⟩
    absurd hbc this.1
#align lt_of_incomp_of_lt lt_of_incomp_of_lt
-/

#print eq_of_incomp /-
theorem eq_of_incomp {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    ¬lt a b ∧ ¬lt b a → a = b := fun ⟨nab, nba⟩ =>
  match trichotomous_of lt a b with
  | Or.inl hab => absurd hab nab
  | Or.inr (Or.inl hab) => hab
  | Or.inr (Or.inr hba) => absurd hba nba
#align eq_of_incomp eq_of_incomp
-/

#print eq_of_eqv_lt /-
theorem eq_of_eqv_lt {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    a ≈[lt]b → a = b :=
  eq_of_incomp
#align eq_of_eqv_lt eq_of_eqv_lt
-/

#print incomp_iff_eq /-
theorem incomp_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    ¬lt a b ∧ ¬lt b a ↔ a = b :=
  Iff.intro eq_of_incomp fun hab => Eq.subst hab (And.intro (irrefl_of lt a) (irrefl_of lt a))
#align incomp_iff_eq incomp_iff_eq
-/

#print eqv_lt_iff_eq /-
theorem eqv_lt_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    a ≈[lt]b ↔ a = b :=
  incomp_iff_eq a b
#align eqv_lt_iff_eq eqv_lt_iff_eq
-/

#print not_lt_of_lt /-
theorem not_lt_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictOrder α lt] {a b} :
    lt a b → ¬lt b a := fun h₁ h₂ => absurd (trans_of lt h₁ h₂) (irrefl_of lt _)
#align not_lt_of_lt not_lt_of_lt
-/


/- This module defines lemmas for option -/
import data.option

universe variables u v

run_cmd mk_simp_attr `simp_option

namespace option

variables {α : Type u} {β : Type u}

@[simp_option]
theorem is_some_none  : is_some (none : option α) = ff := rfl

@[simp_option]
theorem is_some_some {α : Type} (x : α) : option.is_some (some x) = tt := rfl

@[simp_option]
theorem is_some_ff_to_none (x : option α) : is_some x = ff ↔ (x = none) :=
begin
  cases x,
  { simp with simp_option, },
  { simp [is_some], contradiction, },
end

@[simp_option]
theorem has_map_none (f : α → β) : f <$> none = none := rfl

@[simp_option]
theorem has_map_some (f : α → β) (x : α) : f <$> some x = some (f x) := rfl

@[simp_option]
theorem none_orelse (x : option α) : (none <|> x) = x :=
begin
  cases x,
  all_goals { refl },
end

@[simp_option]
theorem some_orelse (x : α) (y : option α) : (some x <|> y) = some x := rfl

@[simp_option]
theorem orelse_none (x : option α) : (x <|> none) = x :=
begin
  cases x,
  all_goals { refl },
end

@[simp_option]
theorem option_is_some_plus (x y : option α)
: is_some (x <|> y) = is_some x || is_some y := do
begin
  cases x; simp [is_some] with simp_option,
end

@[simp_option]
theorem option_is_some_map (f : α → β) (x : option α)
: is_some (f <$> x) = is_some x := do
begin
  cases x; simp [is_some] with simp_option,
end

lemma bind_some' {A B} {ma : option A} {f : A → option B}
  {b : B} (H : option.bind ma f = some b)
  : ∃ a : A, ma = some a ∧ f a = some b
:= begin
  cases ma,
  contradiction,
  existsi a, split, reflexivity, assumption
end

lemma map_some {A B} {ma : option A} {f : A → B}
  {b : B} (H : option.map f ma = some b)
  : ∃ a : A, ma = some a ∧ f a = b
:= begin
cases ma,
contradiction,
existsi a, split, reflexivity,
dsimp [option.map, function.comp, option.bind] at H,
injection H with H',
end

/-
def filter {A : Type u}
   (P : A → Prop) [decidable_pred P] : option A → option A
| (some x) := if P x then some x else none
| none := none
-/

lemma filter_some {A : Type u}
  {P : A → Prop} [decP : decidable_pred P] {mx : option A} {x : A}
  (H : mx.filter P = some x)
  : mx = some x ∧ P x
:= begin
cases mx; simp [option.filter] at H,
contradiction,
have H' := decP a, induction H' with H' H',
{ rw (if_neg H') at H, contradiction, },
{ rw (if_pos H') at H, injection H with H'', clear H,
  subst x, constructor, reflexivity, assumption }
end

def guard_filter {A : Type}
  {P : Prop} [decP : decidable P] (mx : option A) :
  (do guard P, mx) = mx.filter (λ _, P)
:= begin
induction mx; induction decP; try { reflexivity }
end

lemma filter_true {A : Type u}
  {P : A → Prop} [decP : decidable_pred P] {x : A}
  (H : P x)
  : (some x).filter P = some x
:= begin
unfold option.filter, rw (if_pos H),
end

def precondition (P : Prop) [decP : decidable P] : option (plift P) :=
  match decP with
  | decidable.is_true H := some (plift.up H)
  | decidable.is_false contra := none
  end

lemma precondition_true {P : Prop} {A : Type u} [decP : decidable P]
  {f : plift P → option A}
  (H : P)
  : option.bind (precondition P) f = f (plift.up H)
:= begin
unfold precondition,
induction decP; dsimp [precondition],
{ contradiction },
{ simp [option.bind],
}
end

lemma precondition_false {P : Prop} [decP : decidable P]
  (H : ¬ P)
  : precondition P = none
:= begin
unfold precondition,
induction decP; dsimp [precondition],
{ simp [option.bind], },
{ contradiction
}
end

lemma precondition_true_bind {P : Prop} {A : Type} [decP : decidable P]
  {f : plift P → option A}
  (H : P)
  : precondition P >>= f = f (plift.up H)
:= precondition_true H

lemma map_compose {A B C} (f : A → B) (g : B → C)
  : option.map (g ∘ f) = option.map g ∘ option.map f
:= begin
apply funext; intros x, induction x; reflexivity,
end

inductive Issome {A} : option A -> Prop
  | MkIsSome : forall a : A, Issome (some a)

lemma not_Issome_none {A : Type} : ¬ Issome (@none A) :=
begin
generalize b : (@none A) = a,
intros contra,
induction contra,
contradiction
end

end option