import tactic
import .lesson8

noncomputable theory
open_locale classical

open PreHilbertPlane HilbertPlane Triangle

variables {Ω : Type*} [HilbertPlane Ω]
variables {A B C D E F : Ω}

lemma origin_on_ray : A ∈ pts (A=>B) :=
begin
    left,
    refl,
end
/- Any point on a ray different from its origin defines the same ray-/
lemma point_on_ray_gives_same_ray : A ≠ E → B ≠ E → E ∈ pts (A=>B) → pts (A=>B) = pts (A=>E) :=
begin
    intros hAE hBE hE,
    unfold pts,
    ext1,
    split,
    {
        dsimp,
        intro h,
        cases h with h0 h1,
        {
            subst h0,
            dsimp,
            exact origin_on_ray,
        },
        {
            dsimp at h1,
            obtain rfl | hAB := em(A = B), finish,
            right,
            dsimp,
            dsimp at hE,
            rcases hE with (hE | hE), tauto,
            cases h1,
            cases hE,
            have hco : collinear ({A, B, x, E} : set Ω),
            {
                have : {A, B, x, E} = ({A, x, B} : set Ω).union({A, E, B}),
                {
                    ext,
                    split,
                    {
                        intro h,
                        rcases h with h|h|h|h,
                        {
                            subst h, left, simp,
                        },
                        {
                            subst h, left, simp,
                        },
                        {
                            subst h, left, simp,
                        },
                        {
                            simp at h, subst h, right, simp,
                        },
                    },
                    {
                        intro h,
                        cases h;
                        finish,
                    }
                },
                rw this,
                apply collinear_union {A, x, B} {A, E, B} hAB,
                simpa using h1_left,
                simpa using hE_left,
                all_goals {finish},
            },
            {
                split,
                {
                    simp,
                    apply collinear_subset _ {A, B, x, E} _ hco,
                    intros y hy, finish,
                },
                {
                    sorry
                },
            },
        },
    },
    {
        sorry
    }
end

/- Given a line and a point, there is a point on the other side -/
lemma point_on_other_side_of_line (ℓ : Line Ω) (A : Ω) :
    ¬ A ∈ ℓ → ∃ B : Ω, ¬ B ∈ ℓ ∧ ¬ same_side ℓ A B :=
begin
    intro hA,
    rcases (same_side.at_least_two_classes ℓ) with ⟨X, Y, ⟨hX, hY, H⟩⟩,
    by_cases h1 : same_side ℓ A X,
    {
        use Y,
        split, assumption,
        intro h2,
        have h3 : same_side ℓ X Y,
        {
            rw same_side.symm_iff at h1,
            apply same_side.trans h1 h2,
        },
        exact H h3,
    },
    {
        use X,
        exact ⟨hX, h1⟩,
    }
end

/- (using C4 and C1)
Construct an angle ∟ C' A' B'' on the other side of A'=>C' from B'
that is congruent to ∟ BAC and at the same time A'B''
is congruent to AB.
-/
lemma transport_angle_to_other_ray ( A B C A' B' C' : Ω)
    (h: (▵ A B C).nondegenerate) (h': (▵ A' B' C').nondegenerate) :
    ∃ B'' : Ω, (∟ C' A' B'') ≃ (∟ B A C) ∧ A'⬝B'' ≅ A⬝B ∧ (pts (A=>B) = pts (A'=>B'')) :=
begin
    have hACp : A' ≠ C',
    {
        sorry
    },
    let ℓ := line_through A' C',
    have hApℓ: A' ∈ ℓ := line_through_left,
    have hCpℓ: C' ∈ ℓ := line_through_right,
    have hBpℓ: ¬ B' ∈ ℓ,
    {
        intro H,
        apply h',
        use ℓ, tauto,
    },
    have H := point_on_other_side_of_line ℓ B' hBpℓ,
    rcases H with ⟨E, hEℓ, hBpE⟩,
    have hnc : ¬ collinear_triple E A' C',
    {
        sorry
    },
    have hT2 : (∟ B' A' C').nondegenerate,
    {
        sorry
    },
    -- Transport the angle to the ray A'=>C'.
    have HH := C4 (∟ B' A' C') (A'=>C') E hT2 hnc,
    obtain ⟨ℓ, ⟨Q, ⟨hQ1, hQ2, hQ3, hQ4⟩⟩, huniq⟩ := HH,
    simp only at hQ3,

    sorry
end

lemma segment_union (A B C : Ω) (h : A * B * C) :
pts (A ⬝ C) = (pts (A ⬝ B)).union( pts (B ⬝ C)) :=
begin
    ext,
    split,
    {
        intro h,
        rcases h with h|h|h,
        {
            subst h,
            left,
            simp,
        },
        {
            subst h,
            right,
            simp,
        },
        {
            by_cases h1 : A * x * B,
            {
                left,
                simp [h1],
            },
            {
                right,
                simp,
                right, right,

                sorry
            }
        }
    },
    {
        intro h,
        rcases h with h|h,
        {
            simp at h ⊢,
            rcases h with h|h|h,
            {tauto},
            {
                subst h,
                tauto,
            },
            {
                right, right,

                sorry
            }
        },
        sorry
    }
end

/- Proposition 10.1 (SSS) of Hartshorne
If two triangles have their respective sides equal,
then they are congruent.
-/
theorem triangle_SSS' {A B C A' B' C' : Ω} :
(▵ A B C).nondegenerate → (▵ A' B' C').nondegenerate →
(A⬝B ≅ A'⬝B') → (A⬝C ≅ A'⬝C') → (B⬝C ≅ B'⬝C') →
(▵ A B C).is_similar(▵ A' B' C') :=
begin
    intros hT hT' hAB hAC hBC,
    /- (using C4 and C1)
    Construct an angle ∟ C' A' B'' on the other side of A'=>C' from B'
    that is congruent to ∟ BAC and at the same time A'B''
    is congruent to AB.
    -/
    have hACp : A' ≠ C',
    {
        sorry
    },
    let ℓ := line_through A' C',
    have hApℓ: A' ∈ ℓ, exact line_through_left,
    have hCpℓ: C' ∈ ℓ, exact line_through_right,
    have hBpℓ: ¬ B' ∈ ℓ,
    {
        intro h,
        apply hT',
        use ℓ, tauto,
    },

    have H := point_on_other_side_of_line ℓ B' hBpℓ,
    rcases H with ⟨E, hEℓ, hBpE⟩,
    have hnc : ¬ collinear_triple E A' C',
    {
        sorry
    },
    have hT2 : (∟ B' A' C').nondegenerate,
    {
        sorry
    },
    -- Let B₀ be the point defining the angle transported to the ray A'=>C'.
    obtain ⟨B₀,h⟩ := HilbertPlane.C4 (∟ B' A' C') (A'=>C') E hT2 hnc,
    have hBpp : ∃ B'' : Ω, (∟ C' A' B'') ≃ (∟ B A C) ∧ A'⬝B'' ≅ A⬝B,
    {
        sorry
    },

    --repeat {split},
    --repeat {assumption},
    sorry
end

theorem triangle_SSS (T T' : Triangle Ω) :
(T.A⬝T.B ≅ T'.A⬝T'.B) → (T.A⬝T.C ≅ T'.A⬝T'.C) → (T.B⬝T.C ≅ T'.B⬝T'.C) → T.is_congruent T' :=
begin
    intros hAB hAC hBC,
    rw is_congruent,
    suffices : T.is_similar T', by finish,
    apply triangle_SSS' _ _ hAB hAC hBC;
    sorry
end

lemma similar_of_congruent (T R : Triangle Ω) (h : is_congruent T R) :
is_similar T R :=
begin
	sorry
end


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

! This file was ported from Lean 3 source module group_theory.group_action.sub_mul_action.pointwise
! leanprover-community/mathlib commit 2bbc7e3884ba234309d2a43b19144105a753292e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.GroupAction.SubMulAction

/-!
# Pointwise monoid structures on SubMulAction

This file provides `SubMulAction.Monoid` and weaker typeclasses, which show that `SubMulAction`s
inherit the same pointwise multiplications as sets.

To match `Submodule.idemSemiring`, we do not put these in the `Pointwise` locale.

-/

open Pointwise

variable {R M : Type _}

namespace SubMulAction

section One

variable [Monoid R] [MulAction R M] [One M]

instance : One (SubMulAction R M)
    where one :=
    { carrier := Set.range fun r : R => r • (1 : M)
      smul_mem' := fun r _ ⟨r', hr'⟩ => hr' ▸ ⟨r * r', mul_smul _ _ _⟩ }

theorem coe_one : ↑(1 : SubMulAction R M) = Set.range fun r : R => r • (1 : M) :=
  rfl
#align sub_mul_action.coe_one SubMulAction.coe_one

@[simp]
theorem mem_one {x : M} : x ∈ (1 : SubMulAction R M) ↔ ∃ r : R, r • (1 : M) = x :=
  Iff.rfl
#align sub_mul_action.mem_one SubMulAction.mem_one

theorem subset_coe_one : (1 : Set M) ⊆ (1 : SubMulAction R M) := fun _ hx =>
  ⟨1, (one_smul _ _).trans hx.symm⟩
#align sub_mul_action.subset_coe_one SubMulAction.subset_coe_one

end One

section Mul

variable [Monoid R] [MulAction R M] [Mul M] [IsScalarTower R M M]

instance : Mul (SubMulAction R M)
    where mul p q :=
    { carrier := Set.image2 (· * ·) p q
      smul_mem' := fun r _ ⟨m₁, m₂, hm₁, hm₂, h⟩ =>
        h ▸ smul_mul_assoc r m₁ m₂ ▸ Set.mul_mem_mul (p.smul_mem _ hm₁) hm₂ }

@[norm_cast]
theorem coe_mul (p q : SubMulAction R M) : ↑(p * q) = (p * q : Set M) :=
  rfl
#align sub_mul_action.coe_mul SubMulAction.coe_mul

theorem mem_mul {p q : SubMulAction R M} {x : M} : x ∈ p * q ↔ ∃ y z, y ∈ p ∧ z ∈ q ∧ y * z = x :=
  Set.mem_mul
#align sub_mul_action.mem_mul SubMulAction.mem_mul

end Mul

section MulOneClass

variable [Monoid R] [MulAction R M] [MulOneClass M] [IsScalarTower R M M] [SMulCommClass R M M]

-- porting note: giving the instance the name `mulOneClass`
instance mulOneClass : MulOneClass (SubMulAction R M)
    where
  mul := (· * ·)
  one := 1
  mul_one a := by
    ext x
    simp only [mem_mul, mem_one, mul_smul_comm, exists_and_left, exists_exists_eq_and, mul_one]
    constructor
    · rintro ⟨y, hy, r, rfl⟩
      exact smul_mem _ _ hy
    · intro hx
      exact ⟨x, hx, 1, one_smul _ _⟩
  one_mul a := by
    ext x
    simp only [mem_mul, mem_one, smul_mul_assoc, exists_and_left, exists_exists_eq_and, one_mul]
    refine' ⟨_, fun hx => ⟨1, x, hx, one_smul _ _⟩⟩
    rintro ⟨r, y, hy, rfl⟩
    exact smul_mem _ _ hy

end MulOneClass

section Semigroup

variable [Monoid R] [MulAction R M] [Semigroup M] [IsScalarTower R M M]

-- porting note: giving the instance the name `semiGroup`
instance semiGroup : Semigroup (SubMulAction R M)
    where
  mul := (· * ·)
  mul_assoc _ _ _ := SetLike.coe_injective (mul_assoc (_ : Set _) _ _)

end Semigroup

section Monoid

variable [Monoid R] [MulAction R M] [Monoid M] [IsScalarTower R M M] [SMulCommClass R M M]

instance : Monoid (SubMulAction R M) :=
  { SubMulAction.semiGroup,
    SubMulAction.mulOneClass with
    mul := (· * ·)
    one := 1 }

theorem coe_pow (p : SubMulAction R M) : ∀ {n : ℕ} (_ : n ≠ 0), (p ^ n : Set M) = ((p : Set M) ^ n)
  | 0, hn => (hn rfl).elim
  | 1, _ => by rw [pow_one, pow_one]
  | n + 2, _ => by
    rw [pow_succ _ (n + 1), pow_succ _ (n + 1), coe_mul, coe_pow _ n.succ_ne_zero]
#align sub_mul_action.coe_pow SubMulAction.coe_pow

theorem subset_coe_pow (p : SubMulAction R M) : ∀ {n : ℕ}, ((p : Set M) ^ n) ⊆ (p ^ n : Set M)
  | 0 => by
    rw [pow_zero, pow_zero]
    exact subset_coe_one
  | n + 1 => by rw [← Nat.succ_eq_add_one, coe_pow _ n.succ_ne_zero]
#align sub_mul_action.subset_coe_pow SubMulAction.subset_coe_pow

end Monoid

end SubMulAction


import ring_theory.tensor_product

import to_mathlib_maybe.Hilbert_space

---- PARTIAL TRACES

open algebra.tensor_product

open_locale tensor_product

noncomputable theory

variables
{ℋ₁ : Type} [complex_hilbert_space ℋ₁]
{ℋ₂ : Type} [complex_hilbert_space ℋ₂]
{ℋ₃ : Type} [complex_hilbert_space ℋ₃]

namespace bipartite

def Tr₁ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂)) : ℋ₂ →ₗ[ℂ] ℋ₂ :=
sorry

def Tr₂ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂)) : ℋ₁ →ₗ[ℂ] ℋ₁ :=
sorry

end bipartite

namespace tripartite

def Tr₁ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃) :=
sorry

def Tr₂ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃) :=
sorry

def Tr₃ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) :=
sorry

def Tr₁₂ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : ℋ₃ →ₗ[ℂ] ℋ₃ :=
sorry

def Tr₁₃ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : ℋ₂ →ₗ[ℂ] ℋ₂ :=
sorry

def Tr₂₃ (ρ : (ℋ₁ →ₗ[ℂ] ℋ₁) ⊗[ℂ] (ℋ₂ →ₗ[ℂ] ℋ₂) ⊗[ℂ] (ℋ₃ →ₗ[ℂ] ℋ₃)) : ℋ₁ →ₗ[ℂ] ℋ₁ :=
sorry

