import M4R.Algebra.Ring.MapRings

namespace M4R

  def Polynomial (α : Type _) [Semiring α] := Nat →₀ α

  def PowerSeries (α : Type _) [Semiring α] := Nat → α

  def MVPolynomial (σ : Type _) (α : Type _) [Semiring α] := (σ →₀ Nat) →₀ α

  def MVPowerSeries (σ : Type _) (α : Type _) [Semiring α] := (σ →₀ Nat) → α

  noncomputable instance PolynomialSemiring (α : Type _) [Semiring α] : Semiring (Polynomial α) :=
    Finsupp.toSemiring
  noncomputable instance MVPolynomialSemiring (σ : Type _) (α : Type _) [Semiring α] : Semiring (MVPolynomial σ α) :=
    Finsupp.toSemiring

  noncomputable instance PolynomialCoe (α : Type _) [Semiring α] : Coe (Polynomial α) (MVPolynomial Unit α) where
    coe := fun f => by
      simp only [Polynomial, MVPolynomial] at f ⊢
      exact {
        support := Finset.map_inj Finsupp.UnitFinsuppMonoid.right_inv.inv_injective f.support
        to_fun := fun x => f (x Unit.unit)
        mem_support_to_fun := fun x =>
          ⟨fun h => by
            let ⟨n, hnf, hnx⟩ := Finset.map_inj_mem.mp h
            rw [←hnx]; simp only [Finsupp.UnitFinsuppMonoid]
            rw [←Finsupp.mem_support_to_fun, Finsupp.single.eq_same]
            exact hnf,
          fun h => by
            rw [Finset.map_inj_mem]
            exact ⟨x Unit.unit, (Finsupp.mem_support_to_fun f _).mpr h, Finsupp.UnitFinsuppMonoid.left_inv x⟩⟩
      }

  instance PowerSeriesCoe (α : Type _) [Semiring α] : Coe (PowerSeries α) (MVPowerSeries Unit α) where
    coe := fun x y => x (y.to_fun Unit.unit)

  noncomputable def monomial [Semiring α] (s : σ →₀ Nat) : α →₊ MVPolynomial σ α := Finsupp.single_add_hom s

  theorem single_eq_monomial [Semiring α] (s : σ →₀ Nat) (a : α) : Finsupp.single s a = monomial s a := rfl

  theorem mul_def [Semiring α] {p q : MVPolynomial σ α} :
    (p * q) = ∑ fun m a => ∑ fun n b => monomial (m + n) (a * b) in q in p := rfl

  noncomputable def C [Semiring α] : α →*₁ MVPolynomial σ α where
    toMHomomorphism := monomial 0
    preserve_one  := rfl
    preserve_mul  := fun a b => by simp only [←single_eq_monomial, mul_def, Finsupp.map_sum.single,
      Monoid.add_zero, NCSemiring.mul_zero, NCSemiring.zero_mul, Finsupp.single.zero]

  noncomputable def X [Semiring α] (n : σ) : MVPolynomial σ α := monomial (Finsupp.single n 1) 1

  theorem C_apply [Semiring α] : (C a : MVPolynomial σ α) = monomial 0 a := rfl

  @[simp] theorem C_0 [Semiring α] : C 0 = (0 : MVPolynomial σ α) := by
    simp only [C_apply, monomial, Finsupp.single_add_hom, Finsupp.single.zero]

  @[simp] theorem C_1 [Semiring α] : C 1 = (1 : MVPolynomial σ α) := rfl

  theorem C_mul_monomial [Semiring α] {a a' : α} {s : σ →₀ Nat} : C a * monomial s a' = monomial s (a * a') := by
    simp only [C_apply, monomial, Finsupp.single_add_hom]
    rw [Finsupp.single_mul_single, Monoid.zero_add]

  @[simp] theorem C_add [Semiring α] {a a' : α} : (C (a + a') : MVPolynomial σ α) = C a + C a' := by
    simp only [C_apply, monomial, Finsupp.single_add_hom]
    exact Finsupp.single.add 0 a a'

  @[simp] theorem C_mul [Semiring α] : (C (a * a') : MVPolynomial σ α) = C a * C a' := C_mul_monomial.symm

  @[simp] theorem C_pow [Semiring α] (a : α) (n : Nat) : (C (a^n) : MVPolynomial σ α) = (C a)^n := by
    induction n with
    | zero => rfl
    | succ k ih => simp only [NCSemiring.pow_nat_succ, C.preserve_mul, ih]

end M4R


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.ideal.operations
import ring_theory.localization.basic

/-!
# Ideals in localizations of commutative rings

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/

namespace is_localization

section comm_semiring
variables {R : Type*} [comm_semiring R] (M : submonoid R) (S : Type*) [comm_semiring S]
variables [algebra R S] [is_localization M S]

include M

/-- Explicit characterization of the ideal given by `ideal.map (algebra_map R S) I`.
In practice, this ideal differs only in that the carrier set is defined explicitly.
This definition is only meant to be used in proving `mem_map_algebra_map_iff`,
and any proof that needs to refer to the explicit carrier set should use that theorem. -/
private def map_ideal (I : ideal R) : ideal S :=
{ carrier := { z : S | ∃ x : I × M, z * algebra_map R S x.2 = algebra_map R S x.1},
  zero_mem' := ⟨⟨0, 1⟩, by simp⟩,
  add_mem' := begin
    rintros a b ⟨a', ha⟩ ⟨b', hb⟩,
    use ⟨a'.2 * b'.1 + b'.2 * a'.1, I.add_mem (I.mul_mem_left _ b'.1.2) (I.mul_mem_left _ a'.1.2)⟩,
    use a'.2 * b'.2,
    simp only [ring_hom.map_add, submodule.coe_mk, submonoid.coe_mul, ring_hom.map_mul],
    rw [add_mul, ← mul_assoc a, ha, mul_comm (algebra_map R S a'.2) (algebra_map R S b'.2),
        ← mul_assoc b, hb],
    ring
  end,
  smul_mem' := begin
    rintros c x ⟨x', hx⟩,
    obtain ⟨c', hc⟩ := is_localization.surj M c,
    use ⟨c'.1 * x'.1, I.mul_mem_left c'.1 x'.1.2⟩,
    use c'.2 * x'.2,
    simp only [←hx, ←hc, smul_eq_mul, submodule.coe_mk, submonoid.coe_mul, ring_hom.map_mul],
    ring
  end }

theorem mem_map_algebra_map_iff {I : ideal R} {z} :
  z ∈ ideal.map (algebra_map R S) I ↔ ∃ x : I × M, z * algebra_map R S x.2 = algebra_map R S x.1 :=
begin
  split,
  { change _ → z ∈ map_ideal M S I,
    refine λ h, ideal.mem_Inf.1 h (λ z hz, _),
    obtain ⟨y, hy⟩ := hz,
    use ⟨⟨⟨y, hy.left⟩, 1⟩, by simp [hy.right]⟩ },
  { rintros ⟨⟨a, s⟩, h⟩,
    rw [← ideal.unit_mul_mem_iff_mem _ (map_units S s), mul_comm],
    exact h.symm ▸ ideal.mem_map_of_mem _ a.2 }
end

theorem map_comap (J : ideal S) :
  ideal.map (algebra_map R S) (ideal.comap (algebra_map R S) J) = J :=
le_antisymm (ideal.map_le_iff_le_comap.2 le_rfl) $ λ x hJ,
begin
  obtain ⟨r, s, hx⟩ := mk'_surjective M x,
  rw ←hx at ⊢ hJ,
  exact ideal.mul_mem_right _ _ (ideal.mem_map_of_mem _ (show (algebra_map R S) r ∈ J, from
    mk'_spec S r s ▸ J.mul_mem_right ((algebra_map R S) s) hJ)),
end

theorem comap_map_of_is_prime_disjoint (I : ideal R) (hI : I.is_prime)
  (hM : disjoint (M : set R) I) :
  ideal.comap (algebra_map R S) (ideal.map (algebra_map R S) I) = I :=
begin
  refine le_antisymm (λ a ha, _) ideal.le_comap_map,
  obtain ⟨⟨b, s⟩, h⟩ := (mem_map_algebra_map_iff M S).1 (ideal.mem_comap.1 ha),
  replace h : algebra_map R S (a * s) = algebra_map R S b := by simpa only [←map_mul] using h,
  obtain ⟨c, hc⟩ := (eq_iff_exists M S).1 h,
  have : a * (s * c) ∈ I := by { rw [←mul_assoc, hc], exact I.mul_mem_right c b.2 },
  exact (hI.mem_or_mem this).resolve_right (λ hsc, hM ⟨(s * c).2, hsc⟩)
end

/-- If `S` is the localization of `R` at a submonoid, the ordering of ideals of `S` is
embedded in the ordering of ideals of `R`. -/
def order_embedding : ideal S ↪o ideal R :=
{ to_fun := λ J, ideal.comap (algebra_map R S) J,
  inj'   := function.left_inverse.injective (map_comap M S),
  map_rel_iff'   := λ J₁ J₂, ⟨λ hJ, (map_comap M S) J₁ ▸ (map_comap M S) J₂ ▸ ideal.map_mono hJ,
    ideal.comap_mono⟩ }

/-- If `R` is a ring, then prime ideals in the localization at `M`
correspond to prime ideals in the original ring `R` that are disjoint from `M`.
This lemma gives the particular case for an ideal and its comap,
see `le_rel_iso_of_prime` for the more general relation isomorphism -/
lemma is_prime_iff_is_prime_disjoint (J : ideal S) :
  J.is_prime ↔ (ideal.comap (algebra_map R S) J).is_prime ∧
    disjoint (M : set R) ↑(ideal.comap (algebra_map R S) J) :=
begin
  split,
  { refine λ h, ⟨⟨_, _⟩, λ m hm,
      h.ne_top (ideal.eq_top_of_is_unit_mem _ hm.2 (map_units S ⟨m, hm.left⟩))⟩,
    { refine λ hJ, h.ne_top _,
      rw [eq_top_iff, ← (order_embedding M S).le_iff_le],
      exact le_of_eq hJ.symm },
    { intros x y hxy,
      rw [ideal.mem_comap, ring_hom.map_mul] at hxy,
      exact h.mem_or_mem hxy } },
  { refine λ h, ⟨λ hJ, h.left.ne_top (eq_top_iff.2 _), _⟩,
    { rwa [eq_top_iff, ← (order_embedding M S).le_iff_le] at hJ },
    { intros x y hxy,
      obtain ⟨a, s, ha⟩ := mk'_surjective M x,
      obtain ⟨b, t, hb⟩ := mk'_surjective M y,
      have : mk' S (a * b) (s * t) ∈ J := by rwa [mk'_mul, ha, hb],
      rw [mk'_mem_iff, ← ideal.mem_comap] at this,
      replace this := h.left.mem_or_mem this,
      rw [ideal.mem_comap, ideal.mem_comap] at this,
      rwa [← ha, ← hb, mk'_mem_iff, mk'_mem_iff] } }
end

/-- If `R` is a ring, then prime ideals in the localization at `M`
correspond to prime ideals in the original ring `R` that are disjoint from `M`.
This lemma gives the particular case for an ideal and its map,
see `le_rel_iso_of_prime` for the more general relation isomorphism, and the reverse implication -/

/-- If `R` is a ring, then prime ideals in the localization at `M`
correspond to prime ideals in the original ring `R` that are disjoint from `M` -/
def order_iso_of_prime :
  {p : ideal S // p.is_prime} ≃o {p : ideal R // p.is_prime ∧ disjoint (M : set R) ↑p} :=
{ to_fun := λ p, ⟨ideal.comap (algebra_map R S) p.1,
                  (is_prime_iff_is_prime_disjoint M S p.1).1 p.2⟩,
  inv_fun := λ p, ⟨ideal.map (algebra_map R S) p.1,
                   is_prime_of_is_prime_disjoint M S p.1 p.2.1 p.2.2⟩,
  left_inv := λ J, subtype.eq (map_comap M S J),
  right_inv := λ I, subtype.eq (comap_map_of_is_prime_disjoint M S I.1 I.2.1 I.2.2),
  map_rel_iff' := λ I I', ⟨λ h, (show I.val ≤ I'.val,
    from (map_comap M S I.val) ▸ (map_comap M S I'.val) ▸ (ideal.map_mono h)), λ h x hx, h hx⟩ }

end comm_semiring

section comm_ring
variables {R : Type*} [comm_ring R] (M : submonoid R) (S : Type*) [comm_ring S]
variables [algebra R S] [is_localization M S]

include M

/-- `quotient_map` applied to maximal ideals of a localization is `surjective`.
  The quotient by a maximal ideal is a field, so inverses to elements already exist,
  and the localization necessarily maps the equivalence class of the inverse in the localization -/
lemma surjective_quotient_map_of_maximal_of_localization {I : ideal S} [I.is_prime] {J : ideal R}
  {H : J ≤ I.comap (algebra_map R S)} (hI : (I.comap (algebra_map R S)).is_maximal) :
  function.surjective (I.quotient_map (algebra_map R S) H) :=
begin
  intro s,
  obtain ⟨s, rfl⟩ := ideal.quotient.mk_surjective s,
  obtain ⟨r, ⟨m, hm⟩, rfl⟩ := mk'_surjective M s,
  by_cases hM : (ideal.quotient.mk (I.comap (algebra_map R S))) m = 0,
  { have : I = ⊤,
    { rw ideal.eq_top_iff_one,
      rw [ideal.quotient.eq_zero_iff_mem, ideal.mem_comap] at hM,
      convert I.mul_mem_right (mk' S (1 : R) ⟨m, hm⟩) hM,
      rw [← mk'_eq_mul_mk'_one, mk'_self] },
    exact ⟨0, eq_comm.1 (by simp [ideal.quotient.eq_zero_iff_mem, this])⟩ },
  { rw ideal.quotient.maximal_ideal_iff_is_field_quotient at hI,
    obtain ⟨n, hn⟩ := hI.3 hM,
    obtain ⟨rn, rfl⟩ := ideal.quotient.mk_surjective n,
    refine ⟨(ideal.quotient.mk J) (r * rn), _⟩,
    -- The rest of the proof is essentially just algebraic manipulations to prove the equality
    rw ← ring_hom.map_mul at hn,
    replace hn := congr_arg (ideal.quotient_map I (algebra_map R S) le_rfl) hn,
    simp only [ring_hom.map_one, ideal.quotient_map_mk, ring_hom.map_mul] at hn,
    rw [ideal.quotient_map_mk, ← sub_eq_zero, ← ring_hom.map_sub,
      ideal.quotient.eq_zero_iff_mem, ← ideal.quotient.eq_zero_iff_mem, ring_hom.map_sub,
      sub_eq_zero, mk'_eq_mul_mk'_one],
    simp only [mul_eq_mul_left_iff, ring_hom.map_mul],
    exact or.inl (mul_left_cancel₀ (λ hn, hM (ideal.quotient.eq_zero_iff_mem.2
      (ideal.mem_comap.2 (ideal.quotient.eq_zero_iff_mem.1 hn)))) (trans hn
      (by rw [← ring_hom.map_mul, ← mk'_eq_mul_mk'_one, mk'_self, ring_hom.map_one]))) }
end

end comm_ring

end is_localization


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group_ring_action
import group_theory.group_action.defs

/-!
# Equivariant homomorphisms

## Main definitions

* `mul_action_hom M X Y`, the type of equivariant functions from `X` to `Y`, where `M` is a monoid
  that acts on the types `X` and `Y`.
* `distrib_mul_action_hom M A B`, the type of equivariant additive monoid homomorphisms
  from `A` to `B`, where `M` is a monoid that acts on the additive monoids `A` and `B`.
* `mul_semiring_action_hom M R S`, the type of equivariant ring homomorphisms
  from `R` to `S`, where `M` is a monoid that acts on the rings `R` and `S`.

The above types have corresponding classes:
* `smul_hom_class F M X Y` states that `F` is a type of bundled `X → Y` homs
  preserving scalar multiplication by `M`
* `distrib_mul_action_hom_class F M A B` states that `F` is a type of bundled `A → B` homs
  preserving the additive monoid structure and scalar multiplication by `M`
* `mul_semiring_action_hom_class F M R S` states that `F` is a type of bundled `R → S` homs
  preserving the ring structure and scalar multiplication by `M`

## Notations

* `X →[M] Y` is `mul_action_hom M X Y`.
* `A →+[M] B` is `distrib_mul_action_hom M A B`.
* `R →+*[M] S` is `mul_semiring_action_hom M R S`.

-/

variables (M' : Type*)
variables (X : Type*) [has_scalar M' X]
variables (Y : Type*) [has_scalar M' Y]
variables (Z : Type*) [has_scalar M' Z]
variables (M : Type*) [monoid M]
variables (A : Type*) [add_monoid A] [distrib_mul_action M A]
variables (A' : Type*) [add_group A'] [distrib_mul_action M A']
variables (B : Type*) [add_monoid B] [distrib_mul_action M B]
variables (B' : Type*) [add_group B'] [distrib_mul_action M B']
variables (C : Type*) [add_monoid C] [distrib_mul_action M C]
variables (R : Type*) [semiring R] [mul_semiring_action M R]
variables (R' : Type*) [ring R'] [mul_semiring_action M R']
variables (S : Type*) [semiring S] [mul_semiring_action M S]
variables (S' : Type*) [ring S'] [mul_semiring_action M S']
variables (T : Type*) [semiring T] [mul_semiring_action M T]
variables (G : Type*) [group G] (H : subgroup G)

set_option old_structure_cmd true

/-- Equivariant functions. -/
@[nolint has_inhabited_instance]
structure mul_action_hom :=
(to_fun : X → Y)
(map_smul' : ∀ (m : M') (x : X), to_fun (m • x) = m • to_fun x)

notation X ` →[`:25 M:25 `] `:0 Y:0 := mul_action_hom M X Y

/-- `smul_hom_class F M X Y` states that `F` is a type of morphisms preserving
scalar multiplication by `M`.

You should extend this class when you extend `mul_action_hom`. -/
class smul_hom_class (F : Type*) (M X Y : out_param $ Type*) [has_scalar M X] [has_scalar M Y]
  extends fun_like F X (λ _, Y) :=
(map_smul : ∀ (f : F) (c : M) (x : X), f (c • x) = c • f x)

-- `M` becomes a metavariable but it's an `out_param` so it's not a problem.
attribute [nolint dangerous_instance] smul_hom_class.to_fun_like

export smul_hom_class (map_smul)
attribute [simp] map_smul

namespace mul_action_hom

instance : has_coe_to_fun (X →[M'] Y) (λ _, X → Y) := ⟨mul_action_hom.to_fun⟩

instance : smul_hom_class (X →[M'] Y) M' X Y :=
{ coe := mul_action_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_smul := mul_action_hom.map_smul' }

variables {M M' X Y}

protected lemma map_smul (f : X →[M'] Y) (m : M') (x : X) : f (m • x) = m • f x := map_smul _ _ _
@[ext] theorem ext : ∀ {f g : X →[M'] Y}, (∀ x, f x = g x) → f = g := fun_like.ext
theorem ext_iff {f g : X →[M'] Y} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff
protected lemma congr_fun {f g : X →[M'] Y} (h : f = g) (x : X) : f x = g x :=
fun_like.congr_fun h _

variables (M M') {X}

/-- The identity map as an equivariant map. -/
protected def id : X →[M'] X :=
⟨id, λ _ _, rfl⟩

@[simp] lemma id_apply (x : X) : mul_action_hom.id M' x = x := rfl

variables {M M' X Y Z}

/-- Composition of two equivariant maps. -/
def comp (g : Y →[M'] Z) (f : X →[M'] Y) : X →[M'] Z :=
⟨g ∘ f, λ m x, calc
g (f (m • x)) = g (m • f x) : by rw f.map_smul
          ... = m • g (f x) : g.map_smul _ _⟩

@[simp] lemma comp_apply (g : Y →[M'] Z) (f : X →[M'] Y) (x : X) : g.comp f x = g (f x) := rfl

@[simp] lemma id_comp (f : X →[M'] Y) : (mul_action_hom.id M').comp f = f :=
ext $ λ x, by rw [comp_apply, id_apply]

@[simp] lemma comp_id (f : X →[M'] Y) : f.comp (mul_action_hom.id M') = f :=
ext $ λ x, by rw [comp_apply, id_apply]

variables {A B}

/-- The inverse of a bijective equivariant map is equivariant. -/
@[simps] def inverse (f : A →[M] B) (g : B → A)
  (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) :
  B →[M] A :=
{ to_fun    := g,
  map_smul' := λ m x,
    calc g (m • x) = g (m • (f (g x))) : by rw h₂
               ... = g (f (m • (g x))) : by rw f.map_smul
               ... = m • g x : by rw h₁, }

end mul_action_hom

/-- Equivariant additive monoid homomorphisms. -/
structure distrib_mul_action_hom extends A →[M] B, A →+ B.

/-- Reinterpret an equivariant additive monoid homomorphism as an additive monoid homomorphism. -/
add_decl_doc distrib_mul_action_hom.to_add_monoid_hom

/-- Reinterpret an equivariant additive monoid homomorphism as an equivariant function. -/
add_decl_doc distrib_mul_action_hom.to_mul_action_hom

notation A ` →+[`:25 M:25 `] `:0 B:0 := distrib_mul_action_hom M A B

/-- `distrib_mul_action_hom_class F M A B` states that `F` is a type of morphisms preserving
the additive monoid structure and scalar multiplication by `M`.

You should extend this class when you extend `distrib_mul_action_hom`. -/
class distrib_mul_action_hom_class (F : Type*) (M A B : out_param $ Type*)
  [monoid M] [add_monoid A] [add_monoid B] [distrib_mul_action M A] [distrib_mul_action M B]
  extends smul_hom_class F M A B, add_monoid_hom_class F A B

-- `M` becomes a metavariable but it's an `out_param` so it's not a problem.
attribute [nolint dangerous_instance] distrib_mul_action_hom_class.to_add_monoid_hom_class

namespace distrib_mul_action_hom

instance has_coe : has_coe (A →+[M] B) (A →+ B) :=
⟨to_add_monoid_hom⟩

instance has_coe' : has_coe (A →+[M] B) (A →[M] B) :=
⟨to_mul_action_hom⟩

instance : has_coe_to_fun (A →+[M] B) (λ _, A → B) := ⟨to_fun⟩

instance : distrib_mul_action_hom_class (A →+[M] B) M A B :=
{ coe := distrib_mul_action_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_smul := distrib_mul_action_hom.map_smul',
  map_zero := distrib_mul_action_hom.map_zero',
  map_add := distrib_mul_action_hom.map_add' }

variables {M A B}

@[simp] lemma to_fun_eq_coe (f : A →+[M] B) : f.to_fun = ⇑f := rfl

@[norm_cast] lemma coe_fn_coe (f : A →+[M] B) : ((f : A →+ B) : A → B) = f := rfl
@[norm_cast] lemma coe_fn_coe' (f : A →+[M] B) : ((f : A →[M] B) : A → B) = f := rfl

@[ext] theorem ext : ∀ {f g : A →+[M] B}, (∀ x, f x = g x) → f = g := fun_like.ext
theorem ext_iff {f g : A →+[M] B} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff
protected lemma congr_fun {f g : A →+[M] B} (h : f = g) (x : A) : f x = g x :=
fun_like.congr_fun h _

lemma to_mul_action_hom_injective {f g : A →+[M] B}
  (h : (f : A →[M] B) = (g : A →[M] B)) : f = g :=
by { ext a, exact mul_action_hom.congr_fun h a, }

lemma to_add_monoid_hom_injective {f g : A →+[M] B}
  (h : (f : A →+ B) = (g : A →+ B)) : f = g :=
by { ext a, exact add_monoid_hom.congr_fun h a, }

protected lemma map_zero (f : A →+[M] B) : f 0 = 0 := map_zero _
protected lemma map_add (f : A →+[M] B) (x y : A) : f (x + y) = f x + f y := map_add _ _ _
protected lemma map_neg (f : A' →+[M] B') (x : A') : f (-x) = -f x := map_neg _ _
protected lemma map_sub (f : A' →+[M] B') (x y : A') : f (x - y) = f x - f y := map_sub _ _ _
protected lemma map_smul (f : A →+[M] B) (m : M) (x : A) : f (m • x) = m • f x := map_smul _ _ _

variables (M) {A}

/-- The identity map as an equivariant additive monoid homomorphism. -/
protected def id : A →+[M] A :=
⟨id, λ _ _, rfl, rfl, λ _ _, rfl⟩

@[simp] lemma id_apply (x : A) : distrib_mul_action_hom.id M x = x := rfl

variables {M A B C}

instance : has_zero (A →+[M] B) :=
⟨{ map_smul' := by simp,
   .. (0 : A →+ B) }⟩

instance : has_one (A →+[M] A) := ⟨distrib_mul_action_hom.id M⟩

@[simp] lemma coe_zero : ((0 : A →+[M] B) : A → B) = 0 := rfl

@[simp] lemma coe_one : ((1 : A →+[M] A) : A → A) = id := rfl

lemma zero_apply (a : A) : (0 : A →+[M] B) a = 0 := rfl

lemma one_apply (a : A) : (1 : A →+[M] A) a = a := rfl

instance : inhabited (A →+[M] B) := ⟨0⟩

/-- Composition of two equivariant additive monoid homomorphisms. -/
def comp (g : B →+[M] C) (f : A →+[M] B) : A →+[M] C :=
{ .. mul_action_hom.comp (g : B →[M] C) (f : A →[M] B),
  .. add_monoid_hom.comp (g : B →+ C) (f : A →+ B), }

@[simp] lemma comp_apply (g : B →+[M] C) (f : A →+[M] B) (x : A) : g.comp f x = g (f x) := rfl

@[simp] lemma id_comp (f : A →+[M] B) : (distrib_mul_action_hom.id M).comp f = f :=
ext $ λ x, by rw [comp_apply, id_apply]

@[simp] lemma comp_id (f : A →+[M] B) : f.comp (distrib_mul_action_hom.id M) = f :=
ext $ λ x, by rw [comp_apply, id_apply]

/-- The inverse of a bijective `distrib_mul_action_hom` is a `distrib_mul_action_hom`. -/
@[simps] def inverse (f : A →+[M] B) (g : B → A)
  (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f) :
  B →+[M] A :=
{ to_fun := g,
  .. (f : A →+ B).inverse g h₁ h₂,
  .. (f : A →[M] B).inverse g h₁ h₂ }

section semiring

variables {R M'} [add_monoid M'] [distrib_mul_action R M']

@[ext] lemma ext_ring
  {f g : R →+[R] M'} (h : f 1 = g 1) : f = g :=
by { ext x, rw [← mul_one x, ← smul_eq_mul R, f.map_smul, g.map_smul, h], }

lemma ext_ring_iff {f g : R →+[R] M'} : f = g ↔ f 1 = g 1 :=
⟨λ h, h ▸ rfl, ext_ring⟩

end semiring

end distrib_mul_action_hom

/-- Equivariant ring homomorphisms. -/
@[nolint has_inhabited_instance]
structure mul_semiring_action_hom extends R →+[M] S, R →+* S.

/-- Reinterpret an equivariant ring homomorphism as a ring homomorphism. -/
add_decl_doc mul_semiring_action_hom.to_ring_hom

/-- Reinterpret an equivariant ring homomorphism as an equivariant additive monoid homomorphism. -/
add_decl_doc mul_semiring_action_hom.to_distrib_mul_action_hom

notation R ` →+*[`:25 M:25 `] `:0 S:0 := mul_semiring_action_hom M R S

/-- `mul_semiring_action_hom_class F M R S` states that `F` is a type of morphisms preserving
the ring structure and scalar multiplication by `M`.

You should extend this class when you extend `mul_semiring_action_hom`. -/
class mul_semiring_action_hom_class (F : Type*) (M R S : out_param $ Type*)
  [monoid M] [semiring R] [semiring S] [distrib_mul_action M R] [distrib_mul_action M S]
  extends distrib_mul_action_hom_class F M R S, ring_hom_class F R S

-- `M` becomes a metavariable but it's an `out_param` so it's not a problem.
attribute [nolint dangerous_instance] mul_semiring_action_hom_class.to_ring_hom_class

namespace mul_semiring_action_hom

instance has_coe : has_coe (R →+*[M] S) (R →+* S) :=
⟨to_ring_hom⟩

instance has_coe' : has_coe (R →+*[M] S) (R →+[M] S) :=
⟨to_distrib_mul_action_hom⟩

instance : has_coe_to_fun (R →+*[M] S) (λ _, R → S) := ⟨λ c, c.to_fun⟩

instance : mul_semiring_action_hom_class (R →+*[M] S) M R S :=
{ coe := mul_semiring_action_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_smul := mul_semiring_action_hom.map_smul',
  map_zero := mul_semiring_action_hom.map_zero',
  map_add := mul_semiring_action_hom.map_add',
  map_one := mul_semiring_action_hom.map_one',
  map_mul := mul_semiring_action_hom.map_mul' }

variables {M R S}

@[norm_cast] lemma coe_fn_coe (f : R →+*[M] S) : ((f : R →+* S) : R → S) = f := rfl
@[norm_cast] lemma coe_fn_coe' (f : R →+*[M] S) : ((f : R →+[M] S) : R → S) = f := rfl

@[ext] theorem ext : ∀ {f g : R →+*[M] S}, (∀ x, f x = g x) → f = g := fun_like.ext
theorem ext_iff {f g : R →+*[M] S} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

protected lemma map_zero (f : R →+*[M] S) : f 0 = 0 := map_zero _
protected lemma map_add (f : R →+*[M] S) (x y : R) : f (x + y) = f x + f y := map_add _ _ _
protected lemma map_neg (f : R' →+*[M] S') (x : R') : f (-x) = -f x := map_neg _ _
protected lemma map_sub (f : R' →+*[M] S') (x y : R') : f (x - y) = f x - f y := map_sub _ _ _
protected lemma map_one (f : R →+*[M] S) : f 1 = 1 := map_one _
protected

variables (M) {R}

/-- The identity map as an equivariant ring homomorphism. -/
protected def id : R →+*[M] R :=
⟨id, λ _ _, rfl, rfl, λ _ _, rfl, rfl, λ _ _, rfl⟩

@[simp] lemma id_apply (x : R) : mul_semiring_action_hom.id M x = x := rfl

variables {M R S T}

/-- Composition of two equivariant additive monoid homomorphisms. -/
def comp (g : S →+*[M] T) (f : R →+*[M] S) : R →+*[M] T :=
{ .. distrib_mul_action_hom.comp (g : S →+[M] T) (f : R →+[M] S),
  .. ring_hom.comp (g : S →+* T) (f : R →+* S), }

@[simp] lemma comp_apply (g : S →+*[M] T) (f : R →+*[M] S) (x : R) : g.comp f x = g (f x) := rfl

@[simp] lemma id_comp (f : R →+*[M] S) : (mul_semiring_action_hom.id M).comp f = f :=
ext $ λ x, by rw [comp_apply, id_apply]

@[simp] lemma comp_id (f : R →+*[M] S) : f.comp (mul_semiring_action_hom.id M) = f :=
ext $ λ x, by rw [comp_apply, id_apply]

end mul_semiring_action_hom

section
variables (M) {R'} (U : subring R') [is_invariant_subring M U]

/-- The canonical inclusion from an invariant subring. -/
def is_invariant_subring.subtype_hom : U →+*[M] R' :=
{ map_smul' := λ m s, rfl, ..U.subtype }

@[simp] theorem is_invariant_subring.coe_subtype_hom :
  (is_invariant_subring.subtype_hom M U : U → R') = coe := rfl

@[simp] theorem is_invariant_subring.coe_subtype_hom' :
  (is_invariant_subring.subtype_hom M U : U →+* R') = U.subtype := rfl

end


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Utensil Song

! This file was ported from Lean 3 source module linear_algebra.clifford_algebra.basic
! leanprover-community/mathlib commit d46774d43797f5d1f507a63a6e904f7a533ae74a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.RingQuot
import Mathbin.LinearAlgebra.TensorAlgebra.Basic
import Mathbin.LinearAlgebra.QuadraticForm.Isometry

/-!
# Clifford Algebras

We construct the Clifford algebra of a module `M` over a commutative ring `R`, equipped with
a quadratic_form `Q`.

## Notation

The Clifford algebra of the `R`-module `M` equipped with a quadratic_form `Q` is
an `R`-algebra denoted `clifford_algebra Q`.

Given a linear morphism `f : M → A` from a module `M` to another `R`-algebra `A`, such that
`cond : ∀ m, f m * f m = algebra_map _ _ (Q m)`, there is a (unique) lift of `f` to an `R`-algebra
morphism from `clifford_algebra Q` to `A`, which is denoted `clifford_algebra.lift Q f cond`.

The canonical linear map `M → clifford_algebra Q` is denoted `clifford_algebra.ι Q`.

## Theorems

The main theorems proved ensure that `clifford_algebra Q` satisfies the universal property
of the Clifford algebra.
1. `ι_comp_lift` is the fact that the composition of `ι Q` with `lift Q f cond` agrees with `f`.
2. `lift_unique` ensures the uniqueness of `lift Q f cond` with respect to 1.

Additionally, when `Q = 0` an `alg_equiv` to the `exterior_algebra` is provided as `as_exterior`.

## Implementation details

The Clifford algebra of `M` is constructed as a quotient of the tensor algebra, as follows.
1. We define a relation `clifford_algebra.rel Q` on `tensor_algebra R M`.
   This is the smallest relation which identifies squares of elements of `M` with `Q m`.
2. The Clifford algebra is the quotient of the tensor algebra by this relation.

This file is almost identical to `linear_algebra/exterior_algebra.lean`.
-/

variable {R : Type _} [CommRing R]

variable {M : Type _} [AddCommGroup M] [Module R M]

variable (Q : QuadraticForm R M)

variable {n : ℕ}

namespace CliffordAlgebra

open TensorAlgebra

/-- `rel` relates each `ι m * ι m`, for `m : M`, with `Q m`.

The Clifford algebra of `M` is defined as the quotient modulo this relation.
-/
inductive Rel : TensorAlgebra R M → TensorAlgebra R M → Prop
  | of (m : M) : Rel (ι R m * ι R m) (algebraMap R _ (Q m))
#align clifford_algebra.rel CliffordAlgebra.Rel

end CliffordAlgebra

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R -/
/-- The Clifford algebra of an `R`-module `M` equipped with a quadratic_form `Q`.
-/
def CliffordAlgebra :=
  RingQuot (CliffordAlgebra.Rel Q)deriving Inhabited, Ring,
  «./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R»
#align clifford_algebra CliffordAlgebra

namespace CliffordAlgebra

/-- The canonical linear map `M →ₗ[R] clifford_algebra Q`.
-/
def ι : M →ₗ[R] CliffordAlgebra Q :=
  (RingQuot.mkAlgHom R _).toLinearMap.comp (TensorAlgebra.ι R)
#align clifford_algebra.ι CliffordAlgebra.ι

/-- As well as being linear, `ι Q` squares to the quadratic form -/
@[simp]
theorem ι_sq_scalar (m : M) : ι Q m * ι Q m = algebraMap R _ (Q m) :=
  by
  erw [← AlgHom.map_mul, RingQuot.mkAlgHom_rel R (rel.of m), AlgHom.commutes]
  rfl
#align clifford_algebra.ι_sq_scalar CliffordAlgebra.ι_sq_scalar

variable {Q} {A : Type _} [Semiring A] [Algebra R A]

@[simp]
theorem comp_ι_sq_scalar (g : CliffordAlgebra Q →ₐ[R] A) (m : M) :
    g (ι Q m) * g (ι Q m) = algebraMap _ _ (Q m) := by
  rw [← AlgHom.map_mul, ι_sq_scalar, AlgHom.commutes]
#align clifford_algebra.comp_ι_sq_scalar CliffordAlgebra.comp_ι_sq_scalar

variable (Q)

/-- Given a linear map `f : M →ₗ[R] A` into an `R`-algebra `A`, which satisfies the condition:
`cond : ∀ m : M, f m * f m = Q(m)`, this is the canonical lift of `f` to a morphism of `R`-algebras
from `clifford_algebra Q` to `A`.
-/
@[simps symm_apply]
def lift : { f : M →ₗ[R] A // ∀ m, f m * f m = algebraMap _ _ (Q m) } ≃ (CliffordAlgebra Q →ₐ[R] A)
    where
  toFun f :=
    RingQuot.liftAlgHom R
      ⟨TensorAlgebra.lift R (f : M →ₗ[R] A), fun x y (h : Rel Q x y) =>
        by
        induction h
        rw [AlgHom.commutes, AlgHom.map_mul, TensorAlgebra.lift_ι_apply, f.prop]⟩
  invFun F :=
    ⟨F.toLinearMap.comp (ι Q), fun m => by
      rw [LinearMap.comp_apply, AlgHom.toLinearMap_apply, comp_ι_sq_scalar]⟩
  left_inv f := by
    ext
    simp only [ι, AlgHom.toLinearMap_apply, Function.comp_apply, LinearMap.coe_comp, Subtype.coe_mk,
      RingQuot.liftAlgHom_mkAlgHom_apply, TensorAlgebra.lift_ι_apply]
  right_inv F := by
    ext
    simp only [ι, AlgHom.comp_toLinearMap, AlgHom.toLinearMap_apply, Function.comp_apply,
      LinearMap.coe_comp, Subtype.coe_mk, RingQuot.liftAlgHom_mkAlgHom_apply,
      TensorAlgebra.lift_ι_apply]
#align clifford_algebra.lift CliffordAlgebra.lift

variable {Q}

@[simp]
theorem ι_comp_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebraMap _ _ (Q m)) :
    (lift Q ⟨f, cond⟩).toLinearMap.comp (ι Q) = f :=
  Subtype.mk_eq_mk.mp <| (lift Q).symm_apply_apply ⟨f, cond⟩
#align clifford_algebra.ι_comp_lift CliffordAlgebra.ι_comp_lift

@[simp]
theorem lift_ι_apply (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebraMap _ _ (Q m)) (x) :
    lift Q ⟨f, cond⟩ (ι Q x) = f x :=
  (LinearMap.ext_iff.mp <| ι_comp_lift f cond) x
#align clifford_algebra.lift_ι_apply CliffordAlgebra.lift_ι_apply

@[simp]
theorem lift_unique (f : M →ₗ[R] A) (cond : ∀ m : M, f m * f m = algebraMap _ _ (Q m))
    (g : CliffordAlgebra Q →ₐ[R] A) : g.toLinearMap.comp (ι Q) = f ↔ g = lift Q ⟨f, cond⟩ :=
  by
  convert(lift Q).symm_apply_eq
  rw [lift_symm_apply]
  simp only
#align clifford_algebra.lift_unique CliffordAlgebra.lift_unique

@[simp]
theorem lift_comp_ι (g : CliffordAlgebra Q →ₐ[R] A) :
    lift Q ⟨g.toLinearMap.comp (ι Q), comp_ι_sq_scalar _⟩ = g :=
  by
  convert(lift Q).apply_symm_apply g
  rw [lift_symm_apply]
  rfl
#align clifford_algebra.lift_comp_ι CliffordAlgebra.lift_comp_ι

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {A : Type _} [Semiring A] [Algebra R A] {f g : CliffordAlgebra Q →ₐ[R] A} :
    f.toLinearMap.comp (ι Q) = g.toLinearMap.comp (ι Q) → f = g :=
  by
  intro h
  apply (lift Q).symm.Injective
  rw [lift_symm_apply, lift_symm_apply]
  simp only [h]
#align clifford_algebra.hom_ext CliffordAlgebra.hom_ext

-- This proof closely follows `tensor_algebra.induction`
/-- If `C` holds for the `algebra_map` of `r : R` into `clifford_algebra Q`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `clifford_algebra Q`.

See also the stronger `clifford_algebra.left_induction` and `clifford_algebra.right_induction`.
-/
@[elab_as_elim]
theorem induction {C : CliffordAlgebra Q → Prop}
    (h_grade0 : ∀ r, C (algebraMap R (CliffordAlgebra Q) r)) (h_grade1 : ∀ x, C (ι Q x))
    (h_mul : ∀ a b, C a → C b → C (a * b)) (h_add : ∀ a b, C a → C b → C (a + b))
    (a : CliffordAlgebra Q) : C a :=
  by
  -- the arguments are enough to construct a subalgebra, and a mapping into it from M
  let s : Subalgebra R (CliffordAlgebra Q) :=
    { carrier := C
      mul_mem' := h_mul
      add_mem' := h_add
      algebraMap_mem' := h_grade0 }
  let of : { f : M →ₗ[R] s // ∀ m, f m * f m = algebraMap _ _ (Q m) } :=
    ⟨(ι Q).codRestrict s.to_submodule h_grade1, fun m => Subtype.eq <| ι_sq_scalar Q m⟩
  -- the mapping through the subalgebra is the identity
  have of_id : AlgHom.id R (CliffordAlgebra Q) = s.val.comp (lift Q of) :=
    by
    ext
    simp [of]
  -- finding a proof is finding an element of the subalgebra
  convert Subtype.prop (lift Q of a)
  exact AlgHom.congr_fun of_id a
#align clifford_algebra.induction CliffordAlgebra.induction

/-- The symmetric product of vectors is a scalar -/
theorem ι_mul_ι_add_swap (a b : M) :
    ι Q a * ι Q b + ι Q b * ι Q a = algebraMap R _ (QuadraticForm.polar Q a b) :=
  calc
    ι Q a * ι Q b + ι Q b * ι Q a = ι Q (a + b) * ι Q (a + b) - ι Q a * ι Q a - ι Q b * ι Q b :=
      by
      rw [(ι Q).map_add, mul_add, add_mul, add_mul]
      abel
    _ = algebraMap R _ (Q (a + b)) - algebraMap R _ (Q a) - algebraMap R _ (Q b) := by
      rw [ι_sq_scalar, ι_sq_scalar, ι_sq_scalar]
    _ = algebraMap R _ (Q (a + b) - Q a - Q b) := by rw [← RingHom.map_sub, ← RingHom.map_sub]
    _ = algebraMap R _ (QuadraticForm.polar Q a b) := rfl

#align clifford_algebra.ι_mul_ι_add_swap CliffordAlgebra.ι_mul_ι_add_swap

theorem ι_mul_comm (a b : M) :
    ι Q a * ι Q b = algebraMap R _ (QuadraticForm.polar Q a b) - ι Q b * ι Q a :=
  eq_sub_of_add_eq (ι_mul_ι_add_swap a b)
#align clifford_algebra.ι_mul_comm CliffordAlgebra.ι_mul_comm

/-- $aba$ is a vector. -/
theorem ι_mul_ι_mul_ι (a b : M) :
    ι Q a * ι Q b * ι Q a = ι Q (QuadraticForm.polar Q a b • a - Q a • b) := by
  rw [ι_mul_comm, sub_mul, mul_assoc, ι_sq_scalar, ← Algebra.smul_def, ← Algebra.commutes, ←
    Algebra.smul_def, ← map_smul, ← map_smul, ← map_sub]
#align clifford_algebra.ι_mul_ι_mul_ι CliffordAlgebra.ι_mul_ι_mul_ι

@[simp]
theorem ι_range_map_lift (f : M →ₗ[R] A) (cond : ∀ m, f m * f m = algebraMap _ _ (Q m)) :
    (ι Q).range.map (lift Q ⟨f, cond⟩).toLinearMap = f.range := by
  rw [← LinearMap.range_comp, ι_comp_lift]
#align clifford_algebra.ι_range_map_lift CliffordAlgebra.ι_range_map_lift

section Map

variable {M₁ M₂ M₃ : Type _}

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

variable [Module R M₁] [Module R M₂] [Module R M₃]

variable (Q₁ : QuadraticForm R M₁) (Q₂ : QuadraticForm R M₂) (Q₃ : QuadraticForm R M₃)

/-- Any linear map that preserves the quadratic form lifts to an `alg_hom` between algebras.

See `clifford_algebra.equiv_of_isometry` for the case when `f` is a `quadratic_form.isometry`. -/
def map (f : M₁ →ₗ[R] M₂) (hf : ∀ m, Q₂ (f m) = Q₁ m) :
    CliffordAlgebra Q₁ →ₐ[R] CliffordAlgebra Q₂ :=
  CliffordAlgebra.lift Q₁
    ⟨(CliffordAlgebra.ι Q₂).comp f, fun m => (ι_sq_scalar _ _).trans <| RingHom.congr_arg _ <| hf m⟩
#align clifford_algebra.map CliffordAlgebra.map

@[simp]
theorem map_comp_ι (f : M₁ →ₗ[R] M₂) (hf) :
    (map Q₁ Q₂ f hf).toLinearMap.comp (ι Q₁) = (ι Q₂).comp f :=
  ι_comp_lift _ _
#align clifford_algebra.map_comp_ι CliffordAlgebra.map_comp_ι

@[simp]
theorem map_apply_ι (f : M₁ →ₗ[R] M₂) (hf) (m : M₁) : map Q₁ Q₂ f hf (ι Q₁ m) = ι Q₂ (f m) :=
  lift_ι_apply _ _ m
#align clifford_algebra.map_apply_ι CliffordAlgebra.map_apply_ι

@[simp]
theorem map_id :
    (map Q₁ Q₁ (LinearMap.id : M₁ →ₗ[R] M₁) fun m => rfl) = AlgHom.id R (CliffordAlgebra Q₁) :=
  by
  ext m
  exact map_apply_ι _ _ _ _ m
#align clifford_algebra.map_id CliffordAlgebra.map_id

@[simp]
theorem map_comp_map (f : M₂ →ₗ[R] M₃) (hf) (g : M₁ →ₗ[R] M₂) (hg) :
    (map Q₂ Q₃ f hf).comp (map Q₁ Q₂ g hg) = map Q₁ Q₃ (f.comp g) fun m => (hf _).trans <| hg m :=
  by
  ext m
  dsimp only [LinearMap.comp_apply, AlgHom.comp_apply, AlgHom.toLinearMap_apply, AlgHom.id_apply]
  rw [map_apply_ι, map_apply_ι, map_apply_ι, LinearMap.comp_apply]
#align clifford_algebra.map_comp_map CliffordAlgebra.map_comp_map

@[simp]
theorem ι_range_map_map (f : M₁ →ₗ[R] M₂) (hf : ∀ m, Q₂ (f m) = Q₁ m) :
    (ι Q₁).range.map (map Q₁ Q₂ f hf).toLinearMap = f.range.map (ι Q₂) :=
  (ι_range_map_lift _ _).trans (LinearMap.range_comp _ _)
#align clifford_algebra.ι_range_map_map CliffordAlgebra.ι_range_map_map

variable {Q₁ Q₂ Q₃}

/-- Two `clifford_algebra`s are equivalent as algebras if their quadratic forms are
equivalent. -/
@[simps apply]
def equivOfIsometry (e : Q₁.Isometry Q₂) : CliffordAlgebra Q₁ ≃ₐ[R] CliffordAlgebra Q₂ :=
  AlgEquiv.ofAlgHom (map Q₁ Q₂ e e.map_app) (map Q₂ Q₁ e.symm e.symm.map_app)
    ((map_comp_map _ _ _ _ _ _ _).trans <|
      by
      convert map_id _ using 2
      ext m
      exact e.to_linear_equiv.apply_symm_apply m)
    ((map_comp_map _ _ _ _ _ _ _).trans <|
      by
      convert map_id _ using 2
      ext m
      exact e.to_linear_equiv.symm_apply_apply m)
#align clifford_algebra.equiv_of_isometry CliffordAlgebra.equivOfIsometry

@[simp]
theorem equivOfIsometry_symm (e : Q₁.Isometry Q₂) :
    (equivOfIsometry e).symm = equivOfIsometry e.symm :=
  rfl
#align clifford_algebra.equiv_of_isometry_symm CliffordAlgebra.equivOfIsometry_symm

@[simp]
theorem equivOfIsometry_trans (e₁₂ : Q₁.Isometry Q₂) (e₂₃ : Q₂.Isometry Q₃) :
    (equivOfIsometry e₁₂).trans (equivOfIsometry e₂₃) = equivOfIsometry (e₁₂.trans e₂₃) :=
  by
  ext x
  exact AlgHom.congr_fun (map_comp_map Q₁ Q₂ Q₃ _ _ _ _) x
#align clifford_algebra.equiv_of_isometry_trans CliffordAlgebra.equivOfIsometry_trans

@[simp]
theorem equivOfIsometry_refl :
    (equivOfIsometry <| QuadraticForm.Isometry.refl Q₁) = AlgEquiv.refl :=
  by
  ext x
  exact AlgHom.congr_fun (map_id Q₁) x
#align clifford_algebra.equiv_of_isometry_refl CliffordAlgebra.equivOfIsometry_refl

end Map

variable (Q)

/-- If the quadratic form of a vector is invertible, then so is that vector. -/
def invertibleιOfInvertible (m : M) [Invertible (Q m)] : Invertible (ι Q m)
    where
  invOf := ι Q (⅟ (Q m) • m)
  invOf_mul_self := by
    rw [map_smul, smul_mul_assoc, ι_sq_scalar, Algebra.smul_def, ← map_mul, invOf_mul_self, map_one]
  mul_invOf_self := by
    rw [map_smul, mul_smul_comm, ι_sq_scalar, Algebra.smul_def, ← map_mul, invOf_mul_self, map_one]
#align clifford_algebra.invertible_ι_of_invertible CliffordAlgebra.invertibleιOfInvertible

/-- For a vector with invertible quadratic form, $v^{-1} = \frac{v}{Q(v)}$ -/
theorem invOf_ι (m : M) [Invertible (Q m)] [Invertible (ι Q m)] : ⅟ (ι Q m) = ι Q (⅟ (Q m) • m) :=
  by
  letI := invertible_ι_of_invertible Q m
  convert(rfl : ⅟ (ι Q m) = _)
#align clifford_algebra.inv_of_ι CliffordAlgebra.invOf_ι

theorem isUnit_ι_of_isUnit {m : M} (h : IsUnit (Q m)) : IsUnit (ι Q m) :=
  by
  cases h.nonempty_invertible
  letI := invertible_ι_of_invertible Q m
  exact isUnit_of_invertible (ι Q m)
#align clifford_algebra.is_unit_ι_of_is_unit CliffordAlgebra.isUnit_ι_of_isUnit

/-- $aba^{-1}$ is a vector. -/
theorem ι_mul_ι_mul_invOf_ι (a b : M) [Invertible (ι Q a)] [Invertible (Q a)] :
    ι Q a * ι Q b * ⅟ (ι Q a) = ι Q ((⅟ (Q a) * QuadraticForm.polar Q a b) • a - b) := by
  rw [inv_of_ι, map_smul, mul_smul_comm, ι_mul_ι_mul_ι, ← map_smul, smul_sub, smul_smul, smul_smul,
    invOf_mul_self, one_smul]
#align clifford_algebra.ι_mul_ι_mul_inv_of_ι CliffordAlgebra.ι_mul_ι_mul_invOf_ι

/-- $a^{-1}ba$ is a vector. -/
theorem invOf_ι_mul_ι_mul_ι (a b : M) [Invertible (ι Q a)] [Invertible (Q a)] :
    ⅟ (ι Q a) * ι Q b * ι Q a = ι Q ((⅟ (Q a) * QuadraticForm.polar Q a b) • a - b) := by
  rw [inv_of_ι, map_smul, smul_mul_assoc, smul_mul_assoc, ι_mul_ι_mul_ι, ← map_smul, smul_sub,
    smul_smul, smul_smul, invOf_mul_self, one_smul]
#align clifford_algebra.inv_of_ι_mul_ι_mul_ι CliffordAlgebra.invOf_ι_mul_ι_mul_ι

end CliffordAlgebra

namespace TensorAlgebra

variable {Q}

/-- The canonical image of the `tensor_algebra` in the `clifford_algebra`, which maps
`tensor_algebra.ι R x` to `clifford_algebra.ι Q x`. -/
def toClifford : TensorAlgebra R M →ₐ[R] CliffordAlgebra Q :=
  TensorAlgebra.lift R (CliffordAlgebra.ι Q)
#align tensor_algebra.to_clifford TensorAlgebra.toClifford

@[simp]
theorem toClifford_ι (m : M) : (TensorAlgebra.ι R m).toClifford = CliffordAlgebra.ι Q m := by
  simp [to_clifford]
#align tensor_algebra.to_clifford_ι TensorAlgebra.toClifford_ι

end TensorAlgebra


def hello := "world"
def Implies(p q:Prop):Prop:=p->q

#check Not
#check Implies
#check And
variable{p q:Prop}
variable(r:Prop)
#check p->q
-- #check (Sort -1) -> (Sort -1)
#check And p q
#check p ∧ q
def n:Nat:=1
def m:Nat:=2
#eval n+m
-- #check n->m
-- #check n->p
#check Nat
#check Nat->Sort
#check Prop
#check Sort 0
#check Sort 1
#check Sort 2
#check Nat->Sort 1

structure Proof(p:Prop):Type where proof:p
#check Proof

axiom and_comm(p q:Prop):Proof (Implies (And p q) (And q p))
#check and_comm

axiom modus_ponens:(p q:Prop)->(Proof (Implies p q))->Proof p->Proof q
#check modus_ponens p q

-- axiom implies_intro : (p q : Prop) → (Proof p → Proof q) → Proof (Implies p q)
axiom implies_intro : (p q : Prop) → Proof q → Proof (Implies p q)

-- theorem t1 : p → q → p := fun hp : p => fun _ : q => hp
/- theorem t1 : p → q → p :=
  fun hp : p =>
  fun _ : q =>
  show p from hp -/
theorem t1 (hp : p) (_ : q) : p := hp
#print t1
#check t1

def f1:p->q->p:=fun hp:p=>fun hq:q=>hp
#check f1
/- variable(hp:p)
variable(hq:q) -/
-- #eval f1 hp hq

def sum0:Nat->Nat->Nat:=fun a:Nat=>fun b:Nat=>a+b
def sum2:Nat->Nat:= sum0 2
#eval sum2 4

axiom hp : p
theorem t2 : q → p := t1 hp


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

import linear_algebra.basic

/-!
# Basics on bilinear maps

This file provides basics on bilinear maps. The most general form considered are maps that are
semilinear in both arguments. They are of type `M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P`, where `M` and `N`
are modules over `R` and `S` respectively, `P` is a module over both `R₂` and `S₂` with
commuting actions, and `ρ₁₂ : R →+* R₂` and `σ₁₂ : S →+* S₂`.

## Main declarations

* `linear_map.mk₂`: a constructor for bilinear maps,
  taking an unbundled function together with proof witnesses of bilinearity
* `linear_map.flip`: turns a bilinear map `M × N → P` into `N × M → P`
* `linear_map.lcomp` and `linear_map.llcomp`: composition of linear maps as a bilinear map
* `linear_map.compl₂`: composition of a bilinear map `M × N → P` with a linear map `Q → M`
* `linear_map.compr₂`: composition of a bilinear map `M × N → P` with a linear map `Q → N`
* `linear_map.lsmul`: scalar multiplication as a bilinear map `R × M → M`

## Tags

bilinear
-/

namespace linear_map

section semiring

-- the `ₗ` subscript variables are for special cases about linear (as opposed to semilinear) maps
variables {R : Type*} [semiring R] {S : Type*} [semiring S]
variables {R₂ : Type*} [semiring R₂] {S₂ : Type*} [semiring S₂]
variables {M : Type*} {N : Type*} {P : Type*}
variables {Nₗ : Type*} {Pₗ : Type*}
variables {M' : Type*} {N' : Type*} {P' : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ]
variables [add_comm_group M'] [add_comm_group N'] [add_comm_group P']
variables [module R M] [module S N] [module R₂ P] [module S₂ P]
variables [module R Pₗ] [module S Pₗ]
variables [module R M'] [module S N'] [module R₂ P'] [module S₂ P']
variables [smul_comm_class S₂ R₂ P] [smul_comm_class S R Pₗ] [smul_comm_class S₂ R₂ P']
variables {ρ₁₂ : R →+* R₂} {σ₁₂ : S →+* S₂}

variables (ρ₁₂ σ₁₂)
/-- Create a bilinear map from a function that is semilinear in each component.
See `mk₂'` and `mk₂` for the linear case. -/
def mk₂'ₛₗ (f : M → N → P)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = (ρ₁₂ c) • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = (σ₁₂ c) • f m n) : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P :=
{ to_fun := λ m, { to_fun := f m, map_add' := H3 m, map_smul' := λ c, H4 c m},
  map_add' := λ m₁ m₂, linear_map.ext $ H1 m₁ m₂,
  map_smul' := λ c m, linear_map.ext $ H2 c m }
variables {ρ₁₂ σ₁₂}

@[simp] theorem mk₂'ₛₗ_apply
  (f : M → N → P) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂'ₛₗ ρ₁₂ σ₁₂ f H1 H2 H3 H4 : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) m n = f m n := rfl

variables (R S)
/-- Create a bilinear map from a function that is linear in each component.
See `mk₂` for the special case where both arguments come from modules over the same ring. -/
def mk₂' (f : M → N → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:S) m n, f m (c • n) = c • f m n) : M →ₗ[R] N →ₗ[S] Pₗ :=
mk₂'ₛₗ (ring_hom.id R) (ring_hom.id S) f H1 H2 H3 H4
variables {R S}

@[simp] theorem mk₂'_apply
  (f : M → N → Pₗ) {H1 H2 H3 H4} (m : M) (n : N) :
  (mk₂' R S f H1 H2 H3 H4 : M →ₗ[R] N →ₗ[S] Pₗ) m n = f m n := rfl

theorem ext₂ {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P}
  (H : ∀ m n, f m n = g m n) : f = g :=
linear_map.ext (λ m, linear_map.ext $ λ n, H m n)

section

local attribute [instance] smul_comm_class.symm

/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map from `M × N` to
`P`, change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def flip (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) : N →ₛₗ[σ₁₂] M →ₛₗ[ρ₁₂] P :=
mk₂'ₛₗ σ₁₂ ρ₁₂ (λ n m, f m n)
  (λ n₁ n₂ m, (f m).map_add _ _)
  (λ c n m, (f m).map_smulₛₗ _ _)
  (λ n m₁ m₂, by rw f.map_add; refl)
  (λ c n m, by rw f.map_smulₛₗ; refl)

end

@[simp] theorem flip_apply (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (m : M) (n : N) : flip f n m = f m n := rfl

open_locale big_operators

variables {R}
theorem flip_inj {f g : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P} (H : flip f = flip g) : f = g :=
ext₂ $ λ m n, show flip f n m = flip g n m, by rw H

theorem map_zero₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (y) : f 0 y = 0 :=
(flip f y).map_zero

theorem map_neg₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y) : f (-x) y = -f x y :=
(flip f y).map_neg _

theorem map_sub₂ (f : M' →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P') (x y z) : f (x - y) z = f x z - f y z :=
(flip f z).map_sub _ _

theorem map_add₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (x₁ x₂ y) : f (x₁ + x₂) y = f x₁ y + f x₂ y :=
(flip f y).map_add _ _

theorem map_smul₂ (f : M →ₗ[R] N →ₗ[S] Pₗ) (r : R) (x y) : f (r • x) y = r • f x y :=
(flip f y).map_smul _ _

theorem map_smulₛₗ₂ (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (r : R) (x y) : f (r • x) y = (ρ₁₂ r) • f x y :=
(flip f y).map_smulₛₗ _ _

theorem map_sum₂ {ι : Type*} (f : M →ₛₗ[ρ₁₂] N →ₛₗ[σ₁₂] P) (t : finset ι) (x : ι → M) (y) :
  f (∑ i in t, x i) y = ∑ i in t, f (x i) y :=
(flip f y).map_sum

end semiring

section comm_semiring

variables {R : Type*} [comm_semiring R] {R₂ : Type*} [comm_semiring R₂]
variables {R₃ : Type*} [comm_semiring R₃] {R₄ : Type*} [comm_semiring R₄]
variables {M : Type*} {N : Type*} {P : Type*} {Q : Type*}
variables {Nₗ : Type*} {Pₗ : Type*} {Qₗ : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
variables [add_comm_monoid Nₗ] [add_comm_monoid Pₗ] [add_comm_monoid Qₗ]
variables [module R M] [module R₂ N] [module R₃ P] [module R₄ Q]
variables [module R Nₗ] [module R Pₗ] [module R Qₗ]
variables {σ₁₂ : R →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R →+* R₃}
variables {σ₄₂ : R₄ →+* R₂} {σ₄₃ : R₄ →+* R₃}
variables [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] [ring_hom_comp_triple σ₄₂ σ₂₃ σ₄₃]

variables (R)

/-- Create a bilinear map from a function that is linear in each component.

This is a shorthand for `mk₂'` for the common case when `R = S`. -/
def mk₂ (f : M → Nₗ → Pₗ)
  (H1 : ∀ m₁ m₂ n, f (m₁ + m₂) n = f m₁ n + f m₂ n)
  (H2 : ∀ (c:R) m n, f (c • m) n = c • f m n)
  (H3 : ∀ m n₁ n₂, f m (n₁ + n₂) = f m n₁ + f m n₂)
  (H4 : ∀ (c:R) m n, f m (c • n) = c • f m n) : M →ₗ[R] Nₗ →ₗ[R] Pₗ :=
mk₂' R R f H1 H2 H3 H4

@[simp] theorem mk₂_apply
  (f : M → Nₗ → Pₗ) {H1 H2 H3 H4} (m : M) (n : Nₗ) :
  (mk₂ R f H1 H2 H3 H4 : M →ₗ[R] Nₗ →ₗ[R] Pₗ) m n = f m n := rfl

variables (R M N P)
/-- Given a linear map from `M` to linear maps from `N` to `P`, i.e., a bilinear map `M → N → P`,
change the order of variables and get a linear map from `N` to linear maps from `M` to `P`. -/
def lflip : (M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P) →ₗ[R₃] N →ₛₗ[σ₂₃] M →ₛₗ[σ₁₃] P :=
{ to_fun := flip, map_add' := λ _ _, rfl, map_smul' := λ _ _, rfl }
variables {R M N P}

variables (f : M →ₛₗ[σ₁₃] N →ₛₗ[σ₂₃] P)

@[simp] theorem lflip_apply (m : M) (n : N) : lflip R M N P f n m = f m n := rfl

variables (R Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def lcomp (f : M →ₗ[R] Nₗ) : (Nₗ →ₗ[R] Pₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip $ linear_map.comp (flip id) f

variables {R Pₗ}

@[simp] theorem lcomp_apply (f : M →ₗ[R] Nₗ) (g : Nₗ →ₗ[R] Pₗ) (x : M) :
  lcomp R Pₗ f g x = g (f x) := rfl

variables (P σ₂₃)
/-- Composing a semilinear map `M → N` and a semilinear map `N → P` to form a semilinear map
`M → P` is itself a linear map. -/
def lcompₛₗ (f : M →ₛₗ[σ₁₂] N) : (N →ₛₗ[σ₂₃] P) →ₗ[R₃] M →ₛₗ[σ₁₃] P :=
flip $ linear_map.comp (flip id) f
variables {P σ₂₃}

include σ₁₃
@[simp] theorem lcompₛₗ_apply (f : M →ₛₗ[σ₁₂] N) (g : N →ₛₗ[σ₂₃] P) (x : M) :
  lcompₛₗ P σ₂₃ f g x = g (f x) := rfl
omit σ₁₃

variables (R M Nₗ Pₗ)
/-- Composing a linear map `M → N` and a linear map `N → P` to form a linear map `M → P`. -/
def llcomp : (Nₗ →ₗ[R] Pₗ) →ₗ[R] (M →ₗ[R] Nₗ) →ₗ[R] M →ₗ[R] Pₗ :=
flip { to_fun := lcomp R Pₗ,
       map_add' := λ f f', ext₂ $ λ g x, g.map_add _ _,
       map_smul' := λ (c : R) f, ext₂ $ λ g x, g.map_smul _ _ }
variables {R M Nₗ Pₗ}

section
@[simp] theorem llcomp_apply (f : Nₗ →ₗ[R] Pₗ) (g : M →ₗ[R] Nₗ) (x : M) :
  llcomp R M Nₗ Pₗ f g x = f (g x) := rfl
end

/-- Composing a linear map `Q → N` and a bilinear map `M → N → P` to
form a bilinear map `M → Q → P`. -/
def compl₂ (g : Q →ₛₗ[σ₄₂] N) : M →ₛₗ[σ₁₃] Q →ₛₗ[σ₄₃] P := (lcompₛₗ _ _ g).comp f

include σ₄₃
@[simp]

/-- Composing a linear map `P → Q` and a bilinear map `M → N → P` to
form a bilinear map `M → N → Q`. -/
def compr₂ (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) : M →ₗ[R] Nₗ →ₗ[R] Qₗ :=
(llcomp R Nₗ Pₗ Qₗ g) ∘ₗ f

@[simp] theorem compr₂_apply (f : M →ₗ[R] Nₗ →ₗ[R] Pₗ) (g : Pₗ →ₗ[R] Qₗ) (m : M) (n : Nₗ) :
  f.compr₂ g m n = g (f m n) := rfl

variables (R M)
/-- Scalar multiplication as a bilinear map `R → M → M`. -/
def lsmul : R →ₗ[R] M →ₗ[R] M :=
mk₂ R (•) add_smul (λ _ _ _, mul_smul _ _ _) smul_add
(λ r s m, by simp only [smul_smul, smul_eq_mul, mul_comm])
variables {R M}

@[simp] theorem lsmul_apply (r : R) (m : M) : lsmul R M r m = r • m := rfl

end comm_semiring

section comm_ring

variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]

lemma lsmul_injective [no_zero_smul_divisors R M] {x : R} (hx : x ≠ 0) :
  function.injective (lsmul R M x) :=
smul_right_injective _ hx

lemma ker_lsmul [no_zero_smul_divisors R M] {a : R} (ha : a ≠ 0) :
  (linear_map.lsmul R M a).ker = ⊥ :=
linear_map.ker_eq_bot_of_injective (linear_map.lsmul_injective ha)

end comm_ring

end linear_map


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Std.Data.Array.Basic
import Std.Data.Array.Lemmas

import Algdata.Init.Nat
import Algdata.Data.Nat.Rec
import Algdata.Data.List.Basic

/-!

# Miscellaneous lemmas for `Array`

Lemmas around `Array` including `Classical`-free variants of those in Std library.

-/

namespace Array

universe u v w

variable {α : Type u}

/-!
## Equality
-/

/-- The equality of `Array`. -/
protected
theorem eq : ∀ (x y : Array α), x.data = y.data → x=y
| Array.mk _, Array.mk _, rfl => rfl

/-!
## `Array.size`
-/

@[simp]
theorem size_nil {α : Type _} : @Array.size α #[] = 0 := rfl

@[simp]
theorem size_cons (a : α) (as : List α) : Array.size {data := a::as} = (Array.size {data := as}).succ := rfl

theorem size_eq_length_of_data (x : Array α) : x.size = x.data.length := rfl

/-!
## `Array.foldl`
-/

/-- Induction step of `foldl` in terms of `Array.data`. -/
theorem foldl_cons {β : Type v} (f : β → α → β) (init : β) (a : α) (as : List α) : foldl f init {data := a::as} = foldl f (f init a) {data := as} := by
  rw [Array.foldl, Array.foldl]
  rw [Array.foldlM, Array.foldlM]
  rw [Id.run, Id.run]
  simp
  rw [foldlM.loop, dif_pos (Nat.zero_lt_succ _)]
  simp
  suffices t : ∀ v vs h l k w, foldlM.loop (m := Id) f {data := v::vs} vs.length.succ h l (k+1) w = foldlM.loop (m := Id) f {data := vs} vs.length (Nat.le_of_succ_le_succ h) l k w by
    rw [t]
    apply congrArg
    rfl
  intros v vs h l
  induction l with
  | zero =>
    intro k w
    rw [foldlM.loop, foldlM.loop]
    simp
    apply Decidable.byCases (p := k < vs.length)
    case h1 =>
      intro hpos
      rw [dif_pos hpos, dif_pos (Nat.succ_lt_succ hpos)]
    case h2 =>
      intro hneg
      have : ¬(k+1 < vs.length.succ) :=
        fun h' => hneg (Nat.lt_of_succ_lt_succ h')
      rw [dif_neg hneg, dif_neg this]
  | succ l' hi =>
    intro k w
    rw [foldlM.loop, foldlM.loop]
    apply Decidable.byCases (p := k < vs.length)
    case h1 =>
      intro hpos
      rw [dif_pos hpos, dif_pos (Nat.succ_lt_succ hpos)]
      simp
      rw [hi]
      apply congrArg
      rfl
    case h2 =>
      intro hneg
      have : ¬(k+1 < vs.length.succ) :=
        fun h' => hneg (Nat.lt_of_succ_lt_succ h')
      rw [dif_neg hneg, dif_neg this]

/-- `Classical`-free analogue of `Array.foldl_eq_foldl_data` in Std -/
theorem foldl_eq_foldl_data' {β : Type v} (f : α → β → α) (init : α) (arr : Array β) : foldl f init arr = List.foldl f init arr.data := by
  cases arr with | mk bs =>
  induction bs generalizing init
  case nil => rfl
  case cons b bs h_ind =>
    rw [foldl_cons, h_ind]
    rfl

/-!
## `Array.append`
-/

theorem cons_append_data (a : α) : ∀ (as : List α) (x : Array α), ({data := a::as} ++ x).data = a::({data := as} ++ x).data
| as, mk bs => by
  induction bs generalizing as with
  | nil => intros; rfl
  | cons b bs hi =>
    rw [←Array.append_eq_append, ←Array.append_eq_append]
    unfold Array.append
    rw [foldl_cons, foldl_cons]
    exact hi (as.concat b)

theorem append_nil : ∀ (x : Array α), x ++ #[] = x
| Array.mk [] => rfl
| Array.mk (_::_) => rfl

theorem append_cons : ∀ (x : Array α) (b : α) (bs : List α), x ++ {data := b::bs} = (x.push b) ++ {data := bs} := by
  intros x b bs
  rw [←Array.append_eq_append, ←Array.append_eq_append]
  unfold Array.append
  rw [foldl_cons]

/-- `Classical`-free analogue of `append_data` in Std4. -/
theorem append_data' (x y : Array α) : (x ++ y).data = x.data ++ y.data := by
  cases y with | mk bs =>
  induction bs generalizing x
  case nil =>
    conv =>
      change (x ++ #[]).data = x.data ++ []
      rw [append_nil]
    rw [List.append_nil]
  case cons b bs h_ind =>
    rw [append_cons, h_ind]
    conv => change (x.push b).data ++ bs = x.data ++ (b::bs)
    rw [push_data, ←List.append_cons]

theorem nil_append : ∀ (x : Array α), #[] ++ x = x
| Array.mk as => by
  induction as with
  | nil => rfl
  | cons a as hi =>
    rw [append_cons]
    have : #[].push a = {data :=[a]} := rfl
    rw [this]; clear this
    apply Array.eq
    rw [cons_append_data]
    rw [(_ : {data :=[]} = #[])]
    rw [hi]
    rfl

theorem append_push : ∀ (x y : Array α) (a : α), x ++ (y.push a) = (x ++ y).push a := by
  intro x y a
  cases y with | mk bs =>
  induction bs generalizing x
  case nil => rfl
  case cons b bs h_ind =>
    dsimp [Array.push, List.concat]
    rw [append_cons, append_cons]
    have : Array.mk (List.concat bs a) = Array.push {data := bs} a := rfl
    rw [this]
    exact h_ind (x.push b)

theorem append_assoc : ∀ (x y z : Array α), (x ++ y) ++ z = x ++ (y ++ z) := by
  intro x y z
  cases z with | mk cs =>
  induction cs generalizing y
  case nil => rfl
  case cons c cs h_ind =>
    rw [append_cons, append_cons, ←append_push]
    exact h_ind (y.push c)

theorem push_as_append (x : Array α) (a : α) : x.push a = x ++ #[a] := rfl

theorem append_size : ∀ (x y : Array α), (x ++ y).size = x.size + y.size
| mk as, y => by
  induction as with
  | nil =>
    have : mk (α:=α) [] = #[] := rfl
    rw [this, nil_append]
    rw [size_nil, Nat.zero_add]
  | cons a as hi =>
    rw [Array.size, cons_append_data, List.length]
    rw [Array.size, List.length]
    rw [Nat.add_assoc, Nat.add_comm 1, ←Nat.add_assoc]
    have : List.length ({data:=as} ++ y).data = ({data:=as} ++ y).size := rfl
    rw [this, hi]

/-!
## `Array.get` and `Array.set`
-/

theorem get_cons_succ (a : α) (as : List α) (n : Fin as.length): Array.get {data := a::as} n.succ = Array.get {data := as} n := by
  rw [Array.get, Array.get]
  cases n
  rfl

theorem get_cons_succ' (a : α) (as : List α) (n : Nat) {h : n.succ < as.length.succ} : Array.get {data := a::as} ⟨n.succ,h⟩ = Array.get {data := as} ⟨n,Nat.lt_of_succ_lt_succ h⟩ := by
  have : Fin.mk n.succ h = (Fin.mk n (Nat.lt_of_succ_lt_succ h)).succ := rfl
  rw [this]
  exact get_cons_succ a as ⟨n, Nat.lt_of_succ_lt_succ h⟩

theorem set_head (a : α) (as : List α) {h : 0 < as.length.succ} (v : α) : Array.set {data := a::as} ⟨0,h⟩ v = {data := v::as} := rfl

theorem set_cons_succ (a : α) (as : List α) (n : Fin as.length) (v : α) : Array.set {data := a::as} n.succ v = #[a] ++ (Array.set {data:=as} n v) := by
  apply Array.eq
  rw [Array.set, Array.set]
  rw [Fin.val_succ_eq_succ_val]
  rw [List.set]
  have : #[a] = {data:=a::[]} := rfl
  rw [this, cons_append_data]
  have : #[] = {data:=([] : List α)} := rfl
  rw [←this, nil_append]

theorem set_cons_succ' (a : α) (as : List α) (n : Nat) (h : n.succ < as.length.succ) (v : α) : Array.set {data:=a::as} ⟨n+1,h⟩ v = #[a] ++ Array.set {data:=as} ⟨n,Nat.lt_of_succ_lt_succ h⟩ v := by
  have : Fin.mk n.succ h = (Fin.mk n (Nat.lt_of_succ_lt_succ h)).succ := rfl
  rw [this]
  rw [set_cons_succ]

/-!
## `Array.zipWith`
-/

section zipWith

variable {β : Type v} {γ : Type w}

theorem zipWithAux_nil_first (f : α → β → γ) (x : Array β) (n : Nat) (z : Array γ) : Array.zipWithAux f #[] x n z = z := by
  rw [Array.zipWithAux]
  have : ¬ (n  < @Array.size α #[]) := n.not_lt_zero
  rw [dif_neg this]

theorem zipWith_nil_first (f : α → β → γ) (x : Array β) : Array.zipWith #[] x f = #[] := zipWithAux_nil_first f x 0 #[]

theorem zipWithAux_nil_second (f : α → β → γ) (x : Array α) (n : Nat) (z : Array γ) : Array.zipWithAux f x #[] n z = z := by
  rw [Array.zipWithAux]
  apply Decidable.byCases (p := n < x.size)
  case h1 =>
    intro hpos
    have : ¬(n < @Array.size β #[]) := n.not_lt_zero
    rw [dif_pos hpos, dif_neg this]
  case h2 =>
    intro hneg
    rw [dif_neg hneg]

theorem zipWith_nil_second (f : α → β → γ) (x : Array α) : Array.zipWith x #[] f = #[] := zipWithAux_nil_second f x 0 #[]

theorem zipWithAux_cons_cons_succ (f : α → β → γ) (a : α) (as : List α) (b : β) (bs : List β) (n : Nat) (z : Array γ) : Array.zipWithAux f (Array.mk (a::as)) (Array.mk (b::bs)) (n+1) z = Array.zipWithAux f (Array.mk as) (Array.mk bs) n z := by
  rw [Array.zipWithAux]
  rw [Array.zipWithAux]
  apply Decidable.byCases (p:=n+1 < Array.size {data := a::as})
  case h1 =>
    intro hposa
    have hposa' : n < Array.size {data := as} := Nat.lt_of_succ_lt_succ hposa
    rw [dif_pos hposa, dif_pos hposa']
    apply Decidable.byCases (p:=n+1 < bs.length.succ)
    case h1 =>
      intro hposb
      have hposb' : n < bs.length := Nat.lt_of_succ_lt_succ hposb
      simp
      rw [dif_pos hposb, dif_pos hposb']; simp
      exact zipWithAux_cons_cons_succ f a as b bs n.succ _
    case h2 =>
      intro hnegb
      have hnegb' : ¬(n < bs.length) := fun h => hnegb (Nat.succ_lt_succ h)
      simp
      rw[dif_neg hnegb, dif_neg hnegb']
  case h2 =>
    intro hnega
    have hnega' : ¬(n < Array.size {data := as}) := fun h => hnega (Nat.succ_lt_succ h)
    rw [dif_neg hnega, dif_neg hnega']
termination_by _ => as.length - n

theorem zipWithAux_cons_cons_zero (f : α → β → γ) (a : α) (as : List α) (b : β) (bs : List β) (z : Array γ) : Array.zipWithAux f {data := a::as} {data := b::bs} 0 z = Array.zipWithAux f {data := as} {data := bs} 0 (z.push (f a b)) := by
  rw [zipWithAux]
  have hsza : 0 < (Array.mk (a::as)).size := Nat.zero_lt_succ _
  have hszb : 0 < (Array.mk (b::bs)).size := Nat.zero_lt_succ _
  rw [dif_pos hsza, dif_pos hszb]
  simp
  rw [zipWithAux_cons_cons_succ]
  apply congrArg
  rfl

theorem zipWithAux_buf (f : α → β → γ) : ∀ (x : Array α) (y : Array β) (n : Nat) (z : Array γ), zipWithAux f x y n z = z ++ zipWithAux f x y n #[]
| Array.mk [], y, n => by
  intros z
  have : @Array.mk α [] = #[] := rfl
  rw [this, zipWithAux_nil_first, zipWithAux_nil_first]
  rw [Array.append_nil]
| Array.mk _, Array.mk [], n => by
  intros z
  have : @Array.mk β [] = #[] := rfl
  rw [this, zipWithAux_nil_second, zipWithAux_nil_second]
  rw [Array.append_nil]
| Array.mk (a::as), Array.mk (b::bs), 0 => by
  intros z
  rw [zipWithAux_cons_cons_zero, zipWithAux_cons_cons_zero]
  rw [zipWithAux_buf f {data := as} {data := bs} 0 (z.push (f a b))]
  rw [zipWithAux_buf f {data := as} {data := bs} 0 (#[].push (f a b))]
  rw [←append_assoc, append_push, append_nil]
| Array.mk (a::as), Array.mk (b::bs), (n+1) => by
  intros z
  rw [zipWithAux_cons_cons_succ, zipWithAux_cons_cons_succ]
  exact zipWithAux_buf f {data := as} {data := bs} n z

theorem zipWith_cons_cons (f : α → β → γ) (a : α) (as : List α) (b : β) (bs : List β) : Array.zipWith {data := a::as} {data := b::bs} f = #[f a b] ++ (Array.zipWith {data := as} {data := bs} f) := by
  rw [zipWith, zipWith]
  rw [zipWithAux_buf, nil_append, zipWithAux_cons_cons_zero]
  rw [zipWithAux_buf, push_as_append, nil_append]

theorem zipWith_size (f : α → β → γ) : ∀ (x : Array α) (y : Array β), (Array.zipWith x y f).size = min x.size y.size
| Array.mk [], y => by
  conv =>
    lhs; change (zipWith #[] y f).size; rw [zipWith_nil_first]; change 0
  conv =>
    rhs; change min 0 y.size; rw [Nat.zero_min]
| x, Array.mk [] => by
  conv =>
    lhs; change (zipWith x #[] f).size; rw [zipWith_nil_second]; change 0
  conv =>
    rhs; change min x.size 0; rw [Nat.min_zero]
| Array.mk (a::as), Array.mk (b::bs) => by
  rw [zipWith_cons_cons, append_size]
  rw [size_cons, size_cons, Nat.min_succ_succ]
  have : size #[f a b] = 1 := rfl; rw [this]
  rw [zipWith_size f {data := as} {data := bs}]
  rw [Nat.add_comm]

end zipWith

/-!
## `Array.ofFn` in Std
-/

theorem ofFn_go_eq {α : Type u} {n : Nat} (f : Fin n → α) {i : Nat} {acc : Array α} : Array.ofFn.go f i acc = acc ++ Array.ofFn.go f i #[] := by
  by_cases i < n
  case pos hlt =>
    refine Nat.recAscend (motive:=λ i => ∀ acc, Array.ofFn.go f i acc = acc ++ Array.ofFn.go f i #[]) (n:=n) ?_ ?_ i (Nat.le_of_lt hlt) acc
    . dsimp; unfold Array.ofFn.go
      intro acc
      rw [dif_neg (Nat.lt_irrefl n), dif_neg (Nat.lt_irrefl n)]
      rfl
    . dsimp
      intro i hi h_ind acc
      unfold Array.ofFn.go
      rw [dif_pos hi, dif_pos hi]
      rw [h_ind (acc.push _), h_ind (#[].push _)]
      conv =>
        rhs; rw [←Array.append_assoc]
  case neg hnlt =>
    unfold Array.ofFn.go
    rw [dif_neg hnlt, dif_neg hnlt]
    rfl

theorem ofFn_go_succ {α : Type u} {n : Nat} (f : Fin n.succ → α) {i : Nat} {acc : Array α} : Array.ofFn.go f i.succ acc = Array.ofFn.go (f ∘ Fin.succ) i acc := by
  by_cases i < n
  case neg hnlt =>
    have : ¬ i.succ < n.succ := λ h => absurd (Nat.lt_of_succ_lt_succ h) hnlt
    unfold Array.ofFn.go
    rw [dif_neg this, dif_neg hnlt]
  case pos hlt =>
    refine Nat.recAscend (motive:=λ i =>∀ acc, Array.ofFn.go f i.succ acc = Array.ofFn.go (f ∘ Fin.succ) i acc) ?_ ?_ i (Nat.le_of_lt hlt) acc
      <;> dsimp
    . intro acc
      unfold Array.ofFn.go
      rw [dif_neg (Nat.lt_irrefl n.succ), dif_neg (Nat.lt_irrefl n)]
    . intro i hi h_ind acc
      unfold Array.ofFn.go
      rw [dif_pos (Nat.succ_lt_succ hi), dif_pos hi]
      rw [h_ind]
      rfl

theorem ofFn_succ {α : Type u} {n : Nat} (f : Fin n.succ → α) : (Array.ofFn f).data = f ⟨0,Nat.zero_lt_succ n⟩ :: (Array.ofFn (f ∘ Fin.succ)).data := by
  conv =>
    lhs; unfold Array.ofFn; unfold Array.ofFn.go
    rw [dif_pos n.zero_lt_succ]
    rw [Array.ofFn_go_succ, Array.ofFn_go_eq]
    rw [Array.append_data']

/-- `Classical`-free variant of `Array.getElem_ofFn` in Std -/
theorem getElem_ofFn' {α : Type u} {n : Nat} (f : Fin n → α) (i : Nat) (h : i < (Array.ofFn f).size) : (Array.ofFn f)[i] = f ⟨i, Array.size_ofFn f ▸ h⟩ := by
  induction n generalizing i
  case zero =>
    exact absurd h (Nat.not_lt_zero i)
  case succ n h_ind =>
    rw [Array.getElem_eq_data_get]
    rw [List.get_congrList (Array.ofFn_succ f)]
    cases i
    case zero => rfl
    case succ i =>
      rw [List.get_cons_succ]
      rw [←Array.getElem_eq_data_get]
      rw [h_ind]
      rfl

/-- The symmetric counterpart of `getElem_ofFn'` -/
theorem getElem_ofFn'_symm {α : Type u} {n : Nat} (f : Fin n → α) (i : Fin n) : f i = (Array.ofFn f)[i.val]'((Array.size_ofFn f).symm ▸ i.isLt) :=
  Eq.symm $ getElem_ofFn' f i.val ((Array.size_ofFn f).symm ▸ i.isLt)

end Array