end tripartite

variables (ρ : ℋ₁ →ₗ[ℂ] ℋ₁)
(σ : ℋ₂ →ₗ[ℂ] ℋ₂)

local notation ρ ` ⊗ ` σ := ρ ⊗ₜ[ℂ] σ

namespace bipartite

theorem Tr₁_tmul : Tr₁(ρ ⊗ σ) = σ := sorry

theorem Tr₂_tmul : Tr₂(ρ ⊗ σ) = ρ := sorry

end bipartite

variables (τ : ℋ₃ →ₗ[ℂ] ℋ₃)

namespace tripartite

theorem Tr₁_tmul_tmul : Tr₁((ρ ⊗ σ) ⊗ τ) = σ ⊗ τ := sorry

theorem Tr₂_tmul_tmul : Tr₂((ρ ⊗ σ) ⊗ τ) = ρ ⊗ τ := sorry

theorem Tr₃_tmul_tmul : Tr₃((ρ ⊗ σ) ⊗ τ) = ρ ⊗ σ := sorry

theorem Tr₁₂_tmul_tmul : Tr₁₂((ρ ⊗ σ) ⊗ τ) = τ := sorry

theorem Tr₁₃_tmul_tmul : Tr₁₃((ρ ⊗ σ) ⊗ τ) = σ := sorry

theorem Tr₂₃_tmul_tmul : Tr₂₃((ρ ⊗ σ) ⊗ τ) = ρ := sorry

end tripartite

---- USAGE

open bipartite tripartite

example : Tr₂(ρ ⊗ σ) = ρ :=
begin
    apply Tr₂_tmul,
end

example : Tr₂((ρ ⊗ σ) ⊗ τ) = ρ ⊗ τ :=
begin
    apply Tr₂_tmul_tmul,
end


import Lib.Tactic

namespace Prod
variable {α α' β β'} (x y : α × β)
variable {f : α → α'} {g : β → β'}

def eta :
  x.1 = y.1 →
  x.2 = y.2 →
  x = y := by
cases x; cases y; simp <;> auto

@[simp]
theorem fst_map : (x.map f g).1 = f x.1 :=
by cases x; refl

@[simp]
theorem snd_map : (x.map f g).2 = g x.2 :=
by cases x; refl

end Prod


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Module.monoidal
import algebra.category.Algebra.basic
import category_theory.monoidal.Mon_

/-!
# `Mon_ (Module R) ≌ Algebra R`

The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.

Moreover, this equivalence is compatible with the forgetful functors to `Module R`.
-/

universes v u

open category_theory
open linear_map

open_locale tensor_product
local attribute [ext] tensor_product.ext

namespace Module

variables {R : Type u} [comm_ring R]

namespace Mon_Module_equivalence_Algebra

@[simps]
instance (A : Mon_ (Module.{u} R)) : ring A.X :=
{ one := A.one (1 : R),
  mul := λ x y, A.mul (x ⊗ₜ y),
  one_mul := λ x, by { convert linear_map.congr_fun A.one_mul ((1 : R) ⊗ₜ x), simp, },
  mul_one := λ x, by { convert linear_map.congr_fun A.mul_one (x ⊗ₜ (1 : R)), simp, },
  mul_assoc := λ x y z, by convert linear_map.congr_fun A.mul_assoc ((x ⊗ₜ y) ⊗ₜ z),
  left_distrib := λ x y z,
  begin
    convert A.mul.map_add (x ⊗ₜ y) (x ⊗ₜ z),
    rw ←tensor_product.tmul_add,
    refl,
  end,
  right_distrib := λ x y z,
  begin
    convert A.mul.map_add (x ⊗ₜ z) (y ⊗ₜ z),
    rw ←tensor_product.add_tmul,
    refl,
  end,
  ..(by apply_instance : add_comm_group A.X) }

instance (A : Mon_ (Module.{u} R)) : algebra R A.X :=
{ map_zero' := A.one.map_zero,
  map_one' := rfl,
  map_mul' := λ x y,
  begin
    have h := linear_map.congr_fun A.one_mul.symm (x ⊗ₜ (A.one y)),
    rwa [monoidal_category.left_unitor_hom_apply, ←A.one.map_smul] at h,
  end,
  commutes' := λ r a,
  begin dsimp,
    have h₁ := linear_map.congr_fun A.one_mul (r ⊗ₜ a),
    have h₂ := linear_map.congr_fun A.mul_one (a ⊗ₜ r),
    exact h₁.trans h₂.symm,
  end,
  smul_def' := λ r a, (linear_map.congr_fun A.one_mul (r ⊗ₜ a)).symm,
  ..A.one }

@[simp] lemma algebra_map (A : Mon_ (Module.{u} R)) (r : R) : algebra_map R A.X r = A.one r := rfl

/--
Converting a monoid object in `Module R` to a bundled algebra.
-/
@[simps]
def functor : Mon_ (Module.{u} R) ⥤ Algebra R :=
{ obj := λ A, Algebra.of R A.X,
  map := λ A B f,
  { to_fun := f.hom,
    map_one' := linear_map.congr_fun f.one_hom (1 : R),
    map_mul' := λ x y, linear_map.congr_fun f.mul_hom (x ⊗ₜ y),
    commutes' := λ r, linear_map.congr_fun f.one_hom r,
    ..(f.hom.to_add_monoid_hom) }, }.

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
@[simps]
def inverse_obj (A : Algebra.{u} R) : Mon_ (Module.{u} R) :=
{ X := Module.of R A,
  one := algebra.linear_map R A,
  mul := linear_map.mul' R A,
  one_mul' :=
  begin
    ext x,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply,
      algebra.linear_map_apply, linear_map.compr₂_apply, function.comp_app,
      ring_hom.map_one, Module.monoidal_category.hom_apply, Algebra.coe_comp,
      Module.monoidal_category.left_unitor_hom_apply],
    rw [linear_map.mul'_apply, monoidal_category.left_unitor_hom_apply, ← algebra.smul_def]
  end,
  mul_one' :=
  begin
    ext x,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply, algebra.linear_map_apply,
      linear_map.compr₂_apply, function.comp_app, Module.monoidal_category.hom_apply,
      Algebra.coe_comp],
    rw [linear_map.mul'_apply, Module.monoidal_category.right_unitor_hom_apply,
        ← algebra.commutes, ← algebra.smul_def]
  end,
  mul_assoc' :=
  begin
    ext x y z,
    dsimp only [Algebra.id_apply, tensor_product.mk_apply, linear_map.compr₂_apply,
      function.comp_app, Module.monoidal_category.hom_apply,
      Algebra.coe_comp, monoidal_category.associator_hom_apply],
    simp only [linear_map.mul'_apply, mul_assoc]
  end }

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
@[simps]
def inverse : Algebra.{u} R ⥤ Mon_ (Module.{u} R) :=
{ obj := inverse_obj,
  map := λ A B f,
  { hom := f.to_linear_map,
    one_hom' := linear_map.ext f.commutes,
    mul_hom' := tensor_product.ext $ linear_map.ext₂ $ map_mul f, } }

end Mon_Module_equivalence_Algebra

open Mon_Module_equivalence_Algebra

/--
The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.
-/
def Mon_Module_equivalence_Algebra : Mon_ (Module.{u} R) ≌ Algebra R :=
{ functor := functor,
  inverse := inverse,
  unit_iso := nat_iso.of_components
    (λ A,
    { hom := { hom := { to_fun := id, map_add' := λ x y, rfl, map_smul' := λ r a, rfl, },
               mul_hom' := by { ext, dsimp at *, refl } },
      inv := { hom := { to_fun := id, map_add' := λ x y, rfl, map_smul' := λ r a, rfl, },
               mul_hom' := by { ext, dsimp at *, refl } } })
    (by tidy),
  counit_iso := nat_iso.of_components (λ A,
  { hom :=
    { to_fun := id,
      map_zero' := rfl,
      map_add' := λ x y, rfl,
      map_one' := (algebra_map R A).map_one,
      map_mul' := λ x y, (@linear_map.mul'_apply R _ _ _ _ _ _ x y),
      commutes' := λ r, rfl, },
    inv :=
    { to_fun := id,
      map_zero' := rfl,
      map_add' := λ x y, rfl,
      map_one' := (algebra_map R A).map_one.symm,
      map_mul' := λ x y, (@linear_map.mul'_apply R _ _ _ _ _ _ x y).symm,
      commutes' := λ r, rfl } }) (by { intros, refl }), }.

/--
The equivalence `Mon_ (Module R) ≌ Algebra R`
is naturally compatible with the forgetful functors to `Module R`.
-/
def Mon_Module_equivalence_Algebra_forget :
  Mon_Module_equivalence_Algebra.functor ⋙ forget₂ (Algebra.{u} R) (Module.{u} R) ≅
    Mon_.forget (Module.{u} R):=
nat_iso.of_components (λ A,
{ hom :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ c x, rfl },
  inv :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ c x, rfl }, }) (by tidy)

end Module


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

import .def_amenable
import .quotient
import .subgroup
import .aux_lemmas_sums
import .aux_lemmas_bounded
import topology.continuous_function.bounded
import topology.continuous_function.basic
import group_theory.quotient_group

/-!
# Extensions of Amenable Groups

We prove that extensions of amenable groups are again amenable.

## Main Statements
- `amenable_of_extension` : Group extensions of amenable groups are amenable,
                            i.e. if G is a group, N is a normal subgroup and
                            N and G/N are amenable, then so is G.
- `amenable_of_extension_iff` : A group extension G of a normal subgroup N
                                by the quotient G ⧸ N is amenable if and only
                                if N and G ⧸ N are.
## Implementation Notes

We follow the proof of [C. Löh, *Geometric Group Theory*, Proposition 9.1.6 (3)][loeh17].

## References
* [C. Löh, *Geometric Group Theory*, Proposition 9.1.6 (3)][loeh17]
* <https://en.wikipedia.org/wiki/Amenable_group>
* [A.L.T. Paterson, *Amenability*, Proposition 0.16 (3)][Paterson1988]

## Tags

amenable extension, amenable, extension

-/

open classical
open function

namespace amenable_of_extension

variables
{G:Type*}
[group G]
{N : subgroup G}
(nN : N.normal)

local notation `Q` := G ⧸ N

/--choose a split of the quotient map G → G/N -/
noncomputable def split
  (nN : N.normal)
  : Q → G
:= (λ q, classical.some (quotient_group.mk'_surjective N q))

@[simp]
lemma split_spec
  (nN : N.normal)
  {q : Q}
  : (quotient_group.mk' N) (split nN q) = q
:= begin
  unfold split,
  exact classical.some_spec (quotient_group.mk'_surjective N q),
end

/-! The main idea is the following:
  Choose means mN on N and mQ on Q := G / N,
  then we obtain a mean on G as follows:

  For any f: G → ℝ, we define a function Q → ℝ
  as follows:
  For q : Q, define its value by the
   mean mN of the function (n ↦  split (q)*n)

  Then, take the mQ-mean of that function Q → ℝ
   -/

/--The restriction to the left class on N-/
noncomputable def bound_cont_rest_N
  (mN: mean N)
  (f : bounded_continuous_function G ℝ)
  (q : Q)
  : bounded_continuous_function N ℝ
  := bounded_continuous_function.mk
          (continuous_map.mk (λ n:N, f((split nN q)*n))
                            -- proof that the map is continous
                            continuous_of_discrete_topology)
          -- proof of boundedness
          (begin
              rcases f.bounded with ⟨C, hbound⟩,
              use C,
              assume n m : N,
              simp,
              exact hbound _ _,
          end )

@[simp]
lemma bound_cont_rest_N_apply
  (mN: mean N)
  (f : bounded_continuous_function G ℝ)
  (q : Q)
  (n : N)
  : bound_cont_rest_N nN mN f q n = f((split nN q)*n)
:= by refl

@[simp]
noncomputable def fun_on_quotient
  (mN: mean N)
  (f : bounded_continuous_function G ℝ)
  : Q → ℝ
  := (λ q, mN (bound_cont_rest_N nN mN f q))

noncomputable def bounded_fun_on_quotient
  (mN: mean N)
  (nN : N.normal)
  (f : bounded_continuous_function G ℝ)
  : bounded_continuous_function Q ℝ
:= bounded_continuous_function.mk
        (continuous_map.mk (fun_on_quotient nN mN f) continuous_of_discrete_topology)
        (begin
          -- rw to classical formulation of boundedness
          have fbounded : ∃ (C:ℝ), ∀ (x:G), abs (f x) ≤ C
            := function_bounded_classical.mp f.bounded,
          rw function_bounded_classical,

          rcases fbounded with ⟨C, fbounded⟩,
          use C,
          assume x,
          simp,
          have : ∀ (n:N), |(bound_cont_rest_N nN mN f x) n| ≤ C,
          {
            assume n:N,
            dsimp[bound_cont_rest_N],
            exact fbounded ((split nN x)*n),
          },
          exact mean.mean_bounded_abs N mN this,
        end )

@[simp]
lemma bounded_fun_on_quotient_apply
  (mN: mean N)
  (nN : N.normal)
  (f : bounded_continuous_function G ℝ)
  (q : Q)
  : bounded_fun_on_quotient mN nN f q = mN (bound_cont_rest_N nN mN f q)
:= by refl

lemma bounded_fun_quot_add
  (mN: mean N)
  (nN : N.normal)
  (f g : bounded_continuous_function G ℝ)
  (q:Q)
  :   bound_cont_rest_N nN mN (f + g) q
    = bound_cont_rest_N nN mN f q
    + bound_cont_rest_N nN mN g q
:= begin
  ext (n:N),
  simp,
end

lemma bounded_fun_quot_smul
  (mN: mean N)
  (nN : N.normal)
  (f : bounded_continuous_function G ℝ)
  (r : ℝ)
  (q:Q)
  :   bound_cont_rest_N nN mN (r • f) q
    = r • bound_cont_rest_N nN mN f q
:= begin
  ext (n:N),
  simp,
end

noncomputable def to_bounded_fun_on_quotient
  (mN: mean N)
  : (bounded_continuous_function G ℝ) →ₗ[ℝ] (bounded_continuous_function Q ℝ)
:= linear_map.mk (λ f, bounded_fun_on_quotient mN nN f)
                  (begin
                    assume f g,
                    ext (q:Q),
                    simp,
                    rw bounded_fun_quot_add,
                    exact mN.lin_map.map_add' _ _,
                  end )
                  (begin
                    assume r f,
                    ext (q:Q),
                    simp,
                    rw bounded_fun_quot_smul,
                    exact mN.lin_map.map_smul' _ _,
                  end )
@[simp]
lemma to_bounded_fun_on_quotient_apply
  (mN: mean N)
  (f : bounded_continuous_function G ℝ)
  : to_bounded_fun_on_quotient nN mN f = bounded_fun_on_quotient mN nN f
:= by refl

/--The map that will become the mean on G-/
noncomputable def extension_mean_linmap
  (mN: mean N)
  (nN : N.normal)
  (mQ: mean Q)
  : (bounded_continuous_function G ℝ) →ₗ[ℝ] ℝ
:= linear_map.comp mQ.lin_map (to_bounded_fun_on_quotient nN mN)

lemma extension_mean_norm
  (mN: mean N)
  {nN : N.normal}
  (mQ: mean Q)
  : (extension_mean_linmap mN nN mQ) (bounded_continuous_function.const G (1:ℝ)) = (1:ℝ)
:= begin
  have : (to_bounded_fun_on_quotient nN mN) (bounded_continuous_function.const G (1:ℝ))
        = (bounded_continuous_function.const Q (1:ℝ)),
  {
    ext (q:Q),
    simp,
    have : bound_cont_rest_N nN mN (bounded_continuous_function.const G 1) q
          = bounded_continuous_function.const N 1,
    {
      ext (n:N),
      by simp,
    },
    rw this,
    exact mN.normality,
  },
  calc (extension_mean_linmap mN nN mQ) (bounded_continuous_function.const G (1:ℝ))
      = mQ ((to_bounded_fun_on_quotient nN mN) (bounded_continuous_function.const G (1:ℝ)))
      : by tauto
  ... = mQ (bounded_continuous_function.const Q (1:ℝ))
      : by congr'; exact this
  ... = (1:ℝ)
      : by exact mQ.normality,
end

lemma extension_mean_pos
  (mN: mean N)
  {nN : N.normal}
  (mQ: mean Q)
  : ∀ (f : bounded_continuous_function G ℝ),
                          (∀ (x:G), f x ≥ 0) → (extension_mean_linmap mN nN mQ) f ≥ 0
:= begin
  assume f fpos,

  have : ∀(q:Q), to_bounded_fun_on_quotient nN mN f q ≥ 0,
  {
    assume q:Q,
    simp,
    --we want to apply positivity of N here
    apply mN.positivity,
    assume n:N,
    simp,
    exact fpos _,
  },

  calc (extension_mean_linmap mN nN mQ) f
      = mQ ((to_bounded_fun_on_quotient nN mN) f)
      : by tauto
  ... ≥ 0
      : by exact mQ.positivity this,
end

/--the mean on G-/
noncomputable def extension_mean
  (mN: mean N)
  {nN : N.normal}
  (mQ: mean Q)
  : mean G
:= mean.mk (extension_mean_linmap mN nN mQ)
           (extension_mean_norm _ _ )
           (extension_mean_pos _ _)

/-! Some Lemmas for establishing left-invariance of extension_mean -/
lemma rw_ginv_splitq
  (g:G)
  (q:Q)
  : ∃ n':N, g⁻¹ * (split nN q) = (split nN ((quotient_group.mk' N g⁻¹)*q)) * n'⁻¹
:= begin
  let n : G := (split nN q)⁻¹ * g  * split nN ((quotient_group.mk' N g⁻¹)*q),
  have : quotient_group.mk' N n = 1,
  {
   calc  quotient_group.mk' N n
       = quotient_group.mk' N ((split nN q)⁻¹ * g  * split nN ((quotient_group.mk' N g⁻¹)*q))
          : by simp [n]
    ... = (quotient_group.mk' N ((split nN q)⁻¹ * g)) *
          (quotient_group.mk' N (split nN ((quotient_group.mk' N g⁻¹)*q)))
          : map_mul (quotient_group.mk' N) ((split nN q)⁻¹ * g) (split nN ((quotient_group.mk' N) g⁻¹ * q))
    ... = (quotient_group.mk' N ((split nN q)⁻¹))*
          (quotient_group.mk' N  g) *
          (quotient_group.mk' N (split nN ((quotient_group.mk' N g⁻¹)*q)))
          : by congr' 1;simp
    ... = (quotient_group.mk' N ((split nN q)⁻¹))*
          (quotient_group.mk' N  g) *
          ((quotient_group.mk' N g⁻¹)*q)
          : by simp
    ... = (quotient_group.mk' N (split nN q))⁻¹*
          (quotient_group.mk' N  g) *
          ((quotient_group.mk' N g⁻¹)*q)
          : by congr' 2; simp
    ... = q⁻¹* (quotient_group.mk' N  g) *
          ((quotient_group.mk' N g⁻¹)*q)
          : by congr' 2; simp
    ... = q⁻¹* (quotient_group.mk' N  g) *
          ((quotient_group.mk' N g)⁻¹*q)
          : by congr' 2; simp
    ... = 1
          : by group,
  },
  have ninN: n ∈ N,
  {
    rw ← quotient_group.eq_one_iff n,
    exact this,
  },
  use ⟨n, ninN⟩,
  dsimp[n],
  by group,
end

lemma bound_cont_rest_N_transl
  (mN: mean N)
  (f : bounded_continuous_function G ℝ)
  (q : Q)
  (g : G) -- element to translate by
  : ∃ (n' : N),
    bound_cont_rest_N  nN mN (left_translate g f) q
  = left_translate n' (bound_cont_rest_N nN mN f ((quotient_group.mk g⁻¹)*q))
:= begin
  have : ∃ n':N, g⁻¹ * (split nN q) = (split nN ((quotient_group.mk' N g⁻¹)*q)) * n'⁻¹
        := rw_ginv_splitq _ _ _,
  rcases this with ⟨n', hn'⟩,
  use n',
  ext (n:N),
  rw left_translate_eval,
  simp,
  congr' 1,
  change g⁻¹ * (split nN q * ↑n) = split nN (quotient_group.mk' N g⁻¹ * q) * ((↑n')⁻¹ * ↑n),
  calc  g⁻¹ * (split nN q * ↑n)
      = (g⁻¹ * split nN q) * ↑n
        : by group
  ... = ((split nN ((quotient_group.mk' N g⁻¹)*q)) * n'⁻¹)*n
        : by rw hn'
  ... = split nN (quotient_group.mk' N g⁻¹ * q) * ((↑n')⁻¹ * ↑n)
        : by rw mul_assoc,
end

lemma bounded_fun_on_quotient_transl
  (mN: left_invariant_mean N)
  (f : bounded_continuous_function G ℝ)
  (q : Q)
  (g : G) -- element to translate by
  : bounded_fun_on_quotient mN.to_mean nN (left_translate g f) q
  = bounded_fun_on_quotient mN.to_mean nN f ((quotient_group.mk g⁻¹)*q)
:= begin
  simp,
  rcases bound_cont_rest_N_transl nN mN f q g with ⟨n, nprop⟩,
  calc  mN.to_mean (bound_cont_rest_N nN mN.to_mean (left_translate g f) q)
      = mN.to_mean (left_translate n (bound_cont_rest_N nN mN f ((quotient_group.mk g⁻¹)*q)))
        : by {congr' 1,}
  ... = mN.to_mean (bound_cont_rest_N nN mN f ((quotient_group.mk g⁻¹)*q))
        : by exact mN.left_invariance n _,
end

/-- a left-translate version-/
lemma bounded_fun_on_quotient_transl'
  (mN: left_invariant_mean N)
  (f : bounded_continuous_function G ℝ)
  (g : G) -- element to translate by
  : bounded_fun_on_quotient mN.to_mean nN (left_translate g f)
  = left_translate (quotient_group.mk g⁻¹)⁻¹
      (bounded_fun_on_quotient mN.to_mean nN f)
:= begin
  ext (q:Q),
  by simp [bounded_fun_on_quotient_transl nN mN f q g],
end

lemma extension_mean_leftinv
  (mN: left_invariant_mean N)
  {nN : N.normal}
  (mQ: left_invariant_mean Q)
  : ∀(g:G), ∀(f: bounded_continuous_function G ℝ),
      (extension_mean mN.to_mean mQ) (left_translate g f)
    = (extension_mean mN.to_mean mQ) f
:= begin
  assume g:G,
  assume f: bounded_continuous_function G ℝ,
  calc  (extension_mean mN.to_mean mQ) (left_translate g f)
      = mQ (bounded_fun_on_quotient mN.to_mean nN (left_translate g f))
        : by tauto
  ... = mQ (left_translate (quotient_group.mk g⁻¹)⁻¹
      (bounded_fun_on_quotient mN.to_mean nN f))
        : by rw bounded_fun_on_quotient_transl'
  ... = mQ (bounded_fun_on_quotient mN.to_mean nN f)
        : by exact mQ.left_invariance (quotient_group.mk g⁻¹)⁻¹ _
  ... = (extension_mean mN.to_mean mQ) f
        : by tauto,
end

/--A left-invariant mean on G-/
noncomputable def extension_invmean
  (mN: left_invariant_mean N)
  {nN : N.normal}
  (mQ: left_invariant_mean Q)
  : left_invariant_mean G
:= left_invariant_mean.mk (extension_mean mN.to_mean mQ) (extension_mean_leftinv mN mQ)

end amenable_of_extension

/--Theorem: Extensions of amenable groups are amenable -/
theorem amenable_of_extension
  {G:Type*}
  [group G]
  {N : subgroup G}
  (N_am : amenable N)
  (nN : N.normal)
  (Q_am : amenable (G ⧸ N))
  : amenable G
:= amenable_of_invmean (amenable_of_extension.extension_invmean (invmean_of_amenable N_am)
                                         (invmean_of_amenable Q_am))

/--An extension is amenable iff a normal subgroup and its quotient are amenable-/
theorem amenable_of_extension_iff
  {G:Type*}
  [group G]
  {N : subgroup G}
  (nN : N.normal)
  : amenable G ↔ amenable N ∧ amenable (G⧸N)
:= begin
  have mp : amenable G →  amenable N ∧ amenable (G⧸N),
  {
    assume G_am : amenable G,
    exact ⟨amenable_of_subgroup N G_am,
            amenable_of_quotient nN G_am⟩,
  },
  have mpr : amenable N ∧ amenable (G⧸N) → amenable G
      := (λ h, amenable_of_extension h.1 nN h.2),
  exact ⟨mp, mpr⟩,
end


import prefixes
import topology.metric_space.pi_nat

noncomputable theory
open_locale classical topology filter
open topological_space

variables {α : Type*} [topological_space α] [discrete_topology α]

lemma prefix_open_of_open (A : set (ℕ → α)) : is_open A → is_prefix_open A :=
begin
  intros hA,
  use {s : list α | ∀ f, is_prefix s f → f ∈ A},
  intros f,
  split,
  { intros hf,
    have key := (is_topological_basis.is_open_iff (pi_nat.is_topological_basis_cylinders _)).mp hA,
    rcases key f hf with ⟨B, B_cylinder, hB₁, hB₂⟩,
    rcases B_cylinder with ⟨g, n, hn⟩,
    use stream_prefix g n,
    rw hn at *,
    clear key hn,
    split,
    { clear hf hB₁ f,
      intros f hf,
      apply hB₂,
      intros i hi,
      unfold is_prefix at hf,
      rw stream_prefix_length at hf,
      have key : (f i : option α) = (g i : option α) :=
      by calc ↑(f i) = (stream_prefix f n).nth i : (stream_prefix_nth' f n i hi).symm
      ... = (stream_prefix g n).nth i : by rw hf
      ... = ↑(g i) : stream_prefix_nth' g n i hi,
      injections_and_clear,
      assumption, },
    { unfold is_prefix,
      rw stream_prefix_length,
      ext1 i,
      by_cases hi : i < n,
      { calc (stream_prefix f n).nth i = f i : stream_prefix_nth' f n i hi
        ... = g i : congr_arg coe (hB₁ i hi)
        ... = (stream_prefix g n).nth i : (stream_prefix_nth' g n i hi).symm, },
      { calc (stream_prefix f n).nth i = none : list.nth_len_le (by linarith [stream_prefix_length f n])
        ... = (stream_prefix g n).nth i : (list.nth_len_le (by linarith [stream_prefix_length g n])).symm, }, }, },
  { rintros ⟨s, hs₁, hs₂⟩,
    exact hs₁ f hs₂, },
end


lemma zero_mul (m : mynat) : 0 * m = 0 :=
begin
induction m with k Pk,
apply mul_zero,
rw mul_succ,
rw add_zero,
exact Pk,
end


/-
Copyright (c) 2022 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Heather Macbeth
-/

import geometry.manifold.vector_bundle.basic

/-! # Tangent bundles

This file defines the tangent bundle as a smooth vector bundle.

Let `M` be a smooth manifold with corners with model `I` on `(E, H)`. We define the tangent bundle
of `M` using the `vector_bundle_core` construction indexed by the charts of `M` with fibers `E`.
Given two charts `i, j : local_homeomorph M H`, the coordinate change between `i` and `j` at a point
`x : M` is the derivative of the composite
```
  I.symm   i.symm    j     I
E -----> H -----> M --> H --> E
```
within the set `range I ⊆ E` at `I (i x) : E`.
This defines a smooth vector bundle `tangent_bundle` with fibers `tangent_space`.

## Main definitions

* `tangent_space I M x` is the fiber of the tangent bundle at `x : M`, which is defined to be `E`.

* `tangent_bundle I M` is the total space of `tangent_space I M`, proven to be a smooth vector
  bundle.
-/

open bundle set smooth_manifold_with_corners local_homeomorph
open_locale manifold topology bundle

noncomputable theory

variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
{E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] {I : model_with_corners 𝕜 E H}
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
{F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F]
variables (I)

/-- Auxiliary lemma for tangent spaces: the derivative of a coordinate change between two charts is
  smooth on its source. -/
lemma cont_diff_on_fderiv_coord_change (i j : atlas H M) :
  cont_diff_on 𝕜 ∞ (fderiv_within 𝕜 (j.1.extend I ∘ (i.1.extend I).symm) (range I))
    ((i.1.extend I).symm ≫ j.1.extend I).source :=
begin
  have h : ((i.1.extend I).symm ≫ j.1.extend I).source ⊆ range I,
  { rw [i.1.extend_coord_change_source], apply image_subset_range },
  intros x hx,
  refine (cont_diff_within_at.fderiv_within_right _ I.unique_diff le_top $ h hx).mono h,
  refine (local_homeomorph.cont_diff_on_extend_coord_change I (subset_maximal_atlas I j.2)
    (subset_maximal_atlas I i.2) x hx).mono_of_mem _,
  exact i.1.extend_coord_change_source_mem_nhds_within j.1 I hx
end

variables (M)
open smooth_manifold_with_corners

/--
Let `M` be a smooth manifold with corners with model `I` on `(E, H)`.
Then `vector_bundle_core I M` is the vector bundle core for the tangent bundle over `M`.
It is indexed by the atlas of `M`, with fiber `E` and its change of coordinates from the chart `i`
to the chart `j` at point `x : M` is the derivative of the composite
```
  I.symm   i.symm    j     I
E -----> H -----> M --> H --> E
```
within the set `range I ⊆ E` at `I (i x) : E`. -/
@[simps] def tangent_bundle_core : vector_bundle_core 𝕜 M E (atlas H M) :=
{ base_set := λ i, i.1.source,
  is_open_base_set := λ i, i.1.open_source,
  index_at := achart H,
  mem_base_set_at := mem_chart_source H,
  coord_change := λ i j x, fderiv_within 𝕜 (j.1.extend I ∘ (i.1.extend I).symm) (range I)
    (i.1.extend I x),
  coord_change_self := λ i x hx v, begin
    rw [filter.eventually_eq.fderiv_within_eq, fderiv_within_id', continuous_linear_map.id_apply],
    { exact I.unique_diff_at_image },
    { exact I.unique_diff_at_image },
    { filter_upwards [i.1.extend_target_mem_nhds_within I hx] with y hy,
      exact (i.1.extend I).right_inv hy },
    { simp_rw [function.comp_apply, i.1.extend_left_inv I hx] }
  end,
  continuous_on_coord_change := λ i j, begin
      refine (cont_diff_on_fderiv_coord_change I i j).continuous_on.comp
        ((i.1.continuous_on_extend I).mono _) _,
      { rw [i.1.extend_source], exact inter_subset_left _ _ },
      simp_rw [← i.1.extend_image_source_inter, maps_to_image]
    end,
  coord_change_comp := begin
    rintro i j k x ⟨⟨hxi, hxj⟩, hxk⟩ v,
    rw [fderiv_within_fderiv_within, filter.eventually_eq.fderiv_within_eq],
    { exact I.unique_diff_at_image },
    { have := i.1.extend_preimage_mem_nhds I hxi (j.1.extend_source_mem_nhds I hxj),
      filter_upwards [nhds_within_le_nhds this] with y hy,
      simp_rw [function.comp_apply, (j.1.extend I).left_inv hy] },
    { simp_rw [function.comp_apply, i.1.extend_left_inv I hxi, j.1.extend_left_inv I hxj] },
    { exact (cont_diff_within_at_extend_coord_change' I (subset_maximal_atlas I k.2)
        (subset_maximal_atlas I j.2) hxk hxj).differentiable_within_at le_top },
    { exact (cont_diff_within_at_extend_coord_change' I (subset_maximal_atlas I j.2)
        (subset_maximal_atlas I i.2) hxj hxi).differentiable_within_at le_top },
    { intros x hx, exact mem_range_self _ },
    { exact I.unique_diff_at_image },
    { rw [function.comp_apply, i.1.extend_left_inv I hxi] }
  end }

variables {M}

lemma tangent_bundle_core_coord_change_achart (x x' z : M) :
  (tangent_bundle_core I M).coord_change (achart H x) (achart H x') z =
  fderiv_within 𝕜 (ext_chart_at I x' ∘ (ext_chart_at I x).symm) (range I) (ext_chart_at I x z) :=
rfl

include I

/-- The tangent space at a point of the manifold `M`. It is just `E`. We could use instead
`(tangent_bundle_core I M).to_topological_vector_bundle_core.fiber x`, but we use `E` to help the
kernel.
-/
@[nolint unused_arguments, derive [topological_space, add_comm_group, topological_add_group]]
def tangent_space (x : M) : Type* := E

omit I
variable (M)

/-- The tangent bundle to a smooth manifold, as a Sigma type. Defined in terms of
`bundle.total_space` to be able to put a suitable topology on it. -/
@[nolint has_nonempty_instance, reducible] -- is empty if the base manifold is empty
def tangent_bundle := bundle.total_space (tangent_space I : M → Type*)

local notation `TM` := tangent_bundle I M

section tangent_bundle_instances

/- In general, the definition of tangent_space is not reducible, so that type class inference
does not pick wrong instances. In this section, we record the right instances for
them, noting in particular that the tangent bundle is a smooth manifold. -/

section
local attribute [reducible] tangent_space

variables {M} (x : M)

instance : module 𝕜 (tangent_space I x) := by apply_instance
instance : inhabited (tangent_space I x) := ⟨0⟩

end

instance : topological_space TM :=
(tangent_bundle_core I M).to_topological_space

instance : fiber_bundle E (tangent_space I : M → Type*) :=
(tangent_bundle_core I M).fiber_bundle

instance : vector_bundle 𝕜 E (tangent_space I : M → Type*) :=
(tangent_bundle_core I M).vector_bundle

namespace tangent_bundle

protected lemma chart_at (p : TM) :
  chart_at (model_prod H E) p =
    ((tangent_bundle_core I M).to_fiber_bundle_core.local_triv (achart H p.1))
      .to_local_homeomorph ≫ₕ (chart_at H p.1).prod (local_homeomorph.refl E) :=
rfl

lemma chart_at_to_local_equiv (p : TM) :
  (chart_at (model_prod H E) p).to_local_equiv =
    (tangent_bundle_core I M).to_fiber_bundle_core.local_triv_as_local_equiv (achart H p.1) ≫
    (chart_at H p.1).to_local_equiv.prod (local_equiv.refl E) :=
rfl

lemma trivialization_at_eq_local_triv (x : M) :
  trivialization_at E (tangent_space I) x =
  (tangent_bundle_core I M).to_fiber_bundle_core.local_triv (achart H x) :=
rfl

@[simp, mfld_simps]
lemma trivialization_at_source (x : M) :
  (trivialization_at E (tangent_space I) x).source = π _ ⁻¹' (chart_at H x).source :=
rfl

@[simp, mfld_simps]
lemma trivialization_at_target (x : M) :
  (trivialization_at E (tangent_space I) x).target = (chart_at H x).source ×ˢ univ :=
rfl

@[simp, mfld_simps]
lemma trivialization_at_base_set (x : M) :
  (trivialization_at E (tangent_space I) x).base_set = (chart_at H x).source :=
rfl

lemma trivialization_at_apply (x : M) (z : TM) :
  trivialization_at E (tangent_space I) x z =
  (z.1, fderiv_within 𝕜 ((chart_at H x).extend I ∘ ((chart_at H z.1).extend I).symm) (range I)
    ((chart_at H z.1).extend I z.1) z.2) :=
rfl

@[simp, mfld_simps]
lemma trivialization_at_fst (x : M) (z : TM) :
  (trivialization_at E (tangent_space I) x z).1 = z.1 :=
rfl

@[simp, mfld_simps] lemma mem_chart_source_iff (p q : TM) :
  p ∈ (chart_at (model_prod H E) q).source ↔ p.1 ∈ (chart_at H q.1).source :=
by simp only [fiber_bundle.charted_space_chart_at] with mfld_simps

@[simp, mfld_simps] lemma mem_chart_target_iff (p : H × E) (q : TM) :
  p ∈ (chart_at (model_prod H E) q).target ↔ p.1 ∈ (chart_at H q.1).target :=
by simp only [fiber_bundle.charted_space_chart_at, and_iff_left_iff_imp] with mfld_simps
  {contextual := tt}

@[simp, mfld_simps] lemma coe_chart_at_fst (p q : TM) :
  ((chart_at (model_prod H E) q) p).1 = chart_at H q.1 p.1 := rfl

@[simp, mfld_simps] lemma coe_chart_at_symm_fst (p : H × E) (q : TM) :
  ((chart_at (model_prod H E) q).symm p).1 = ((chart_at H q.1).symm : H → M) p.1 := rfl

end tangent_bundle

instance tangent_bundle_core.is_smooth : (tangent_bundle_core I M).is_smooth I :=
begin
  refine ⟨λ i j, _⟩,
  rw [smooth_on, cont_mdiff_on_iff_source_of_mem_maximal_atlas
    (subset_maximal_atlas I i.2), cont_mdiff_on_iff_cont_diff_on],
  refine ((cont_diff_on_fderiv_coord_change I i j).congr $ λ x hx, _).mono _,
  { rw [local_equiv.trans_source'] at hx,
    simp_rw [function.comp_apply, tangent_bundle_core_coord_change,
      (i.1.extend I).right_inv hx.1] },
  { exact (i.1.extend_image_source_inter j.1 I).subset },
  { apply inter_subset_left }
end

instance tangent_bundle.smooth_vector_bundle :
  smooth_vector_bundle E (tangent_space I : M → Type*) I :=
(tangent_bundle_core I M).smooth_vector_bundle _

end tangent_bundle_instances

/-! ## The tangent bundle to the model space -/

/-- In the tangent bundle to the model space, the charts are just the canonical identification
between a product type and a sigma type, a.k.a. `equiv.sigma_equiv_prod`. -/
@[simp, mfld_simps] lemma tangent_bundle_model_space_chart_at (p : tangent_bundle I H) :
  (chart_at (model_prod H E) p).to_local_equiv = (equiv.sigma_equiv_prod H E).to_local_equiv :=
begin
  ext x : 1,
  { ext, { refl },
    exact (tangent_bundle_core I H).coord_change_self (achart _ x.1) x.1
      (mem_achart_source H x.1) x.2 },
  { intros x, ext, { refl }, apply heq_of_eq,
    exact (tangent_bundle_core I H).coord_change_self (achart _ x.1) x.1
      (mem_achart_source H x.1) x.2 },
  simp_rw [tangent_bundle.chart_at, fiber_bundle_core.local_triv,
    fiber_bundle_core.local_triv_as_local_equiv, vector_bundle_core.to_fiber_bundle_core_base_set,
    tangent_bundle_core_base_set],
  simp only with mfld_simps,
end

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at (p : tangent_bundle I H) :
  ⇑(chart_at (model_prod H E) p) = equiv.sigma_equiv_prod H E :=
by { unfold_coes, simp_rw [tangent_bundle_model_space_chart_at], refl }

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at_symm (p : tangent_bundle I H) :
  ((chart_at (model_prod H E) p).symm : model_prod H E → tangent_bundle I H) =
  (equiv.sigma_equiv_prod H E).symm :=
by { unfold_coes,
  simp_rw [local_homeomorph.symm_to_local_equiv, tangent_bundle_model_space_chart_at], refl }

variable (H)
/-- The canonical identification between the tangent bundle to the model space and the product,
as a homeomorphism -/
def tangent_bundle_model_space_homeomorph : tangent_bundle I H ≃ₜ model_prod H E :=
{ continuous_to_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p),
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only [tangent_space.fiber_bundle] with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  continuous_inv_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p).symm,
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  .. equiv.sigma_equiv_prod H E }

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe :
  (tangent_bundle_model_space_homeomorph H I : tangent_bundle I H → model_prod H E)
  = equiv.sigma_equiv_prod H E :=
rfl

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe_symm :
  ((tangent_bundle_model_space_homeomorph H I).symm : model_prod H E → tangent_bundle I H)
  = (equiv.sigma_equiv_prod H E).symm :=
rfl


/-
Copyright © 2019, Oracle and/or its affiliates. All rights reserved.
-/

import .setup_definition .setup_properties

open set
open measure_theory
open probability_measure
open lattice

local attribute [instance] classical.prop_decidable

namespace stump

variables (μ: probability_measure ℍ) (target: ℍ)

lemma is_meas_to_target:
    is_measurable {a: nnreal | a ≤ target} :=
begin
    apply is_measurable_of_is_closed,
    have TEST: Icc 0 target = {a: nnreal | a ≤ target}, {
        unfold Icc,
        rw ext_iff,
        intro,
        simp at *,
    },
    rw ← TEST,
    apply is_closed_Icc,
end

@[simp]
lemma label_measurable: measurable (label target) :=
begin
    dunfold label,
    apply measurable.prod,
    apply measurable_id,
    unfold rle,
    unfold to_bool,
    apply measurable.if,
    apply is_meas_to_target,
    apply measurable_const,
    apply measurable_const,
end

lemma measurable_interval_function:
    ∀ f: nnreal → nnreal,
    (∀ x: nnreal, is_measurable (f ⁻¹' Iio x)) →
    measurable f :=
begin
    intros,
    have FOO:= borel_eq_generate_Iio nnreal,
    unfold measurable,
    unfold stump.meas_ℍ,
    rw FOO,
    apply measurable_generate_from,
    intros,
    unfold range at H,
    rw mem_set_of_eq at H,
    cases H,
    unfold is_measurable,
    unfold is_measurable at a,
    unfold stump.meas_ℍ at a,
    rw FOO at a,
    rw ← H_h,
    apply a,
end

lemma measurable_lt :let f := λ x: nnreal, μ (Icc 0 x) in
∀ y : nnreal,
(∃ θ : nnreal, {x : nnreal | f x < y} = Ico 0 θ)
∨
{x : nnreal | f x < y} = ∅
∨
(∃ θ : nnreal, {x : nnreal | f x < y} = Icc 0 θ)
∨
{x : nnreal | f x < y} = Ici 0
:=
begin
    intros f y,
    let S := {x : ℍ | f x < y},
    have hm : monotone f, from assume a b hab, prob_mono _ (Icc_subset_Icc (by refl) hab),
    have hm' : ∀ {x y}, f x < f y → x < y,
    {
        by_contradiction, push_neg at a,
        choose x₀ y₀ hxy using a,
        rcases hxy with ⟨hxy₁,hxy₂⟩,
        have : f y₀ ≤ f x₀, from hm hxy₂,
        rw ←not_lt at this, exact this hxy₁,
    },
    by_cases (∃ u, f(u) ≥ y),
    swap, push_neg at h,
    have hS : S = Ici 0,
    {
        ext z, dsimp [S, Ici],
        fsplit, assume h₁, by_contra, simp at *, assumption,
        assume h₁, apply h,
    },
    right, right, right, assumption,
    let T := {x : ℍ | f x ≥ y},
    have Tne : T ≠ ∅,
    {
        assume not, choose u hyp using h,
        have : u ∈ T, by assumption, finish,
    },
    have Tbdbl : bdd_below T, from ⟨ 0 , assume y hy, zero_le _ ⟩,
    let θ := Inf T,
    have Sleθ : ∀ x ∈ S, x ≤ θ,
    {
        assume s hs, refine le_cInf Tne _,
        assume b hb, dsimp [T,S] at hb hs,
        suffices : f s < f b, exact le_of_lt (hm' this),
        exact lt_of_lt_of_le hs hb,
    },
    by_cases case : (f θ < y),
    have hS : S = Icc 0 θ, from set.ext (assume x, iff.intro (assume h₁, ⟨ by simp , Sleθ _ h₁⟩) (assume h₂, lt_of_le_of_lt (hm h₂.2) case)),
    right, right, left, existsi θ, exact hS,
    have hS : S = Ico 0 θ,
    {
        ext x, fsplit,
        assume h₁,
        suffices : x ≠ θ, dsimp [Ico], refine ⟨ by simp , lt_of_le_of_ne (Sleθ _ h₁) this ⟩,
        assume not,
        have : θ ∉ S, from case, rw not at h₁, exact this h₁,
        assume h₁, dsimp [S,Ico] at h₁ ⊢,
        have : x ∉ T, assume not, have : θ ≤ x, from cInf_le Tbdbl not,
        replace h₁ := h₁.2, rw ←not_le at h₁, exact h₁ this,
        simp at this, assumption,
    },
    left, existsi θ, exact hS,
end

lemma measurable_Icc_0_x:
    measurable (λ x: nnreal, μ (Icc 0 x)) :=
begin
    apply measurable_interval_function,
    intros,
    unfold set.preimage,
    unfold Iio,
    conv {
        congr, congr, funext, rw mem_set_of_eq, skip,
    },
    have FOO := measurable_lt μ x,
    cases FOO,
    cases FOO,
    rw FOO_h,
    exact is_measurable_Ico,
    cases FOO,
    rw FOO,
    exact is_measurable.empty,
    cases FOO,
    cases FOO,
    rw FOO_h,
    apply is_measurable_of_is_closed,
    apply is_closed_Icc,
    rw FOO,
    have COMPL: (Ici (0: nnreal) = - Iio 0),
    {
        unfold Ici, unfold Iio,
        rw ext_iff, intro,
        rw mem_set_of_eq,
        rw compl_set_of,
        rw mem_set_of_eq,
        split; intro,
        simp,
        simp at a,
        tidy,
    },
    rw COMPL,
    apply is_measurable.compl,
    exact is_measurable_Iio,
end

noncomputable
def error1: nnreal → nnreal := λ h, μ (Icc 0 target) - μ (Icc 0 h)

noncomputable
def error2: nnreal → nnreal := λ h, μ (Icc 0 h) - μ (Icc 0 target)

noncomputable
def error_decomposed: nnreal → nnreal := λ h, ite (rle h target) (error1 μ target h) (error2 μ target h)

lemma decompose_error:
    error μ target = error_decomposed μ target :=
begin
    funext,
    unfold error_decomposed,
    by_cases (rle h target = tt),
    {
        dedup,
        rw h_1, simp,
        unfold error1,
        rw error_interval_1,
        rw ← Icc_diff_Ioc 0 h target,
        have INCL: Icc 0 h ⊆ Icc 0 target, swap,
        {
            have FOO:= @measure_diff nnreal _ μ _ _ INCL _ _ _,
            unfold_coes,
            unfold_coes at FOO,
            rw FOO,
            rw ← ennreal.coe_eq_coe,
            rw to_nnreal_sub,
            exact to_measure_lt_top μ (Icc 0 target),
            exact to_measure_lt_top μ (Icc 0 h),
            apply is_measurable_of_is_closed,
            apply is_closed_Icc,
            apply is_measurable_of_is_closed,
            apply is_closed_Icc,
            exact probability_measure.to_measure_lt_top μ (Icc 0 h),
        },
        {
            have H: h ≤ target,
            {
                unfold rle at h_1,
                tidy,
            },
            unfold Icc,
            rw subset_def, intros,
            rw mem_set_of_eq,
            rw mem_set_of_eq at a,
            cases a,
            split,
            assumption,
            transitivity h; assumption,
        },
        {
            tidy,
        },
        repeat {
            unfold rle at h_1,
            tidy,
        },
    },
    {
        dedup,
        simp at h_1, rw h_1, simp,
        unfold error2,
        rw error_interval_2,
        rw ← Icc_diff_Ioc 0 target h,
        have INCL: Icc 0 target ⊆ Icc 0 h, swap,
        {
            have FOO:= @measure_diff nnreal _ μ _ _ INCL _ _ _,
            unfold_coes,
            unfold_coes at FOO,
            rw FOO,
            rw ← ennreal.coe_eq_coe,
            rw to_nnreal_sub,
            exact to_measure_lt_top μ (Icc 0 h),
            exact to_measure_lt_top μ (Icc 0 target),
            apply is_measurable_of_is_closed,
            apply is_closed_Icc,
            apply is_measurable_of_is_closed,
            apply is_closed_Icc,
            exact probability_measure.to_measure_lt_top μ (Icc 0 target)
        },
        {
            have H: target < h,
            {
                unfold rle at h_1,
                tidy,
            },
            unfold Icc,
            rw subset_def, intros,
            rw mem_set_of_eq,
            rw mem_set_of_eq at a,
            cases a,
            split,
            assumption,
            transitivity target; try {assumption},
            exact le_of_lt H,
        },
        {
            tidy,
        },
        {
            unfold rle at h_1, simp at h_1,
            exact le_of_lt h_1,
        },
        {
            unfold rle at h_1, simp at h_1,
            exact (gt_from_lt h target).mp h_1,
        },
    },
end

lemma error_measurable:
    measurable (error μ target) :=
begin
    rw decompose_error,
    unfold error_decomposed,
    apply measurable.if,
    {
        unfold rle, simp, apply is_meas_to_target,
    },
    {
        unfold error1,
        apply nnreal.measurable_sub,
        {
            apply measurable_const,
        },
        {
            apply measurable_Icc_0_x,
        },
    },
    {
        unfold error2,
        apply nnreal.measurable_sub,
        {
            apply measurable_Icc_0_x,
        },
        {
            apply measurable_const,
        },
    },
end

@[simp]
lemma is_meas_gamma_1:
    ∀ ε,
    is_measurable {h: ℍ | error μ target h > ε} :=
begin
    intro,
    have COMPL: {h: ℍ | error μ target h > ε} = -{h: ℍ | error μ target h ≤ ε},
    {
        rw compl_set_of,
        simp,
    },
    rw COMPL,
    apply is_measurable.compl,
    have MLE := @measurable_le _ _ _ _ _ _ _ (λ h, error μ target h) (λ h, ε),
    apply MLE,
    apply error_measurable,
    apply measurable_const,
end

@[simp]
lemma is_meas_gamma_2:
    ∀ ε,
    is_measurable {h: ℍ | error μ target h ≤ ε} :=
begin
    intros,
    have COMPL: {h: ℍ | error μ target h ≤ ε} = -{h: ℍ | error μ target h > ε},
    {
        rw compl_set_of,
        simp,
    },
    rw COMPL,
    apply is_measurable.compl,
    apply is_meas_gamma_1,
end

@[simp]
lemma is_meas_one: ∀ θ,
    θ > 0 →
    is_measurable {x: ℍ |  ∀ p = label target x, (if p.snd then p.fst else 0) < θ} :=
begin
    introv T0,
    convert_to (is_measurable {x: ℍ | (if (label target x).snd then (label target x).fst else 0) < θ}),
    {
        rw ext_iff, intro,
        repeat {rw mem_set_of_eq},
        split; intros,
        apply a, trivial,
        rw H, assumption,
    },
    unfold label, simp, unfold rle,
    rw ite_equals_union_interval θ T0 target,
    apply is_measurable.union,
    {
        exact is_measurable_Ico,
    },
    {
        rw Ioi_complement target,
        apply is_measurable.compl,
        apply is_measurable.union,
        exact is_measurable_Iio,
        rw ← (Ico_diff_Ioo_eq_singleton (by exact lt_add_one target)),
        apply is_measurable.diff,
        exact is_measurable_Ico,
        exact is_measurable_Ioo,
    },
end

@[simp]
lemma is_meas_forall: ∀ θ,
    θ > 0 →
    ∀ n, is_measurable {S: vec ℍ n |  ∀ (i: dfin (nat.succ n)), ∀ p = label target (kth_projn S i), (if p.snd then p.fst else 0) < θ} :=
begin
    intros,
    convert_to (is_measurable {S: vec ℍ n |  ∀ (i: dfin (nat.succ n)), (if (label target (kth_projn S i)).snd then (label target (kth_projn S i)).fst else 0) < θ}),
    {
        rw ext_iff, intro,
        repeat {rw mem_set_of_eq},
        split; intros,
        apply (a_1 i), trivial,
        rw H, apply (a_1 i),
    },
    have FOO:= is_measurable_simple_vec (λ x, (if (label target x).snd then (label target x).fst else 0) < θ),
    apply FOO,
    convert_to (is_measurable {x: ℍ |  ∀ p = label target x, (if p.snd then p.fst else 0) < θ}),
    {
        rw ext_iff, intro,
        repeat {rw mem_set_of_eq},
        split; intros,
        rw H, assumption,
        apply a_1, trivial,
    },
    apply is_meas_one; assumption,
end

end stump


import SciLean.Mathlib.Data.Enumtype
import Mathlib.Algebra.Group.Defs

namespace SciLean

class PowType (X : Type) where
  powType : Nat → Type
  intro {n} : (Fin n → X) → powType n
  get {n} : powType n → Fin n → X
  set {n} : powType n → Fin n → X → powType n
  ext {n} : ∀ x y : powType n, (∀ i, get x i = get y i) → x = y

-- instance (priority := low) {X} (n : Nat) : PowType X n :=
-- {
--   powType := {a : Array X // a.size = n}
--   intro := λ f => Id.run do
--     let mut x : Array X := Array.mkEmpty n
--     for i in [0:n] do
--       let i := ⟨i, sorry⟩
--       x := x.push (f i)
--     ⟨x, sorry⟩
--   get := λ x i => x.1.get ⟨i.1, sorry⟩
--   set := λ x i xi => ⟨x.1.set ⟨i.1, sorry⟩ xi, sorry⟩
--   ext := sorry
-- }

-- instance (n : Nat) : PowType Float n :=
-- {
--   powType := {a : FloatArray // a.size = n}
--   intro := λ f => Id.run do
--     let mut x := FloatArray.mkEmpty n
--     for i in [0:n] do
--       let i := ⟨i, sorry⟩
--       x := x.push (f i)
--     ⟨x, sorry⟩
--   get := λ x i => x.1.get ⟨i.1, sorry⟩
--   set := λ x i xi => ⟨x.1.set ⟨i.1, sorry⟩ xi, sorry⟩
--   ext := sorry
-- }

notation X "^" n => PowType.powType X n

namespace PowType.powType

  variable {X} {n : Nat} [PowType X]

  abbrev get (x : X^n) (i : Fin n) : X := PowType.get x i
  abbrev set (x : X^n) (i : Fin n) (xi : X) : X^n := PowType.set x i xi

  def getOp (self : X^n) (idx : Fin n) : X := self.get idx

  @[simp]
  theorem get_to_getop (x : X^n) (i : Fin n) : x.get i = x[i] := by simp[getOp] done

  @[simp]
  theorem intro_getop (f : Fin n → X) (i : Fin n) : (intro f)[i] = f i := by sorry

  -- instance {X} [PowType X 1] : Coe (X^1) X := ⟨λ x => x.get 0⟩
  -- instance {X} [PowType X 0] : Coe (X^(0:Nat)) Unit := ⟨λ x => ()⟩

  def modify {X} {n : Nat} [PowType X] [Inhabited X] (x : X^n) (i : Fin n) (f : X → X) : X^n := Id.run do
    let mut x := x
    let xi := x[i]
    -- Reset x[i] to ensure `xi` be modified in place if possible
    -- I do not thin we can take the same liberty as Array.modifyMUnsafe and assign `unsafeCast ()`
    x := x.set i default
    x := x.set i (f xi)
    x

  def mapIdx {X} {n : Nat} [PowType X] (x : X^n) (f : Fin n → X → X) : X^n :=
    Id.run do
    let mut x' := x
    for i in [0:n] do
      let i := ⟨i, sorry⟩
      x' := set x' i (f i (get x' i))
    x'

  def map {X} {n : Nat} [PowType X] (x : X^n) (f : X → X) : X^n :=
    x.mapIdx λ i xi => f xi

  section Operations

    variable {X} {n : Nat} [PowType X]

    instance [Add X] : Add (X^n) := ⟨λ x y => x.mapIdx λ i xi => xi + y[i]⟩
    instance [Sub X] : Sub (X^n) := ⟨λ x y => x.mapIdx λ i xi => xi - y[i]⟩
    instance [Mul X] : Mul (X^n) := ⟨λ x y => x.mapIdx λ i xi => xi * y[i]⟩
    instance [Div X] : Div (X^n) := ⟨λ x y => x.mapIdx λ i xi => xi / y[i]⟩

    instance {R} [HMul R X X] : HMul R (X^n) (X^n) := ⟨λ r x => x.map λ xi => r*xi⟩

    instance [Neg X] : Neg (X^n) := ⟨λ x => x.map λ xi => -xi⟩
    instance [Inv X] : Inv (X^n) := ⟨λ x => x.map λ xi => xi⁻¹⟩

    instance [One X]  : One (X^n)  := ⟨intro λ _ => 1⟩
    instance [Zero X] : Zero (X^n) := ⟨intro λ _ => 0⟩

    instance [LT X] : LT (X^n) := ⟨λ u v => ∀ i, u[i] < v[i]⟩
    instance [LE X] : LE (X^n) := ⟨λ u v => ∀ i, u[i] ≤ v[i]⟩

    instance [DecidableEq X] : DecidableEq (X^n) :=
      λ u v => Id.run do
        let mut eq : Bool := true
        for i in [0:n] do
          if u[⟨i,sorry⟩] ≠ v[⟨i,sorry⟩] then
            eq := false
            break
        if eq then isTrue sorry else isFalse sorry

    instance [LT X] [∀ x y : X, Decidable (x < y)] (u v : X^n) : Decidable (u < v) := Id.run do
      let mut eq : Bool := true
      for i in [0:n] do
        if ¬(u[⟨i,sorry⟩] < v[⟨i,sorry⟩]) then
          eq := false
          break
      if eq then isTrue sorry else isFalse sorry

    instance [LE X] [∀ x y : X, Decidable (x ≤ y)] (u v : X^n) : Decidable (u ≤ v) := Id.run do
      let mut eq : Bool := true
      for i in [0:n] do
        if ¬(u[⟨i,sorry⟩] ≤ v[⟨i,sorry⟩]) then
          eq := false
          break
      if eq then isTrue sorry else isFalse sorry

  end Operations

  -- instance {X n} [PowType X n] : Table (X^n) (Fin n) X :=
  --   ⟨λ x i => x.get i⟩

  -- instance {X n} [PowType X n] : Table.Intro (X^n):=
  --   ⟨λ f => PowType.intro f, sorry⟩

  -- instance {X n} [PowType X n] : Table.Set (X^n):=
  --   ⟨λ v i x => v.set i x, sorry⟩

  -- instance {X n} [PowType X n] : Table.MapIdx (X^n):=
  --   ⟨λ f v => v.mapIdx f, sorry⟩

  -- instance {X n} [PowType X n] : Table.Map (X^n):=
  --   ⟨λ f v => v.map f, sorry⟩

  -- section TableOpConversion

  --   variable {X n} [PowType X n]

  --   @[simp]
  --   theorem powtype_get_to_table_get (u : X^n) (i : Fin n)
  --     : u.get i = u[i] := by simp[Table.get, Table.toFun] done

  --   @[simp]
  --   theorem table_set_to_powtype_set (u : X^n) (i : Fin n) (xi : X)
  --     : Table.set u i xi = u.set i xi := by simp[Table.set, Table.toFun] done

  --   @[simp]
  --   theorem table_map_to_powtype_set (u : X^n) (i : Fin n) (xi : X)
  --     : Table.set u i xi = u.set i xi := by simp[Table.set, Table.toFun] done

  -- end TableOpConversion

  def concat {X} {n m : Nat} [PowType X] : (X^n) → (X^m) → X^(n+m) :=
    λ x y => PowType.intro λ i =>
      if i < n then
        x.get ⟨i, sorry⟩
      else
        y.get ⟨i.1-n, sorry⟩

  def split {X} {N : Nat} (n : Fin N) [PowType X] : (X^N) → (X^n) × (X^(N-n)) :=
    λ x =>
      (PowType.intro λ i => x.get ⟨i.1, sorry⟩,
       PowType.intro λ i => x.get ⟨i.1 + n, sorry⟩)

  instance {X} {n : Nat} [ToString X] [PowType X] : ToString (X^n) :=
    ⟨λ x =>
      if n == 0 then
        "^[]"
      else Id.run do
        let mut s : String := "^[" ++ toString (x.get ⟨0, sorry⟩)
        for i in [1:n] do
          s := s ++ ", " ++ toString (x.get ⟨i, sorry⟩)
        s ++ "]"⟩

end PowType.powType

def List.toPowType {X} (l : List X) [PowType X] : X^l.length :=
  PowType.intro λ i => l.toArray.get ⟨i.1, sorry⟩

syntax "^[" sepBy(term, ", ") "]" : term

macro_rules
  | `(^[ $elems,* ]) => `(List.toPowType [ $elems,* ])

@[simp]
theorem sum_intro {ι} [Enumtype ι]
  [PowType α] [Add α] [Zero α] [Zero (Fin n → α)] [Add (Fin n → α)]
  (f : ι → Fin n → α)
  : (∑ i, PowType.intro (f i)) = (PowType.intro (∑ i, f i))
  :=
by
  admit

@[simp]
theorem add_intro
  (f g : Fin n → α) [PowType α] [Add α]
  :
    (PowType.intro f)  + (PowType.intro g)
    =
    (PowType.intro λ i => f i + g i)
  :=
by
  admit

@[simp]
theorem sub_intro
  (f g : Fin n → α) [PowType α] [Sub α]
  :
    (PowType.intro f)  - (PowType.intro g)
    =
    (PowType.intro λ i => f i - g i)
  :=
by
  admit

@[simp]
theorem hmul_intro
  (f : Fin n → α) [PowType α] [HMul β α α] (b : β)
  :
    b * (PowType.intro f) = PowType.intro λ i => b * f i
  :=
by
  admit

-- instance {X} (n : Nat) [PowType X n] [Add X] : Add (X^n) :=
--   ⟨λ x y => x.mapIdx λ i xi => xi + y.get i⟩

-- instance {X} (n : Nat) [PowType X n] [Add X] : HAdd X (X^n) (X^n) :=
--   ⟨λ a x => x.map λ xi => a + xi⟩

-- instance {X} (n : Nat) [PowType X n] [Add X] : HAdd (X^n) X (X^n) :=
--   ⟨λ x a => x.map λ xi => xi + a⟩

-- instance {X} (n : Nat) [PowType X n] [Sub X] : Sub (X^n) :=
--   ⟨λ x y => x.mapIdx λ i xi => xi - y.get i⟩

-- instance {X} (n : Nat) [PowType X n] [Mul X] : Mul (X^n) :=
--   ⟨λ x y => x.mapIdx λ i xi => xi * y.get i⟩

-- instance {X} (n : Nat) [PowType X n] [Mul X] : HMul X (X^n) (X^n) :=
--   ⟨λ a x => x.map λ xi => a * xi⟩

-- instance {X} (n : Nat) [PowType X n] [Mul X] : HMul (X^n) X (X^n) :=
--   ⟨λ x a => x.map λ xi => xi * a⟩

-- instance {X} (n : Nat) [PowType X n] [Div X] : Div (X^n) :=
--   ⟨λ x y => x.mapIdx λ i xi => xi / y.get i⟩

-- instance {X} (n : Nat) [PowType X n] [Neg X] : Neg (X^n) :=
--   ⟨λ x => x.map λ xi => - xi⟩

-- instance {X} (n : Nat) [PowType X n] [Zero X] : Zero (Float^n) :=
--   ⟨PowType.intro λ _ => 0⟩

-- instance {X} (n : Nat) [PowType X n] [One X] : One (Float^n) :=
--   ⟨PowType.intro λ _ => 1⟩

-- def v1 : Float^(3 : Nat) := ^[1.0,2.0,3.0]
-- def v2 : Float^(3 : Nat) := ^[2.0,3.0,5.0]
-- def v3 : Float^(3 : Nat) := v1 / v2

-- #eval (v1.concat v2).split 4

-- #eval v1[(0 : Fin 3)]

-- #eval ∑ i, v1[i]
-- #eval ∑ i, v2[i]


variables A B : Prop

premise P1 : A

example : not( (not A) /\ B) :=
assume H1: (not A)/\ B,
show false, from (and.left H1) P1.

/- Negation at right-/


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

https://github.com/leanprover-community/mathlib/blob/master/src/algebra/graded_monoid.lean
-/
import algebra.group.inj_surj
import data.list.big_operators
import data.list.range
import group_theory.group_action.defs
import group_theory.submonoid.basic
import data.set_like.basic
import data.sigma.basic

/-!
# Additively-graded multiplicative structures

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over the sigma type `graded_monoid A` such that `(*) : A i → A j → A (i + j)`; that is to say, `A`
forms an additively-graded monoid. The typeclasses are:

* `graded_monoid.ghas_one A`
* `graded_monoid.ghas_mul A`
* `graded_monoid.gmonoid A`
* `graded_monoid.gcomm_monoid A`

With the `sigma_graded` locale open, these respectively imbue:

* `has_one (graded_monoid A)`
* `has_mul (graded_monoid A)`
* `monoid (graded_monoid A)`
* `comm_monoid (graded_monoid A)`

the base type `A 0` with:

* `graded_monoid.grade_zero.has_one`
* `graded_monoid.grade_zero.has_mul`
* `graded_monoid.grade_zero.monoid`
* `graded_monoid.grade_zero.comm_monoid`

and the `i`th grade `A i` with `A 0`-actions (`•`) defined as left-multiplication:

* (nothing)
* `graded_monoid.grade_zero.has_smul (A 0)`
* `graded_monoid.grade_zero.mul_action (A 0)`
* (nothing)

For now, these typeclasses are primarily used in the construction of `direct_sum.ring` and the rest
of that file.

## Dependent graded products

This also introduces `list.dprod`, which takes the (possibly non-commutative) product of a list
of graded elements of type `A i`. This definition primarily exist to allow `graded_monoid.mk`
and `direct_sum.of` to be pulled outside a product, such as in `graded_monoid.mk_list_dprod` and
`direct_sum.of_list_dprod`.

## Internally graded monoids

In addition to the above typeclasses, in the most frequent case when `A` is an indexed collection of
`set_like` subobjects (such as `add_submonoid`s, `add_subgroup`s, or `submodule`s), this file
provides the `Prop` typeclasses:

* `set_like.has_graded_one A` (which provides the obvious `graded_monoid.ghas_one A` instance)
* `set_like.has_graded_mul A` (which provides the obvious `graded_monoid.ghas_mul A` instance)
* `set_like.graded_monoid A` (which provides the obvious `graded_monoid.gmonoid A` and
  `graded_monoid.gcomm_monoid A` instances)
* `set_like.is_homogeneous A` (which says that `a` is homogeneous iff `a ∈ A i` for some `i : ι`)

Strictly this last class is unecessary as it has no fields not present in its parents, but it is
included for convenience. Note that there is no need for `graded_ring` or similar, as all the
information it would contain is already supplied by `graded_monoid` when `A` is a collection
of additively-closed set_like objects such as `submodule`s. These constructions are explored in
`algebra.direct_sum.internal`.

This file also contains the definition of `set_like.homogeneous_submonoid A`, which is, as the name
suggests, the submonoid consisting of all the homogeneous elements.

## tags

graded monoid
-/

set_option old_structure_cmd true

variables {ι : Type*}

/-- A type alias of sigma types for graded monoids. -/
def graded_monoid (A : ι → Type*) := sigma A

namespace graded_monoid

instance {A : ι → Type*} [inhabited ι] [inhabited (A default)]: inhabited (graded_monoid A) :=
sigma.inhabited

/-- Construct an element of a graded monoid. -/
def mk {A : ι → Type*} : Π i, A i → graded_monoid A := sigma.mk

/-! ### Typeclasses -/
section defs

variables (A : ι → Type*)

/-- A graded version of `has_one`, which must be of grade 0. -/
class ghas_one [has_zero ι] :=
(one : A 0)

/-- `ghas_one` implies `has_one (graded_monoid A)` -/
instance ghas_one.to_has_one [has_zero ι] [ghas_one A] : has_one (graded_monoid A) :=
⟨⟨_, ghas_one.one⟩⟩

/-- A graded version of `has_mul`. Multiplication combines grades additively, like
`add_monoid_algebra`. -/
class ghas_mul [has_add ι] :=
(mul {i j} : A i → A j → A (i + j))

/-- `ghas_mul` implies `has_mul (graded_monoid A)`. -/
instance ghas_mul.to_has_mul [has_add ι] [ghas_mul A] :
  has_mul (graded_monoid A) :=
⟨λ (x y : graded_monoid A), ⟨_, ghas_mul.mul x.snd y.snd⟩⟩

lemma mk_mul_mk [has_add ι] [ghas_mul A] {i j} (a : A i) (b : A j) :
  mk i a * mk j b = mk (i + j) (ghas_mul.mul a b) :=
rfl

namespace gmonoid

variables {A} [add_monoid ι] [ghas_mul A] [ghas_one A]

/-- A default implementation of power on a graded monoid, like `npow_rec`.
`gmonoid.gnpow` should be used instead. -/
def gnpow_rec : Π (n : ℕ) {i}, A i → A (n • i)
| 0 i a := cast (congr_arg A (zero_nsmul i).symm) ghas_one.one
| (n + 1) i a := cast (congr_arg A (succ_nsmul i n).symm) (ghas_mul.mul a $ gnpow_rec _ a)

@[simp] lemma gnpow_rec_zero (a : graded_monoid A) : graded_monoid.mk _ (gnpow_rec 0 a.snd) = 1 :=
sigma.ext (zero_nsmul _) (heq_of_cast_eq _ rfl).symm

/-- Tactic used to autofill `graded_monoid.gmonoid.gnpow_zero'` when the default
`graded_monoid.gmonoid.gnpow_rec` is used. -/
meta def apply_gnpow_rec_zero_tac : tactic unit := `[apply graded_monoid.gmonoid.gnpow_rec_zero]

@[simp] lemma gnpow_rec_succ (n : ℕ) (a : graded_monoid A) :
  (graded_monoid.mk _ $ gnpow_rec n.succ a.snd) = a * ⟨_, gnpow_rec n a.snd⟩ :=
sigma.ext (succ_nsmul _ _) (heq_of_cast_eq _ rfl).symm

/-- Tactic used to autofill `graded_monoid.gmonoid.gnpow_succ'` when the default
`graded_monoid.gmonoid.gnpow_rec` is used. -/
meta def apply_gnpow_rec_succ_tac : tactic unit := `[apply graded_monoid.gmonoid.gnpow_rec_succ]

end gmonoid

/-- A graded version of `monoid`.

Like `monoid.npow`, this has an optional `gmonoid.gnpow` field to allow definitional control of
natural powers of a graded monoid. -/
class gmonoid [add_monoid ι]  extends ghas_mul A, ghas_one A :=
(one_mul (a : graded_monoid A) : 1 * a = a)
(mul_one (a : graded_monoid A) : a * 1 = a)
(mul_assoc (a b c : graded_monoid A) : a * b * c = a * (b * c))
(gnpow : Π (n : ℕ) {i}, A i → A (n • i) := gmonoid.gnpow_rec)
(gnpow_zero' : Π (a : graded_monoid A), graded_monoid.mk _ (gnpow 0 a.snd) = 1
  . gmonoid.apply_gnpow_rec_zero_tac)
(gnpow_succ' : Π (n : ℕ) (a : graded_monoid A),
  (graded_monoid.mk _ $ gnpow n.succ a.snd) = a * ⟨_, gnpow n a.snd⟩
  . gmonoid.apply_gnpow_rec_succ_tac)

/-- `gmonoid` implies a `monoid (graded_monoid A)`. -/
instance gmonoid.to_monoid [add_monoid ι] [gmonoid A] :
  monoid (graded_monoid A) :=
{ one := (1), mul := (*),
  npow := λ n a, graded_monoid.mk _ (gmonoid.gnpow n a.snd),
  npow_zero' := λ a, gmonoid.gnpow_zero' a,
  npow_succ' := λ n a, gmonoid.gnpow_succ' n a,
  one_mul := gmonoid.one_mul, mul_one := gmonoid.mul_one, mul_assoc := gmonoid.mul_assoc }

lemma mk_pow [add_monoid ι] [gmonoid A] {i} (a : A i) (n : ℕ) :
  mk i a ^ n = mk (n • i) (gmonoid.gnpow _ a) :=
begin
  induction n with n,
  { rw [pow_zero],
    exact (gmonoid.gnpow_zero' ⟨_, a⟩).symm, },
  { rw [pow_succ, n_ih, mk_mul_mk],
    exact (gmonoid.gnpow_succ' n ⟨_, a⟩).symm, },
end

/-- A graded version of `comm_monoid`. -/
class gcomm_monoid [add_comm_monoid ι] extends gmonoid A :=
(mul_comm (a : graded_monoid A) (b : graded_monoid A) : a * b = b * a)

/-- `gcomm_monoid` implies a `comm_monoid (graded_monoid A)`, although this is only used as an
instance locally to define notation in `gmonoid` and similar typeclasses. -/
instance gcomm_monoid.to_comm_monoid [add_comm_monoid ι] [gcomm_monoid A] :
  comm_monoid (graded_monoid A) :=
{ mul_comm := gcomm_monoid.mul_comm, ..gmonoid.to_monoid A }

end defs

/-! ### Instances for `A 0`

The various `g*` instances are enough to promote the `add_comm_monoid (A 0)` structure to various
types of multiplicative structure.
-/

section grade_zero

variables (A : ι → Type*)

section one
variables [has_zero ι] [ghas_one A]

/-- `1 : A 0` is the value provided in `ghas_one.one`. -/
@[nolint unused_arguments]
instance grade_zero.has_one : has_one (A 0) :=
⟨ghas_one.one⟩

end one

section mul
variables [add_zero_class ι] [ghas_mul A]

/-- `(•) : A 0 → A i → A i` is the value provided in `graded_monoid.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + i)` into `A i`.
-/
instance grade_zero.has_smul (i : ι) : has_smul (A 0) (A i) :=
{ smul := λ x y, (zero_add i).rec (ghas_mul.mul x y) }

/-- `(*) : A 0 → A 0 → A 0` is the value provided in `graded_monoid.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + 0)` into `A 0`.
-/
instance grade_zero.has_mul : has_mul (A 0) :=
{ mul := (•) }

variables {A}

@[simp] lemma mk_zero_smul {i} (a : A 0) (b : A i) : mk _ (a • b) = mk _ a * mk _ b :=
sigma.ext (zero_add _).symm $ eq_rec_heq _ _

@[simp] lemma grade_zero.smul_eq_mul (a b : A 0) : a • b = a * b := rfl

end mul

section monoid
variables [add_monoid ι] [gmonoid A]

instance : has_pow (A 0) ℕ :=
{ pow := λ x n, (nsmul_zero n).rec (gmonoid.gnpow n x : A (n • 0)) }

variables {A}

@[simp] lemma mk_zero_pow (a : A 0) (n : ℕ) : mk _ (a ^ n) = mk _ a ^ n :=
sigma.ext (nsmul_zero n).symm $ eq_rec_heq _ _

variables (A)

/-- The `monoid` structure derived from `gmonoid A`. -/
instance grade_zero.monoid : monoid (A 0) :=
function.injective.monoid (mk 0) sigma_mk_injective rfl mk_zero_smul mk_zero_pow

end monoid

section monoid
variables [add_comm_monoid ι] [gcomm_monoid A]

/-- The `comm_monoid` structure derived from `gcomm_monoid A`. -/
instance grade_zero.comm_monoid : comm_monoid (A 0) :=
function.injective.comm_monoid (mk 0) sigma_mk_injective rfl mk_zero_smul mk_zero_pow

end monoid

section mul_action
variables [add_monoid ι] [gmonoid A]

/-- `graded_monoid.mk 0` is a `monoid_hom`, using the `graded_monoid.grade_zero.monoid` structure.
-/
def mk_zero_monoid_hom : A 0 →* (graded_monoid A) :=
{ to_fun := mk 0, map_one' := rfl, map_mul' := mk_zero_smul }

/-- Each grade `A i` derives a `A 0`-action structure from `gmonoid A`. -/
instance grade_zero.mul_action {i} : mul_action (A 0) (A i) :=
begin
  letI := mul_action.comp_hom (graded_monoid A) (mk_zero_monoid_hom A),
  exact function.injective.mul_action (mk i) sigma_mk_injective mk_zero_smul,
end

end mul_action

end grade_zero

end graded_monoid

/-! ### Dependent products of graded elements -/

section dprod

variables {α : Type*} {A : ι → Type*} [add_monoid ι] [graded_monoid.gmonoid A]

/-- The index used by `list.dprod`. Propositionally this is equal to `(l.map fι).sum`, but
definitionally it needs to have a different form to avoid introducing `eq.rec`s in `list.dprod`. -/
def list.dprod_index (l : list α) (fι : α → ι) : ι :=
l.foldr (λ i b, fι i + b) 0

@[simp] lemma list.dprod_index_nil (fι : α → ι) : ([] : list α).dprod_index fι = 0 := rfl
@[simp] lemma list.dprod_index_cons (a : α) (l : list α) (fι : α → ι) :
  (a :: l).dprod_index fι = fι a + l.dprod_index fι := rfl

lemma list.dprod_index_eq_map_sum (l : list α) (fι : α → ι) :
  l.dprod_index fι = (l.map fι).sum :=
begin
  dunfold list.dprod_index,
  induction l,
  { simp, },
  { simp [l_ih], },
end

/-- A dependent product for graded monoids represented by the indexed family of types `A i`.
This is a dependent version of `(l.map fA).prod`.

For a list `l : list α`, this computes the product of `fA a` over `a`, where each `fA` is of type
`A (fι a)`. -/
def list.dprod (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  A (l.dprod_index fι) :=
l.foldr_rec_on _ _ graded_monoid.ghas_one.one (λ i x a ha, graded_monoid.ghas_mul.mul (fA a) x)

@[simp] lemma list.dprod_nil (fι : α → ι) (fA : Π a, A (fι a)) :
  (list.nil : list α).dprod fι fA = graded_monoid.ghas_one.one := rfl

-- the `( : _)` in this lemma statement results in the type on the RHS not being unfolded, which
-- is nicer in the goal view.
@[simp] lemma list.dprod_cons (fι : α → ι) (fA : Π a, A (fι a)) (a : α) (l : list α) :
  (a :: l).dprod fι fA = (graded_monoid.ghas_mul.mul (fA a) (l.dprod fι fA) : _) := rfl

lemma graded_monoid.mk_list_dprod (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  graded_monoid.mk _ (l.dprod fι fA) = (l.map (λ a, graded_monoid.mk (fι a) (fA a))).prod :=
begin
  induction l,
  { simp, refl  },
  { simp [←l_ih, graded_monoid.mk_mul_mk, list.prod_cons],
    refl, },
end

/-- A variant of `graded_monoid.mk_list_dprod` for rewriting in the other direction. -/
lemma graded_monoid.list_prod_map_eq_dprod (l : list α) (f : α → graded_monoid A) :
  (l.map f).prod = graded_monoid.mk _ (l.dprod (λ i, (f i).1) (λ i, (f i).2)) :=
begin
  rw [graded_monoid.mk_list_dprod, graded_monoid.mk],
  simp_rw sigma.eta,
end

lemma graded_monoid.list_prod_of_fn_eq_dprod {n : ℕ} (f : fin n → graded_monoid A) :
  (list.of_fn f).prod =
    graded_monoid.mk _ ((list.fin_range n).dprod (λ i, (f i).1) (λ i, (f i).2)) :=
by rw [list.of_fn_eq_map, graded_monoid.list_prod_map_eq_dprod]

end dprod

/-! ### Concrete instances -/
section

variables (ι) {R : Type*}

@[simps one]
instance has_one.ghas_one [has_zero ι] [has_one R] : graded_monoid.ghas_one (λ i : ι, R) :=
{ one := 1 }

@[simps mul]
instance has_mul.ghas_mul [has_add ι] [has_mul R] : graded_monoid.ghas_mul (λ i : ι, R) :=
{ mul := λ i j, (*) }

/-- If all grades are the same type and themselves form a monoid, then there is a trivial grading
structure. -/
@[simps gnpow]
instance monoid.gmonoid [add_monoid ι] [monoid R] : graded_monoid.gmonoid (λ i : ι, R) :=
{ one_mul := λ a, sigma.ext (zero_add _) (heq_of_eq (one_mul _)),
  mul_one := λ a, sigma.ext (add_zero _) (heq_of_eq (mul_one _)),
  mul_assoc := λ a b c, sigma.ext (add_assoc _ _ _) (heq_of_eq (mul_assoc _ _ _)),
  gnpow := λ n i a, a ^ n,
  gnpow_zero' := λ a, sigma.ext (zero_nsmul _) (heq_of_eq (monoid.npow_zero' _)),
  gnpow_succ' := λ n ⟨i, a⟩, sigma.ext (succ_nsmul _ _) (heq_of_eq (monoid.npow_succ' _ _)),
  ..has_one.ghas_one ι,
  ..has_mul.ghas_mul ι }

/-- If all grades are the same type and themselves form a commutative monoid, then there is a
trivial grading structure. -/
instance comm_monoid.gcomm_monoid [add_comm_monoid ι] [comm_monoid R] :
  graded_monoid.gcomm_monoid (λ i : ι, R) :=
{ mul_comm := λ a b, sigma.ext (add_comm _ _) (heq_of_eq (mul_comm _ _)),
  ..monoid.gmonoid ι }

/-- When all the indexed types are the same, the dependent product is just the regular product. -/
@[simp] lemma list.dprod_monoid {α} [add_monoid ι] [monoid R] (l : list α) (fι : α → ι)
  (fA : α → R) :
  (l.dprod fι fA : (λ i : ι, R) _) = ((l.map fA).prod : _) :=
begin
  induction l,
  { rw [list.dprod_nil, list.map_nil, list.prod_nil], refl },
  { rw [list.dprod_cons, list.map_cons, list.prod_cons, l_ih], refl },
end

end

/-! ### Shorthands for creating instance of the above typeclasses for collections of subobjects -/

section subobjects

variables {R : Type*}

/-- A version of `graded_monoid.ghas_one` for internally graded objects. -/
class set_like.has_graded_one {S : Type*} [set_like S R] [has_one R] [has_zero ι]
  (A : ι → S) : Prop :=
(one_mem : (1 : R) ∈ A 0)

instance set_like.ghas_one {S : Type*} [set_like S R] [has_one R] [has_zero ι] (A : ι → S)
  [set_like.has_graded_one A] : graded_monoid.ghas_one (λ i, A i) :=
{ one := ⟨1, set_like.has_graded_one.one_mem⟩ }

@[simp] lemma set_like.coe_ghas_one {S : Type*} [set_like S R] [has_one R] [has_zero ι] (A : ι → S)
  [set_like.has_graded_one A] : ↑(@graded_monoid.ghas_one.one _ (λ i, A i) _ _) = (1 : R) := rfl

/-- A version of `graded_monoid.ghas_one` for internally graded objects. -/
class set_like.has_graded_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι]
  (A : ι → S) : Prop :=
(mul_mem : ∀ ⦃i j⦄ {gi gj}, gi ∈ A i → gj ∈ A j → gi * gj ∈ A (i + j))

instance set_like.ghas_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι] (A : ι → S)
  [set_like.has_graded_mul A] :
  graded_monoid.ghas_mul (λ i, A i) :=
{ mul := λ i j a b, ⟨(a * b : R), set_like.has_graded_mul.mul_mem a.prop b.prop⟩ }

@[simp] lemma set_like.coe_ghas_mul {S : Type*} [set_like S R] [has_mul R] [has_add ι] (A : ι → S)
  [set_like.has_graded_mul A] {i j : ι} (x : A i) (y : A j) :
    ↑(@graded_monoid.ghas_mul.mul _ (λ i, A i) _ _ _ _ x y) = (x * y : R) := rfl

/-- A version of `graded_monoid.gmonoid` for internally graded objects. -/
class set_like.graded_monoid {S : Type*} [set_like S R] [monoid R] [add_monoid ι]
  (A : ι → S) extends set_like.has_graded_one A, set_like.has_graded_mul A : Prop

namespace set_like.graded_monoid
variables {S : Type*} [set_like S R] [monoid R] [add_monoid ι]
variables {A : ι → S} [set_like.graded_monoid A]

lemma pow_mem (n : ℕ) {r : R} {i : ι} (h : r ∈ A i) : r ^ n ∈ A (n • i) :=
begin
  induction n,
  { rw [pow_zero, zero_nsmul], exact one_mem },
  { rw [pow_succ', succ_nsmul'], exact mul_mem n_ih h },
end

lemma list_prod_map_mem {ι'} (l : list ι') (i : ι' → ι) (r : ι' → R) (h : ∀ j ∈ l, r j ∈ A (i j)) :
  (l.map r).prod ∈ A (l.map i).sum :=
begin
  induction l,
  { rw [list.map_nil, list.map_nil, list.prod_nil, list.sum_nil],
    exact one_mem },
  { rw [list.map_cons, list.map_cons, list.prod_cons, list.sum_cons],
    exact mul_mem (h _ $ list.mem_cons_self _ _) (l_ih $ λ j hj, h _ $ list.mem_cons_of_mem _ hj) },
end

lemma list_prod_of_fn_mem {n} (i : fin n → ι) (r : fin n → R) (h : ∀ j, r j ∈ A (i j)) :
  (list.of_fn r).prod ∈ A (list.of_fn i).sum :=
begin
  rw [list.of_fn_eq_map, list.of_fn_eq_map],
  exact list_prod_map_mem _ _ _ (λ _ _, h _),
end

end set_like.graded_monoid

/-- Build a `gmonoid` instance for a collection of subobjects. -/
instance set_like.gmonoid {S : Type*} [set_like S R] [monoid R] [add_monoid ι] (A : ι → S)
  [set_like.graded_monoid A] :
  graded_monoid.gmonoid (λ i, A i) :=
{ one_mul := λ ⟨i, a, h⟩, sigma.subtype_ext (zero_add _) (one_mul _),
  mul_one := λ ⟨i, a, h⟩, sigma.subtype_ext (add_zero _) (mul_one _),
  mul_assoc := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩ ⟨k, c, hc⟩,
    sigma.subtype_ext (add_assoc _ _ _) (mul_assoc _ _ _),
  gnpow := λ n i a, ⟨a ^ n, set_like.graded_monoid.pow_mem n a.prop⟩,
  gnpow_zero' := λ n, sigma.subtype_ext (zero_nsmul _) (pow_zero _),
  gnpow_succ' := λ n a, sigma.subtype_ext (succ_nsmul _ _) (pow_succ _ _),
  ..set_like.ghas_one A,
  ..set_like.ghas_mul A }

@[simp] lemma set_like.coe_gnpow {S : Type*} [set_like S R] [monoid R] [add_monoid ι] (A : ι → S)
  [set_like.graded_monoid A] {i : ι} (x : A i) (n : ℕ) :
    ↑(@graded_monoid.gmonoid.gnpow _ (λ i, A i) _ _ n _ x) = (x ^ n : R) := rfl

/-- Build a `gcomm_monoid` instance for a collection of subobjects. -/
instance set_like.gcomm_monoid {S : Type*} [set_like S R] [comm_monoid R] [add_comm_monoid ι]
  (A : ι → S) [set_like.graded_monoid A] :
  graded_monoid.gcomm_monoid (λ i, A i) :=
{ mul_comm := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩, sigma.subtype_ext (add_comm _ _) (mul_comm _ _),
  ..set_like.gmonoid A}

section dprod
open set_like set_like.graded_monoid
variables {α S : Type*} [set_like S R] [monoid R] [add_monoid ι]

/-- Coercing a dependent product of subtypes is the same as taking the regular product of the
coercions. -/
@[simp] lemma set_like.coe_list_dprod (A : ι → S) [set_like.graded_monoid A]
  (fι : α → ι) (fA : Π a, A (fι a)) (l : list α) :
  ↑(l.dprod fι fA : (λ i, ↥(A i)) _) = (list.prod (l.map (λ a, fA a)) : R) :=
begin
  induction l,
  { rw [list.dprod_nil, coe_ghas_one, list.map_nil, list.prod_nil] },
  { rw [list.dprod_cons, coe_ghas_mul, list.map_cons, list.prod_cons, l_ih], },
end

include R

/-- A version of `list.coe_dprod_set_like` with `subtype.mk`. -/
lemma set_like.list_dprod_eq (A : ι → S) [set_like.graded_monoid A]
  (fι : α → ι) (fA : Π a, A (fι a)) (l : list α) :
  (l.dprod fι fA : (λ i, ↥(A i)) _) =
    ⟨list.prod (l.map (λ a, fA a)), (l.dprod_index_eq_map_sum fι).symm ▸
      list_prod_map_mem l _ _ (λ i hi, (fA i).prop)⟩ :=
subtype.ext $ set_like.coe_list_dprod _ _ _ _

end dprod

end subobjects

section homogeneous_elements

variables {R S : Type*} [set_like S R]

/-- An element `a : R` is said to be homogeneous if there is some `i : ι` such that `a ∈ A i`. -/
def set_like.is_homogeneous (A : ι → S) (a : R) : Prop := ∃ i, a ∈ A i

@[simp] lemma set_like.is_homogeneous_coe {A : ι → S} {i} (x : A i) :
  set_like.is_homogeneous A (x : R) :=
⟨i, x.prop⟩

lemma set_like.is_homogeneous_one [has_zero ι] [has_one R]
  (A : ι → S) [set_like.has_graded_one A] : set_like.is_homogeneous A (1 : R) :=
⟨0, set_like.has_graded_one.one_mem⟩

lemma set_like.is_homogeneous.mul [has_add ι] [has_mul R] {A : ι → S}
  [set_like.has_graded_mul A] {a b : R} :
  set_like.is_homogeneous A a → set_like.is_homogeneous A b → set_like.is_homogeneous A (a * b)
| ⟨i, hi⟩ ⟨j, hj⟩ := ⟨i + j, set_like.has_graded_mul.mul_mem hi hj⟩

/-- When `A` is a `set_like.graded_monoid A`, then the homogeneous elements forms a submonoid. -/
def set_like.homogeneous_submonoid [add_monoid ι] [monoid R]
  (A : ι → S) [set_like.graded_monoid A] : submonoid R :=
{ carrier := { a | set_like.is_homogeneous A a },
  one_mem' := set_like.is_homogeneous_one A,
  mul_mem' := λ a b, set_like.is_homogeneous.mul }

end homogeneous_elements


import algebra.category.CommRing.basic
import algebra.ring
import tactic
import category_theory.concrete_category.bundled_hom
import category_theory.functor_category -- this transitively imports
import algebra.ring
import category_theory.types
import .A2_disc
open category_theory
/--
##  It's the group functor  Idem,
##  e1 × e2 = e1 e2 + (1-e1)(1-e2)
-/
structure Idem (R : Type ) [comm_ring R] :=
(e  : R)
(certif :  e * e = e)
namespace  Idem
 variables {R : Type }[comm_ring R]
    section                               --   ""
    /- extention lemma : E = E' ↔  E.e = E'.e
    -/
    @[ext]lemma ext : ∀ {g1 g2 : Idem R}, g1.e = g2.e → g1 = g2 := λ g1 g2,
        begin
            intros h1 ,
            cases g1,
            cases g2,
            congr ; try { assumption },   ---
        end
    lemma idem_to_sym (E :Idem R) : (2*E.e-1)^2 = 1 :=
    begin
        have T : (2*E.e-1)^2 = 4*(E.e*E.e)-4*E.e+1,
            ring,
        rw [T,E.certif],ring,
    end
    -- We start to define one element : neutral element
    def one  : Idem (R) := {e := 1,  certif := mul_one 1}
    instance : has_one (Idem R) := ⟨one⟩
    -- lemma !
    lemma one_e : (1 : Idem(R)).e = 1 := rfl
    -- comm ring calculation !
    lemma alg_calc (a b : R) : (a * b + (1 - a) * (1 - b)) * (a * b + (1 - a) * (1 - b)) =(a * a) * (b * b) +
                         ((1 - a) * (1 - a)) * ((1 - b) * (1 - b)) + 2* (a* (1 - a)) * (b*(1 - b)) := by ring

    lemma compl_e (E : Idem R) : (1-E.e) * (1-E.e)  = (1-E.e)  :=
        begin
            have H : (1-E.e) * (1-E.e) = 1- 2 * E.e + E.e *E.e,
                ring,
            rw E.certif at H,
            rw H,
            ring,
        end
    /-   e → 1-e
    -/
    def ortho : Idem R → Idem R := λ E,
        begin
            exact {e := 1-E.e, certif := compl_e E}
        end
    lemma ortho_comp (E : Idem R) : (ortho E).e = 1-E.e := rfl
    lemma ortho_is_involution (E : Idem R) : ortho (ortho E) = E :=
    begin
        ext,
        rw ortho_comp,
        rw ortho_comp,
        ring,
    end

    lemma ortho_e (E : Idem R) : E.e * (1-E.e) = 0 :=
        begin
            rw [mul_sub_left_distrib,mul_one,E.certif],
            exact sub_self E.e,
        end
    def mul_map' : Idem (R) →  Idem (R) → Idem (R) := λ g1 g2, begin
        exact { e := g1.e * g2.e + ((1 : R) -g1.e) * ((1 : R)-g2.e),certif := begin
            rw [alg_calc g1.e g2.e,ortho_e g1,g1.certif,g2.certif,mul_zero,zero_mul,add_zero,compl_e g1,compl_e g2], end }
    end
    instance : inhabited (Idem R) := ⟨1⟩

    instance : has_mul (Idem R) := ⟨Idem.mul_map'⟩

    lemma e_comp (g1 g2 : Idem R) : (g1 * g2).e = g1.e * g2.e+((1 :R)-g1.e) * ((1 : R)-g2.e) :=  rfl

    def mul_inv : Idem R → Idem R := λ g, g

    instance : has_inv (Idem R) := ⟨Idem.mul_inv⟩

    lemma e_comp_inv (g : Idem R) : (g⁻¹).e =g.e  :=  rfl
    meta def AGL_ring : tactic unit :=
            `[simp only [one_e, e_comp ,e_comp_inv], ring]

    run_cmd add_interactive [`AGL_ring]

def mul_one'  (g : Idem R) :  g * 1 = g := begin ext; AGL_ring, end
def one_mul' (g : Idem R)  : 1 * g = g := begin ext ;AGL_ring, end
def mul_assoc' (g1 g2 g3 : Idem R) :  (g1 * g2) * g3 = g1 * (g2 * g3) := begin ext; AGL_ring, end

lemma mul_right_inv' (g : Idem R) : g * g⁻¹ = 1 :=
   begin
        ext,
        rw [e_comp,e_comp_inv,g.certif,compl_e,one_e],
        simp,
    end

 lemma mul_left_inv' (g : Idem R) :  g⁻¹ * g = 1 :=
    begin
        ext,
        rw [e_comp,e_comp_inv,g.certif,compl_e,one_e],
        simp,
    end
instance : group (Idem R) :=
  { mul             := mul_map',
    one             := 1,
    one_mul         := one_mul',
    mul_one         := mul_one',
    inv             :=  mul_inv,
    mul_assoc       := mul_assoc',
    mul_left_inv    := mul_left_inv',}

open CommRing
open is_ring_hom
variables {R' : Type }[comm_ring R'] (f : R →  R')[is_ring_hom f]
def hom_map (f : R →  R')[is_ring_hom f] : Idem (R) → Idem (R') := λ g,
    {
        e := f g.e,
        certif := begin rw [← map_mul (f),g.certif], end
    }
lemma e_comp_hom (g : Idem R) : (hom_map (f) (g)).e = f g.e := rfl
meta def idem_hom : tactic unit :=
`[simp only [map_add f,map_mul f,map_sub f,map_one f,e_comp_hom,e_comp]]

run_cmd add_interactive [`idem_hom]
lemma hom_map_group_comp  (g1 g2 : Idem R) :
     hom_map (f) (g1 * g2) = (hom_map (f) g1) * hom_map (f) g2  := begin
        ext,
        idem_hom,
        -- rw [e_comp_hom,e_comp,map_add f,map_mul f,map_mul f,map_sub f,map_sub f,map_one f],
     end

lemma hom_map_one : hom_map f (1) = 1 :=
begin
    ext,
    exact map_one f,
end
def map : (Idem R) →*  (Idem R') :=   monoid_hom.mk' (hom_map f) (hom_map_group_comp f)
def Idem_ : CommRing ⥤ Group  :=
{ obj := λ R, Group.of (Idem R),
  map := λ R R' f, (map f),
}
end
#print Idem_
namespace Idem.calculus
    open nat
    lemma idem_comb (a : R) (E : Idem R) : E.e * a + (1 - E.e) * a = a := by ring
    lemma localy_eq (a b : R) (E : Idem R) : E.e * a = E.e * b → ((1 : R)-E.e ) * a = ((1 : R)-E.e)*b →  a = b := λ h1 h2, begin
        have H : E.e * a + (1 - E.e) * a = E.e * b+(1 - E.e) * b,
            rw [h1,h2],
        rw idem_comb (a) (E) at H,
        rw idem_comb (b) (E) at H,
        exact H,
    end
    lemma square_idem (a : R) (E : Idem R) : a^2 = (E.e * a - (1-E.e) * a)^2 :=
    begin
        have H : (E.e * a - (1 - E.e) * a) ^ 2 = (E.e * E.e) * (a * a) - 2 * (a * a) * (E.e * (1-E.e)) + (a*a)*((1-E.e)*(1-E.e)),
            ring,
        rw E.certif at H,
        rw ortho_e E at H,
        rw compl_e E at H,
        rw H,
        ring,
    end

end Idem.calculus
end Idem