import data.polynomial
open finset
universes u v
variables
          {R : Type u}[nonzero_comm_ring R]
          {A : Type v} [fintype A][decidable_eq A]
          (M : matrix A A R)
          (N : matrix A A (polynomial R))
namespace tools
open polynomial
open with_bot
notation `Σ` := finset.sum finset.univ
open_locale big_operators
/-!
    We start by explaining the strategy.
    Let :
    `(s : finset A)(φ :A → polynomial R)(a : A)`
    `(hyp : ∀ b : A, a ≠ b →  degree (φ b) < degree (φ a) )`+
    `(hyp_not_nul : ⊥  < degree (φ a))`:
    Then
    `if a ∈ s then (degree (∑ x in s, φ x ) =  degree (φ a))`
            ` else degree (∑ x in s, φ x ) < (degree (φ a))`
    The caracteristic polynomial is constuct as a product over permutation.
    We analyse each term of the sum.
        If `σ = id ` then the degree of the polynomial is `card A` else the degre is less (`<`) than `card A`
    That permit to apply the next lemma.
-/

namespace with_bot

end with_bot

lemma χ_degree_strategy (s : finset A)(φ :A → polynomial R)(a : A)
(hyp : ∀ b : A, a ≠ b →  degree (φ b) < degree (φ a) ) (hyp_not_nul : ⊥  < degree (φ a)):

        if a ∈ s then (degree (∑ x in s, φ x ) =  degree (φ a)) else degree (∑ x in s, φ x ) < (degree (φ a)) :=
begin
    apply (finset.induction_on s), {
        intros, let F :=  not_mem_empty a, split_ifs,
        rw finset.sum_empty, rw degree_zero, assumption,
    },
    {{
        intros ℓ s hyp_ℓ hyp_rec,
        let p1 := φ a,
        let p2 := ∑ x in s, φ x ,
        split_ifs with H, {
            by_cases a = ℓ,
                {
                    rw sum_insert (by assumption),
                    rw ← h,
                    split_ifs at hyp_rec,
                        {
                            rw h at h_1, trivial,
                            },
                        {   rw add_comm,
                            apply degree_add_eq_of_degree_lt hyp_rec,
                            },

                },
                {
                    split_ifs at hyp_rec,
                    {
                        rw sum_insert (by assumption),rw ← hyp_rec,
                        apply degree_add_eq_of_degree_lt, rw hyp_rec,
                        exact hyp ℓ h,
                        },
                    {
                        rw sum_insert (by assumption),
                        let g := mem_of_mem_insert_of_ne H h, trivial,
                        },
                },
        },
            split_ifs at hyp_rec,
            {   have : a ∈ insert ℓ s,
                    apply  mem_insert_of_mem  h, trivial,

            },
            {
                rw sum_insert (by assumption),
                have : a ≠ ℓ,
                    let g := mem_insert_self ℓ s,
                    intro, rw a_1 at H, trivial,
                specialize hyp ℓ this,
                apply lt_of_le_of_lt (degree_add_le (φ ℓ ) p2),
                apply  max_lt (hyp)(hyp_rec),
            },
    }},
end

/--
    let `(φ : A → polynomial R)`  a familly of polynomial.
    let `(a : A)` s t  `∀ b : A, a ≠ b,`   `degree (φ b) < degree (φ a)`
    assume  `degree (φ a) not ⊥`.
    Then    `degree (Σ  φ ) =  degree (φ a)`
-/
lemma proof_strategy.car_pol_degree  (φ : A → polynomial R)(a : A)
(hyp : ∀ b : A, a ≠ b →  degree (φ b) < degree (φ a) )  ---
(hyp_not_nul : ⊥  < degree (φ a)):
       (degree (Σ  φ ) =  degree (φ a))  :=
begin
    let g := (χ_degree_strategy (finset.univ) φ a hyp hyp_not_nul),
    split_ifs at g, assumption,
    by_contradiction,
    exact  (h  (mem_univ  a)),
end

theorem my_theo (a b : with_bot ℕ  ) : a ≤ b → a+1 ≤ b+1 :=
begin
    intros,rcases  b,
        {
            intros, rcases a,
                {exact le_refl (none +1)},
                {erw  le_bot_iff at a_1, rw a_1, refine le_refl _}
        },
        {
            rcases a,
                {exact bot_le},
                {
                    apply  some_le_some.mpr,
                    apply add_le_add,
                        {apply some_le_some.mp a_1},
                        {exact le_refl 1}
                }
        },
end
#check with_bot.some_lt_some

lemma  zero_le_one' :  (0 : with_bot ℕ )  ≤ 1 :=
begin
            apply coe_le_coe.mpr,
            exact zero_le_one,
end

lemma prod_monic (s : finset A)(φ : A → polynomial R)  (hyp : ∀ a : A, monic (φ a)) :
                monic (finset.prod s  (λ x : A, φ x))  :=
 begin
    apply (finset.induction_on s), {
      erw prod_empty at  *,
      exact leading_coeff_C _,
    },
    {
        intros ℓ  s hyp' hyp_rec,
        rw finset.prod_insert (by assumption),
        apply monic_mul, exact hyp ℓ, exact hyp_rec,
    },
 end
/--
     For monic `φ : A → polynomial R)`
    `degree (∏ x in  s, φ x) =  ∑ x in s, degree (φ x)`
-/

lemma degree_prod_monic (s : finset A)(φ : A → polynomial R)
(hyp_lc : ∀ ℓ : A, monic (φ ℓ )) :
  degree (∏ x in  s, φ x) =  ∑ x in s, degree (φ x) :=
  begin
        apply (finset.induction_on s), {
          rw prod_empty,
          exact degree_C (one_ne_zero),
    },
    {
        intros ℓ  s hyp' hyp_rec,
        rw finset.prod_insert (by assumption),
        rw finset.sum_insert (by assumption),
        rw ← hyp_rec,
        apply degree_mul_eq',
        erw  monic.def.mp (hyp_lc ℓ), rw one_mul,
        erw  monic.def.mp (prod_monic s φ hyp_lc),
        exact one_ne_zero,
    },
  end

theorem cast_with_bot   (a  : ℕ ) :  nat.cast (a) = (a: with_bot ℕ ) := begin
    apply (nat.rec_on a),  {
        exact rfl,
    },
    intros ℓ  hyp_rec,
    change _ = ↑ℓ + ↑1,
    erw ← hyp_rec, exact rfl,
end
/--     For monic degree one polynomial `φ : A → polynomial R`
         `degree (∏ x in s,  φ x) =  card s`
-/
lemma prod_monic_one  (s : finset A)(φ : A → polynomial R)(hyp : ∀ ℓ : A, degree(φ ℓ ) = 1 )
(hyp_lc : ∀ ℓ : A, monic(φ ℓ) ) :   -- monic !
  degree (∏ x in s,  φ x) =  card s :=
 begin
    rw degree_prod_monic s φ  hyp_lc,
    conv_lhs{
        apply_congr, skip,
        rw hyp x,
    },
    rw finset.sum_const,  rw add_monoid.smul_one, unfold_coes, rw some_eq_coe, refine cast_with_bot  _ ,

end

/--     For  polynomial `φ : A → polynomial R`
            `degree (∏ x in s,  φ x) ≤   ∑ x in s, degree (φ x)`
-/
lemma degree_prod_le_sum_degree (s : finset A)(φ : A → polynomial R)  :
                degree (∏ x in s,  φ x) ≤  (∑ x in s, degree (φ x))
:=
 begin apply (finset.induction_on s), {
          rw prod_empty, rw sum_empty,
          rw degree_one, exact le_refl 0,
          },
        intros ℓ s hyp_ℓ hyp_rec,
        rw sum_insert (by assumption), rw prod_insert (by assumption),
        apply le_trans (degree_mul_le _ _),
        exact (add_le_add_left' (hyp_rec)),
 end

example (a b c d : ℕ ) : a ≤ b → c < d → a+c < b +d := begin
    intros, exact add_lt_add_of_le_of_lt a_1 a_2,
end

/--     For  `φ : A → with_bot ℕ ` s.t ` ∀ x, φ x ≤ 1`.
         ` ∑ x in s,  φ x  ≤  card s `
-/
theorem sum_le (s : finset A) (φ : A → (with_bot ℕ) ) (hyp : ∀ ℓ : A, φ ℓ ≤ 1)  :
        ∑ x in s,  φ x  ≤  card s :=
begin
    apply (finset.induction_on s), {
        rw sum_empty, rw card_empty, exact le_refl 0,
    },
    intros ℓ s hyp_l hyp_rec,
    rw sum_insert (by assumption), rw card_insert_of_not_mem(by assumption), rw coe_add, rw add_comm,
    apply add_le_add' hyp_rec (hyp ℓ ),
end
/--  for degree less one polynomial `φ : A → polynomial R`
    `degree ( ∏  x in s, φ x ) ≤ card s`
-/
lemma prod_degree_one_le_card (s : finset A)(φ : A → polynomial R) (hyp : ∀ ℓ : A, degree(φ ℓ ) ≤  1 ) :
    degree ( ∏  x in s, φ x ) ≤ card s :=
begin
        apply le_trans (degree_prod_le_sum_degree s φ),
        apply sum_le, exact hyp,
end

lemma le_add_compensation (a : ℕ) { b c d : with_bot ℕ} : (a : with_bot ℕ ) + c ≤  b +d  →  b ≤ a →  c ≤ d :=
begin
    intros hyp1 hyp2 ,
    have r : b+d ≤  a + d,
        exact add_le_add_right' hyp2,
    have : (a : with_bot ℕ ) + c ≤  a + d,
        apply le_trans (hyp1) (r),
    rcases c, exact bot_le,
    rcases d, erw le_bot_iff at this, trivial,
    rw ← some_eq_coe at  * ,
    erw ← coe_add at this, erw ← coe_add at this,
    let F := coe_le_coe.mp this,
    apply coe_le_coe.mpr,
    exact (add_le_add_iff_left a).mp F,
end
/-!
    The last technical lemma
-/
example (a b: ℕ ): a = b →  a ≤ b := begin
library_search,
end
lemma add_eq_bot (a : ℕ ) (b : with_bot ℕ ) : (a : with_bot ℕ ) + b = ⊥  →   b = ⊥  :=
begin
    cases b, intros,  rw none_eq_bot, intros, rw some_eq_coe at a_1, rw ← coe_add at a_1,  finish,
end
#check with_bot.
--by cases a; cases b; simp [none_eq_bot, some_eq_coe, coe_add.symm]
lemma ert (a b : ℕ) : (a = b ) → (a : with_bot ℕ ) = b := begin
  intros,exact congr_arg coe a_1,
end

lemma tre (a b : ℕ ) : (a : with_bot ℕ ) = b → a = b := begin
  intros,exact option.some_inj.mp a_1,
end
lemma left_cancel ( a : ℕ ) {b c : with_bot ℕ } : ↑a + b = a + c → b = c := begin
    intros,
    rcases b, rcases c, exact rfl, rw none_eq_bot  at a_1,
    rw add_bot at a_1, rw some_eq_coe at a_1, let g := (add_eq_bot a) c,
    let h :=  eq.symm a_1,
    specialize g h, trivial, rw some_eq_coe at a_1, rw ← coe_add at a_1,cases c, finish,
    rw some_eq_coe at a_1, rw ← coe_add at a_1, let k := tre (a+b) (a+c) a_1,
    rw some_eq_coe , rw some_eq_coe,
    apply ert,
    apply eq_of_add_eq_add_left k,
end
theorem proof_stra (a : ℕ) { b c d : ℕ} :   a ≤ c → b ≤ d →  (a+ b = c +d → (a=c ∧ b = d)) :=
begin
    intros,split, apply le_antisymm, assumption,
    apply (add_le_add_iff_left b).mp,
    conv_rhs {
        rw add_comm,
        rw a_3, rw add_comm,
    },
    apply (add_le_add_iff_right c).mpr , assumption,
    apply le_antisymm, assumption,
    apply (add_le_add_iff_left a).mp,
    conv_rhs  {
        rw a_3,
    },
    apply (add_le_add_iff_right d).mpr , assumption,
end

/--
        I use proof_strategy 2
-/
theorem q_card_insert_eq_card (s : finset A) (φ : A → (with_bot ℕ) )
(hyp : ∀ ℓ : A, φ ℓ ≤ 1) (ℓ0 ∉ s ):
 finset.sum (insert ℓ0 s)  φ = card (insert ℓ0 s) → finset.sum s  φ = card  s :=
 begin
     rw sum_insert(by assumption),
    rw card_insert_of_not_mem(by assumption), rw [coe_add, add_comm], intros  hyp_s,
    apply le_antisymm( sum_le s φ hyp),
    have pre_strat :  ↑1 + ↑(card s)   =   φ ℓ0 + finset.sum s (λ (x : A), φ x),
        rw add_comm, rw ← hyp_s, rw add_comm,
    apply  le_add_compensation 1 (le_of_eq (pre_strat)),
    exact (hyp ℓ0),
 end

/--
    `∑ x in s , φ x = φ a + ∑ x in erase s a, φ x `
-/
lemma sum_erase (s : finset A) (φ : A → with_bot ℕ )(a : A) (ha : a ∈ s) :
    ∑ x in s , φ x = φ a + ∑ x in erase s a, φ x  :=
begin
     -- rw ← insert_erase ha, -- here the rewrite change all
    conv_lhs {
        apply_congr,
        rw ← insert_erase ha, skip,
    },
    exact sum_insert (not_mem_erase _ _),
end
lemma card_insert_erase (s : finset A) (a : A) (ha : a ∈ s) : card ( s) = 1 + card (erase s a) :=
begin
    rw card_erase_of_mem ha, change card s = 1 + (card s -1),apply eq.symm ,
    apply @nat.add_sub_cancel'  (card s) 1, refine not_lt.mp _,intro,
    by_cases (card s)=0, let h :=card_eq_zero.mp h,
    have  g : s.nonempty ,
     use a,assumption,
     finish,
     have t := nat.pos_iff_ne_zero.mpr h,
     rw ← add_zero (1) at a_1,
    let j := nat.lt_one_add_iff.mp a_1,finish,
end

lemma  add_lt_add_of_lt_of_le ( γ   : ℕ ) (α β θ  : with_bot ℕ) (hyp : α  < θ )(hyp' :  β  ≤  γ ) :  α  + β  < θ  + γ  :=
begin
     cases θ, {
        cases α,
            {let t := lt_irrefl none, trivial},
            {by_contradiction, exact lt_asymm  hyp (bot_lt_some α)},
    },  cases α,
            {erw bot_add,erw ← coe_add, exact bot_lt_some _},
            cases β,
                {erw add_bot,  erw ← coe_add, exact bot_lt_some _},
                {
                    erw ← coe_add,erw ←  coe_add, erw  coe_lt_coe,
                    apply add_lt_add_of_lt_of_le,
                        {exact  coe_lt_coe.mp hyp},
                        {exact coe_le_coe.mp hyp'}
                },
end

/--
   For   polynomials `φ : A → polynomial R`
    ` ∃  ℓ0 : A, degree (φ ℓ0) < 1)`

    degree (finset.prod finset.univ  (λ x :A, φ x)) <  fintype.card A
-/
theorem degree_prod_le_one_lt_card (φ : A → polynomial R)
(hyp : ∀ ℓ : A, degree(φ ℓ ) ≤ 1 )
(hyp_lt_one : ∃  ℓ0 : A, degree (φ ℓ0) < 1) : degree ( ∏ ℓ :  A, φ ℓ ) < fintype.card A :=
begin
    rcases hyp_lt_one with ⟨ℓ0, hyp_l0 ⟩,
    apply lt_of_le_of_lt (degree_prod_le_sum_degree finset.univ φ ),
    rw sum_erase finset.univ _ ℓ0 ( (mem_univ ℓ0)),
    unfold fintype.card,
    erw card_insert_erase (univ ) ℓ0 (mem_univ ℓ0), rw coe_add,
    apply add_lt_add_of_lt_of_le,
        {exact hyp_l0},
        {exact  (sum_le (erase univ ℓ0) _ hyp ),},
end
#check bot_lt_some
end tools


/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import analysis.normed.group.hom
import analysis.normed_space.basic
import analysis.normed_space.linear_isometry
import algebra.star.self_adjoint
import algebra.star.unitary

/-!
# Normed star rings and algebras

A normed star group is a normed group with a compatible `star` which is isometric.

A C⋆-ring is a normed star group that is also a ring and that verifies the stronger
condition `∥x⋆ * x∥ = ∥x∥^2` for all `x`.  If a C⋆-ring is also a star algebra, then it is a
C⋆-algebra.

To get a C⋆-algebra `E` over field `𝕜`, use
`[normed_field 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [cstar_ring E]
 [normed_algebra 𝕜 E] [star_module 𝕜 E]`.

## TODO

- Show that `∥x⋆ * x∥ = ∥x∥^2` is equivalent to `∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥`, which is used as the
  definition of C*-algebras in some sources (e.g. Wikipedia).

-/

open_locale topological_space

local postfix `⋆`:std.prec.max_plus := star

/-- A normed star group is a normed group with a compatible `star` which is isometric. -/
class normed_star_group (E : Type*) [semi_normed_group E] [star_add_monoid E] : Prop :=
(norm_star : ∀ {x : E}, ∥x⋆∥ = ∥x∥)

export normed_star_group (norm_star)
attribute [simp] norm_star

variables {𝕜 E α : Type*}

section normed_star_group
variables [semi_normed_group E] [star_add_monoid E] [normed_star_group E]

/-- The `star` map in a normed star group is a normed group homomorphism. -/
def star_normed_group_hom : normed_group_hom E E :=
{ bound' := ⟨1, λ v, le_trans (norm_star.le) (one_mul _).symm.le⟩,
  .. star_add_equiv }

/-- The `star` map in a normed star group is an isometry -/
lemma star_isometry : isometry (star : E → E) :=
star_add_equiv.to_add_monoid_hom.isometry_of_norm (λ _, norm_star)

lemma continuous_star : continuous (star : E → E) := star_isometry.continuous

lemma continuous_on_star {s : set E} : continuous_on star s := continuous_star.continuous_on

lemma continuous_at_star {x : E} : continuous_at star x := continuous_star.continuous_at

lemma continuous_within_at_star {s : set E} {x : E} : continuous_within_at star s x :=
continuous_star.continuous_within_at

lemma tendsto_star (x : E) : filter.tendsto star (𝓝 x) (𝓝 x⋆) := continuous_star.tendsto x

lemma filter.tendsto.star {f : α → E} {l : filter α} {y : E} (h : filter.tendsto f l (𝓝 y)) :
  filter.tendsto (λ x, (f x)⋆) l (𝓝 y⋆) :=
(continuous_star.tendsto y).comp h

variables [topological_space α]

lemma continuous.star {f : α → E} (hf : continuous f) : continuous (λ y, star (f y)) :=
continuous_star.comp hf

lemma continuous_at.star {f : α → E} {x : α} (hf : continuous_at f x) :
  continuous_at (λ x, (f x)⋆) x :=
continuous_at_star.comp hf

lemma continuous_on.star {f : α → E} {s : set α} (hf : continuous_on f s) :
  continuous_on (λ x, (f x)⋆) s :=
continuous_star.comp_continuous_on hf

lemma continuous_within_at.star {f : α → E} {s : set α} {x : α}
  (hf : continuous_within_at f s x) : continuous_within_at (λ x, (f x)⋆) s x := hf.star

end normed_star_group

instance ring_hom_isometric.star_ring_end [normed_comm_ring E] [star_ring E]
  [normed_star_group E] : ring_hom_isometric (star_ring_end E) :=
⟨λ _, norm_star⟩

/-- A C*-ring is a normed star ring that satifies the stronger condition `∥x⋆ * x∥ = ∥x∥^2`
for every `x`. -/
class cstar_ring (E : Type*) [non_unital_normed_ring E] [star_ring E] : Prop :=
(norm_star_mul_self : ∀ {x : E}, ∥x⋆ * x∥ = ∥x∥ * ∥x∥)

instance : cstar_ring ℝ :=
{ norm_star_mul_self := λ x, by simp only [star, id.def, norm_mul] }

namespace cstar_ring
section non_unital

variables [non_unital_normed_ring E] [star_ring E] [cstar_ring E]

/-- In a C*-ring, star preserves the norm. -/
@[priority 100] -- see Note [lower instance priority]
instance to_normed_star_group : normed_star_group E :=
⟨begin
  intro x,
  by_cases htriv : x = 0,
  { simp only [htriv, star_zero] },
  { have hnt : 0 < ∥x∥ := norm_pos_iff.mpr htriv,
    have hnt_star : 0 < ∥x⋆∥ :=
      norm_pos_iff.mpr ((add_equiv.map_ne_zero_iff star_add_equiv).mpr htriv),
    have h₁ := calc
      ∥x∥ * ∥x∥ = ∥x⋆ * x∥        : norm_star_mul_self.symm
            ... ≤ ∥x⋆∥ * ∥x∥      : norm_mul_le _ _,
    have h₂ := calc
      ∥x⋆∥ * ∥x⋆∥ = ∥x * x⋆∥      : by rw [←norm_star_mul_self, star_star]
             ... ≤ ∥x∥ * ∥x⋆∥     : norm_mul_le _ _,
    exact le_antisymm (le_of_mul_le_mul_right h₂ hnt_star) (le_of_mul_le_mul_right h₁ hnt) },
end⟩

lemma norm_self_mul_star {x : E} : ∥x * x⋆∥ = ∥x∥ * ∥x∥ :=
by { nth_rewrite 0 [←star_star x], simp only [norm_star_mul_self, norm_star] }

lemma norm_star_mul_self' {x : E} : ∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥ :=
by rw [norm_star_mul_self, norm_star]

lemma nnnorm_star_mul_self {x : E} : ∥x⋆ * x∥₊ = ∥x∥₊ * ∥x∥₊ :=
subtype.ext norm_star_mul_self

end non_unital

section unital
variables [normed_ring E] [star_ring E] [cstar_ring E]

@[simp] lemma norm_one [nontrivial E] : ∥(1 : E)∥ = 1 :=
begin
  have : 0 < ∥(1 : E)∥ := norm_pos_iff.mpr one_ne_zero,
  rw [←mul_left_inj' this.ne', ←norm_star_mul_self, mul_one, star_one, one_mul],
end

@[priority 100] -- see Note [lower instance priority]
instance [nontrivial E] : norm_one_class E := ⟨norm_one⟩

lemma norm_coe_unitary [nontrivial E] (U : unitary E) : ∥(U : E)∥ = 1 :=
begin
  rw [←sq_eq_sq (norm_nonneg _) zero_le_one, one_pow 2, sq, ←cstar_ring.norm_star_mul_self,
    unitary.coe_star_mul_self, cstar_ring.norm_one],
end

@[simp] lemma norm_of_mem_unitary [nontrivial E] {U : E} (hU : U ∈ unitary E) : ∥U∥ = 1 :=
norm_coe_unitary ⟨U, hU⟩

@[simp] lemma norm_coe_unitary_mul (U : unitary E) (A : E) : ∥(U : E) * A∥ = ∥A∥ :=
begin
  nontriviality E,
  refine le_antisymm _ _,
  { calc _  ≤ ∥(U : E)∥ * ∥A∥     : norm_mul_le _ _
        ... = ∥A∥                 : by rw [norm_coe_unitary, one_mul] },
  { calc _ = ∥(U : E)⋆ * U * A∥         : by rw [unitary.coe_star_mul_self U, one_mul]
       ... ≤ ∥(U : E)⋆∥ * ∥(U : E) * A∥ : by { rw [mul_assoc], exact norm_mul_le _ _ }
       ... = ∥(U : E) * A∥              : by rw [norm_star, norm_coe_unitary, one_mul] },
end

@[simp] lemma norm_unitary_smul (U : unitary E) (A : E) : ∥U • A∥ = ∥A∥ :=
norm_coe_unitary_mul U A

lemma norm_mem_unitary_mul {U : E} (A : E) (hU : U ∈ unitary E) : ∥U * A∥ = ∥A∥ :=
norm_coe_unitary_mul ⟨U, hU⟩ A

@[simp] lemma norm_mul_coe_unitary (A : E) (U : unitary E) : ∥A * U∥ = ∥A∥ :=
calc _ = ∥((U : E)⋆ * A⋆)⋆∥ : by simp only [star_star, star_mul]
  ...  = ∥(U : E)⋆ * A⋆∥    : by rw [norm_star]
  ...  = ∥A⋆∥               : norm_mem_unitary_mul (star A) (unitary.star_mem U.prop)
  ...  = ∥A∥                : norm_star

lemma norm_mul_mem_unitary (A : E) {U : E} (hU : U ∈ unitary E) : ∥A * U∥ = ∥A∥ :=
norm_mul_coe_unitary A ⟨U, hU⟩

end unital
end cstar_ring

lemma nnnorm_pow_two_pow_of_self_adjoint [normed_ring E] [star_ring E] [cstar_ring E]
  {x : E} (hx : x ∈ self_adjoint E) (n : ℕ) : ∥x ^ 2 ^ n∥₊ = ∥x∥₊ ^ (2 ^ n) :=
begin
  induction n with k hk,
  { simp only [pow_zero, pow_one] },
  { rw [pow_succ, pow_mul', sq],
    nth_rewrite 0 ←(self_adjoint.mem_iff.mp hx),
    rw [←star_pow, cstar_ring.nnnorm_star_mul_self, ←sq, hk, pow_mul'] },
end

lemma self_adjoint.nnnorm_pow_two_pow [normed_ring E] [star_ring E] [cstar_ring E]
  (x : self_adjoint E) (n : ℕ) : ∥x ^ 2 ^ n∥₊ = ∥x∥₊ ^ (2 ^ n) :=
nnnorm_pow_two_pow_of_self_adjoint x.property _

section starₗᵢ

variables [comm_semiring 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [normed_star_group E]
variables [module 𝕜 E] [star_module 𝕜 E]

variables (𝕜)
/-- `star` bundled as a linear isometric equivalence -/
def starₗᵢ : E ≃ₗᵢ⋆[𝕜] E :=
{ map_smul' := star_smul,
  norm_map' := λ x, norm_star,
  .. star_add_equiv }

variables {𝕜}

@[simp] lemma coe_starₗᵢ : (starₗᵢ 𝕜 : E → E) = star := rfl

lemma starₗᵢ_apply {x : E} : starₗᵢ 𝕜 x = star x := rfl

end starₗᵢ


import sub_pq
import pq_to_group
import pq_induction_principles

universe u

section pq_group_subgroup

variables {Q : Type u} [power_quandle Q]

variables (Q1 : sub_power_quandle Q)

inductive is_from_sub_pq : pq_group Q → Prop
| incl (x : Q1) : is_from_sub_pq (of ↑x)
| mul (x y : pq_group Q) (hx : is_from_sub_pq x) (hy : is_from_sub_pq y) : is_from_sub_pq (x * y)

lemma one_mem_is_from_sub_pq : is_from_sub_pq Q1 1 :=
begin
  suffices : is_from_sub_pq Q1 (of ↑(1 : Q1)),
  {
    convert this,
    rw coe_one,
    rw of_one,
  },
  {
    exact is_from_sub_pq.incl 1,
  },
end

def pq_group_subgroup : subgroup (pq_group Q) := {
  carrier := is_from_sub_pq Q1,
  one_mem' := begin
    exact one_mem_is_from_sub_pq Q1,
  end,
  mul_mem' := begin
    exact is_from_sub_pq.mul,
  end,
  inv_mem' := begin
    intros x hx,
    induction hx with y,
    {
      rw of_inv,
      rw coe_pow,
      apply is_from_sub_pq.incl,
    },
    {
      simp only [mul_inv_rev],
      apply is_from_sub_pq.mul,
      assumption,
      assumption,
    },
  end }

--variables {X : Type*} [power_quandle X]

/-
def pq_group_subgroup_domain (f : Q1 → X) (hf : is_pq_morphism f) : pq_group_subgroup Q1 →* pq_group X :=
begin
  fconstructor,
  {
    intro x,

  },
  sorry,
  sorry,
end
-/

def pq_group_subgroup_inclusion : pq_group Q1 →* pq_group_subgroup Q1 :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    intro q,
    fconstructor,
    exact (of ↑q),
    apply is_from_sub_pq.incl,
  },
  {
    split,
    {
      intros a b,
      simp_rw ←coe_rhd,
      simp_rw ←rhd_of_eq_of_rhd,
      refl,
    },
    {
      intros a n,
      simp_rw ←coe_pow,
      simp_rw of_pow_eq_pow_of,
      ext1,
      simp only [subgroup.coe_gpow, subtype.coe_mk],
    }
  }
end

theorem pq_group_subgroup_inclusion_bijective : function.bijective (pq_group_subgroup_inclusion Q1) :=
begin
  split,
  {
    refine (pq_group_subgroup_inclusion Q1).injective_iff.mpr _,
    intros a ha,
    sorry,
  },
  {
    intro x,
    cases x with x hx,
    induction hx with y,
    {
      use (of y),
      refl,
    },
    {
      cases hx_ih_hx with a ha,
      cases hx_ih_hy with b hb,
      use a * b,
      simp only [monoid_hom.map_mul],
      rw ha,
      rw hb,
      refl,
    },
  },
end

end pq_group_subgroup


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales, Benjamin Davidson

! This file was ported from Lean 3 source module geometry.euclidean.sphere.power
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Euclidean.Angle.Unoriented.Affine
import Mathbin.Geometry.Euclidean.Sphere.Basic

/-!
# Power of a point (intersecting chords and secants)

This file proves basic geometrical results about power of a point (intersecting chords and
secants) in spheres in real inner product spaces and Euclidean affine spaces.

## Main theorems

* `mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi`: Intersecting Chords Theorem (Freek No. 55).
* `mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero`: Intersecting Secants Theorem.
-/

open Real

open EuclideanGeometry RealInnerProductSpace Real

variable {V : Type _} [NormedAddCommGroup V] [InnerProductSpace ℝ V]

namespace InnerProductGeometry

/-!
### Geometrical results on spheres in real inner product spaces

This section develops some results on spheres in real inner product spaces,
which are used to deduce corresponding results for Euclidean affine spaces.
-/

theorem mul_norm_eq_abs_sub_sq_norm {x y z : V} (h₁ : ∃ k : ℝ, k ≠ 1 ∧ x + y = k • (x - y))
    (h₂ : ‖z - y‖ = ‖z + y‖) : ‖x - y‖ * ‖x + y‖ = |‖z + y‖ ^ 2 - ‖z - x‖ ^ 2| :=
  by
  obtain ⟨k, hk_ne_one, hk⟩ := h₁
  let r := (k - 1)⁻¹ * (k + 1)
  have hxy : x = r • y :=
    by
    rw [← smul_smul, eq_inv_smul_iff₀ (sub_ne_zero.mpr hk_ne_one), ← sub_eq_zero]
    calc
      (k - 1) • x - (k + 1) • y = k • x - x - (k • y + y) := by
        simp_rw [sub_smul, add_smul, one_smul]
      _ = k • x - k • y - (x + y) := by simp_rw [← sub_sub, sub_right_comm]
      _ = k • (x - y) - (x + y) := by rw [← smul_sub k x y]
      _ = 0 := sub_eq_zero.mpr hk.symm

  have hzy : ⟪z, y⟫ = 0 := by
    rwa [inner_eq_zero_iff_angle_eq_pi_div_two, ← norm_add_eq_norm_sub_iff_angle_eq_pi_div_two,
      eq_comm]
  have hzx : ⟪z, x⟫ = 0 := by rw [hxy, inner_smul_right, hzy, MulZeroClass.mul_zero]
  calc
    ‖x - y‖ * ‖x + y‖ = ‖(r - 1) • y‖ * ‖(r + 1) • y‖ := by simp [sub_smul, add_smul, hxy]
    _ = ‖r - 1‖ * ‖y‖ * (‖r + 1‖ * ‖y‖) := by simp_rw [norm_smul]
    _ = ‖r - 1‖ * ‖r + 1‖ * ‖y‖ ^ 2 := by ring
    _ = |(r - 1) * (r + 1) * ‖y‖ ^ 2| := by simp [abs_mul]
    _ = |r ^ 2 * ‖y‖ ^ 2 - ‖y‖ ^ 2| := by ring_nf
    _ = |‖x‖ ^ 2 - ‖y‖ ^ 2| := by simp [hxy, norm_smul, mul_pow, sq_abs]
    _ = |‖z + y‖ ^ 2 - ‖z - x‖ ^ 2| := by
      simp [norm_add_sq_real, norm_sub_sq_real, hzy, hzx, abs_sub_comm]

#align inner_product_geometry.mul_norm_eq_abs_sub_sq_norm InnerProductGeometry.mul_norm_eq_abs_sub_sq_norm

end InnerProductGeometry

namespace EuclideanGeometry

/-!
### Geometrical results on spheres in Euclidean affine spaces

This section develops some results on spheres in Euclidean affine spaces.
-/

open InnerProductGeometry

variable {P : Type _} [MetricSpace P] [NormedAddTorsor V P]

include V

/-- If `P` is a point on the line `AB` and `Q` is equidistant from `A` and `B`, then
`AP * BP = abs (BQ ^ 2 - PQ ^ 2)`. -/
theorem mul_dist_eq_abs_sub_sq_dist {a b p q : P} (hp : ∃ k : ℝ, k ≠ 1 ∧ b -ᵥ p = k • (a -ᵥ p))
    (hq : dist a q = dist b q) : dist a p * dist b p = |dist b q ^ 2 - dist p q ^ 2| :=
  by
  let m : P := midpoint ℝ a b
  obtain ⟨v, h1, h2, h3⟩ := vsub_sub_vsub_cancel_left, v a p m, v p q m, v a q m
  have h : ∀ r, b -ᵥ r = m -ᵥ r + (m -ᵥ a) := fun r => by
    rw [midpoint_vsub_left, ← right_vsub_midpoint, add_comm, vsub_add_vsub_cancel]
  iterate 4 rw [dist_eq_norm_vsub V]
  rw [← h1, ← h2, h, h]
  rw [← h1, h] at hp
  rw [dist_eq_norm_vsub V a q, dist_eq_norm_vsub V b q, ← h3, h] at hq
  exact mul_norm_eq_abs_sub_sq_norm hp hq
#align euclidean_geometry.mul_dist_eq_abs_sub_sq_dist EuclideanGeometry.mul_dist_eq_abs_sub_sq_dist

/-- If `A`, `B`, `C`, `D` are cospherical and `P` is on both lines `AB` and `CD`, then
`AP * BP = CP * DP`. -/
theorem mul_dist_eq_mul_dist_of_cospherical {a b c d p : P} (h : Cospherical ({a, b, c, d} : Set P))
    (hapb : ∃ k₁ : ℝ, k₁ ≠ 1 ∧ b -ᵥ p = k₁ • (a -ᵥ p))
    (hcpd : ∃ k₂ : ℝ, k₂ ≠ 1 ∧ d -ᵥ p = k₂ • (c -ᵥ p)) :
    dist a p * dist b p = dist c p * dist d p :=
  by
  obtain ⟨q, r, h'⟩ := (cospherical_def {a, b, c, d}).mp h
  obtain ⟨ha, hb, hc, hd⟩ := h' a _, h' b _, h' c _, h' d _
  · rw [← hd] at hc
    rw [← hb] at ha
    rw [mul_dist_eq_abs_sub_sq_dist hapb ha, hb, mul_dist_eq_abs_sub_sq_dist hcpd hc, hd]
  all_goals simp
#align euclidean_geometry.mul_dist_eq_mul_dist_of_cospherical EuclideanGeometry.mul_dist_eq_mul_dist_of_cospherical

/-- **Intersecting Chords Theorem**. -/
theorem mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi {a b c d p : P}
    (h : Cospherical ({a, b, c, d} : Set P)) (hapb : ∠ a p b = π) (hcpd : ∠ c p d = π) :
    dist a p * dist b p = dist c p * dist d p :=
  by
  obtain ⟨-, k₁, _, hab⟩ := angle_eq_pi_iff.mp hapb
  obtain ⟨-, k₂, _, hcd⟩ := angle_eq_pi_iff.mp hcpd
  exact mul_dist_eq_mul_dist_of_cospherical h ⟨k₁, by linarith, hab⟩ ⟨k₂, by linarith, hcd⟩
#align euclidean_geometry.mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi EuclideanGeometry.mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_pi

/-- **Intersecting Secants Theorem**. -/
theorem mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero {a b c d p : P}
    (h : Cospherical ({a, b, c, d} : Set P)) (hab : a ≠ b) (hcd : c ≠ d) (hapb : ∠ a p b = 0)
    (hcpd : ∠ c p d = 0) : dist a p * dist b p = dist c p * dist d p :=
  by
  obtain ⟨-, k₁, -, hab₁⟩ := angle_eq_zero_iff.mp hapb
  obtain ⟨-, k₂, -, hcd₁⟩ := angle_eq_zero_iff.mp hcpd
  refine' mul_dist_eq_mul_dist_of_cospherical h ⟨k₁, _, hab₁⟩ ⟨k₂, _, hcd₁⟩ <;> by_contra hnot <;>
    simp_all only [Classical.not_not, one_smul]
  exacts[hab (vsub_left_cancel hab₁).symm, hcd (vsub_left_cancel hcd₁).symm]
#align euclidean_geometry.mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero EuclideanGeometry.mul_dist_eq_mul_dist_of_cospherical_of_angle_eq_zero

end EuclideanGeometry


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Thomas Browning
-/
import group_theory.group_action.basic
import group_theory.quotient_group

/-!
# Properties of group actions involving quotient groups

This file proves properties of group actions which use the quotient group construction, notably
* the orbit-stabilizer theorem `card_orbit_mul_card_stabilizer_eq_card_group`
* the class formula `card_eq_sum_card_group_div_card_stabilizer'`
* Burnside's lemma `sum_card_fixed_by_eq_card_orbits_mul_card_group`
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

open function
open_locale big_operators

namespace mul_action

variables [group α]

section quotient_action

open subgroup mul_opposite quotient_group

variables (β) [monoid β] [mul_action β α] (H : subgroup α)

/-- A typeclass for when a `mul_action β α` descends to the quotient `α ⧸ H`. -/
class quotient_action : Prop :=
(inv_mul_mem : ∀ (b : β) {a a' : α}, a⁻¹ * a' ∈ H → (b • a)⁻¹ * (b • a') ∈ H)

/-- A typeclass for when an `add_action β α` descends to the quotient `α ⧸ H`. -/
class _root_.add_action.quotient_action {α : Type*} (β : Type*) [add_group α] [add_monoid β]
  [add_action β α] (H : add_subgroup α) : Prop :=
(inv_mul_mem : ∀ (b : β) {a a' : α}, -a + a' ∈ H → -(b +ᵥ a) + (b +ᵥ a') ∈ H)

attribute [to_additive add_action.quotient_action] mul_action.quotient_action

@[to_additive] instance left_quotient_action : quotient_action α H :=
⟨λ _ _ _ _, by rwa [smul_eq_mul, smul_eq_mul, mul_inv_rev, mul_assoc, inv_mul_cancel_left]⟩

@[to_additive] instance right_quotient_action : quotient_action H.normalizer.opposite H :=
⟨λ b c _ _, by rwa [smul_def, smul_def, smul_eq_mul_unop, smul_eq_mul_unop, mul_inv_rev, ←mul_assoc,
  mem_normalizer_iff'.mp b.prop, mul_assoc, mul_inv_cancel_left]⟩

@[to_additive] instance right_quotient_action' [hH : H.normal] : quotient_action αᵐᵒᵖ H :=
⟨λ _ _ _ _, by rwa [smul_eq_mul_unop, smul_eq_mul_unop, mul_inv_rev, mul_assoc, hH.mem_comm_iff,
  mul_assoc, mul_inv_cancel_right]⟩

@[to_additive] instance quotient [quotient_action β H] : mul_action β (α ⧸ H) :=
{ smul := λ b, quotient.map' ((•) b) (λ a a' h, left_rel_apply.mpr $
    quotient_action.inv_mul_mem b $ left_rel_apply.mp h),
  one_smul := λ q, quotient.induction_on' q (λ a, congr_arg quotient.mk' (one_smul β a)),
  mul_smul := λ b b' q, quotient.induction_on' q (λ a, congr_arg quotient.mk' (mul_smul b b' a)) }

variables {β}

@[simp, to_additive] lemma quotient.smul_mk [quotient_action β H] (b : β) (a : α) :
  (b • quotient_group.mk a : α ⧸ H) = quotient_group.mk (b • a) := rfl

@[simp, to_additive] lemma quotient.smul_coe [quotient_action β H] (b : β) (a : α) :
  (b • a : α ⧸ H) = ↑(b • a) := rfl

@[simp, to_additive] lemma quotient.mk_smul_out' [quotient_action β H] (b : β) (q : α ⧸ H) :
  quotient_group.mk (b • q.out') = b • q :=
by rw [←quotient.smul_mk, quotient_group.out_eq']

@[simp, to_additive] lemma quotient.coe_smul_out' [quotient_action β H] (b : β) (q : α ⧸ H) :
  ↑(b • q.out') = b • q :=
quotient.mk_smul_out' H b q

end quotient_action

open quotient_group

/-- The canonical map to the left cosets. -/
def _root_.mul_action_hom.to_quotient (H : subgroup α) : α →[α] α ⧸ H :=
⟨coe, quotient.smul_coe H⟩

@[simp] lemma _root_.mul_action_hom.to_quotient_apply (H : subgroup α) (g : α) :
  mul_action_hom.to_quotient H g = g := rfl

@[to_additive] instance mul_left_cosets_comp_subtype_val (H I : subgroup α) :
  mul_action I (α ⧸ H) :=
mul_action.comp_hom (α ⧸ H) (subgroup.subtype I)

variables (α) {β} [mul_action α β] (x : β)

/-- The canonical map from the quotient of the stabilizer to the set. -/
@[to_additive "The canonical map from the quotient of the stabilizer to the set. "]
def of_quotient_stabilizer (g : α ⧸ (mul_action.stabilizer α x)) : β :=
quotient.lift_on' g (•x) $ λ g1 g2 H,
calc  g1 • x
    = g1 • (g1⁻¹ * g2) • x : congr_arg _ ((left_rel_apply.mp H).symm)
... = g2 • x : by rw [smul_smul, mul_inv_cancel_left]

@[simp, to_additive] theorem of_quotient_stabilizer_mk (g : α) :
  of_quotient_stabilizer α x (quotient_group.mk g) = g • x :=
rfl

@[to_additive] theorem of_quotient_stabilizer_mem_orbit (g) :
  of_quotient_stabilizer α x g ∈ orbit α x :=
quotient.induction_on' g $ λ g, ⟨g, rfl⟩

@[to_additive] theorem of_quotient_stabilizer_smul (g : α)
  (g' : α ⧸ (mul_action.stabilizer α x)) :
  of_quotient_stabilizer α x (g • g') = g • of_quotient_stabilizer α x g' :=
quotient.induction_on' g' $ λ _, mul_smul _ _ _

@[to_additive] theorem injective_of_quotient_stabilizer :
  function.injective (of_quotient_stabilizer α x) :=
λ y₁ y₂, quotient.induction_on₂' y₁ y₂ $ λ g₁ g₂ (H : g₁ • x = g₂ • x), quotient.sound' $
by { rw [left_rel_apply], show (g₁⁻¹ * g₂) • x = x, rw [mul_smul, ← H, inv_smul_smul] }

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
noncomputable def orbit_equiv_quotient_stabilizer (b : β) :
  orbit α b ≃ α ⧸ (stabilizer α b) :=
equiv.symm $ equiv.of_bijective
  (λ g, ⟨of_quotient_stabilizer α b g, of_quotient_stabilizer_mem_orbit α b g⟩)
  ⟨λ x y hxy, injective_of_quotient_stabilizer α b (by convert congr_arg subtype.val hxy),
  λ ⟨b, ⟨g, hgb⟩⟩, ⟨g, subtype.eq hgb⟩⟩

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
noncomputable def orbit_prod_stabilizer_equiv_group (b : β) :
  orbit α b × stabilizer α b ≃ α :=
(equiv.prod_congr (orbit_equiv_quotient_stabilizer α _) (equiv.refl _)).trans
subgroup.group_equiv_quotient_times_subgroup.symm

/-- Orbit-stabilizer theorem. -/
@[to_additive "Orbit-stabilizer theorem."]
lemma card_orbit_mul_card_stabilizer_eq_card_group (b : β) [fintype α] [fintype $ orbit α b]
  [fintype $ stabilizer α b] :
  fintype.card (orbit α b) * fintype.card (stabilizer α b) = fintype.card α :=
by rw [← fintype.card_prod, fintype.card_congr (orbit_prod_stabilizer_equiv_group α b)]

@[simp, to_additive] theorem orbit_equiv_quotient_stabilizer_symm_apply (b : β) (a : α) :
  ((orbit_equiv_quotient_stabilizer α b).symm a : β) = a • b :=
rfl

@[simp, to_additive] lemma stabilizer_quotient {G} [group G] (H : subgroup G) :
  mul_action.stabilizer G ((1 : G) : G ⧸ H) = H :=
by { ext, simp [quotient_group.eq] }

variable (β)

local notation `Ω` := (quotient $ orbit_rel α β)

/-- **Class formula** : given `G` a group acting on `X` and `φ` a function mapping each orbit of `X`
under this action (that is, each element of the quotient of `X` by the relation `orbit_rel G X`) to
an element in this orbit, this gives a (noncomputable) bijection between `X` and the disjoint union
of `G/Stab(φ(ω))` over all orbits `ω`. In most cases you'll want `φ` to be `quotient.out'`, so we
provide `mul_action.self_equiv_sigma_orbits_quotient_stabilizer` as a special case. -/
@[to_additive "**Class formula** : given `G` an additive group acting on `X` and `φ` a function
mapping each orbit of `X` under this action (that is, each element of the quotient of `X` by the
relation `orbit_rel G X`) to an element in this orbit, this gives a (noncomputable) bijection
between `X` and the disjoint union of `G/Stab(φ(ω))` over all orbits `ω`. In most cases you'll want
`φ` to be `quotient.out'`, so we provide `add_action.self_equiv_sigma_orbits_quotient_stabilizer`
as a special case. "]
noncomputable def self_equiv_sigma_orbits_quotient_stabilizer' {φ : Ω → β}
  (hφ : left_inverse quotient.mk' φ) : β ≃ Σ (ω : Ω), α ⧸ (stabilizer α (φ ω)) :=
calc  β
    ≃ Σ (ω : Ω), orbit α (φ ω) : self_equiv_sigma_orbits' α β hφ
... ≃ Σ (ω : Ω), α ⧸ (stabilizer α (φ ω)) :
        equiv.sigma_congr_right (λ ω, orbit_equiv_quotient_stabilizer α (φ ω))

/-- **Class formula** for a finite group acting on a finite type. See
`mul_action.card_eq_sum_card_group_div_card_stabilizer` for a specialized version using
`quotient.out'`. -/
@[to_additive "**Class formula** for a finite group acting on a finite type. See
`add_action.card_eq_sum_card_add_group_div_card_stabilizer` for a specialized version using
`quotient.out'`."]
lemma card_eq_sum_card_group_div_card_stabilizer' [fintype α] [fintype β] [fintype Ω]
  [Π (b : β), fintype $ stabilizer α b] {φ : Ω → β} (hφ : left_inverse quotient.mk' φ) :
  fintype.card β = ∑ (ω : Ω), fintype.card α / fintype.card (stabilizer α (φ ω)) :=
begin
  classical,
  have : ∀ ω : Ω, fintype.card α / fintype.card ↥(stabilizer α (φ ω)) =
    fintype.card (α ⧸ stabilizer α (φ ω)),
  { intro ω,
    rw [fintype.card_congr (@subgroup.group_equiv_quotient_times_subgroup α _ (stabilizer α $ φ ω)),
        fintype.card_prod, nat.mul_div_cancel],
    exact fintype.card_pos_iff.mpr (by apply_instance) },
  simp_rw [this, ← fintype.card_sigma, fintype.card_congr
            (self_equiv_sigma_orbits_quotient_stabilizer' α β hφ)],
end

/-- **Class formula**. This is a special case of
`mul_action.self_equiv_sigma_orbits_quotient_stabilizer'` with `φ = quotient.out'`. -/
@[to_additive "**Class formula**. This is a special case of
`add_action.self_equiv_sigma_orbits_quotient_stabilizer'` with `φ = quotient.out'`. "]
noncomputable def self_equiv_sigma_orbits_quotient_stabilizer :
  β ≃ Σ (ω : Ω), α ⧸ (stabilizer α ω.out') :=
self_equiv_sigma_orbits_quotient_stabilizer' α β quotient.out_eq'

/-- **Class formula** for a finite group acting on a finite type. -/
@[to_additive "**Class formula** for a finite group acting on a finite type."]
lemma card_eq_sum_card_group_div_card_stabilizer [fintype α] [fintype β] [fintype Ω]
  [Π (b : β), fintype $ stabilizer α b] :
  fintype.card β = ∑ (ω : Ω), fintype.card α / fintype.card (stabilizer α ω.out') :=
card_eq_sum_card_group_div_card_stabilizer' α β quotient.out_eq'

/-- **Burnside's lemma** : a (noncomputable) bijection between the disjoint union of all
`{x ∈ X | g • x = x}` for `g ∈ G` and the product `G × X/G`, where `G` is a group acting on `X` and
`X/G`denotes the quotient of `X` by the relation `orbit_rel G X`. -/
@[to_additive "**Burnside's lemma** : a (noncomputable) bijection between the disjoint union of all
`{x ∈ X | g • x = x}` for `g ∈ G` and the product `G × X/G`, where `G` is an additive group acting
on `X` and `X/G`denotes the quotient of `X` by the relation `orbit_rel G X`. "]
noncomputable def sigma_fixed_by_equiv_orbits_prod_group :
  (Σ (a : α), (fixed_by α β a)) ≃ Ω × α :=
calc  (Σ (a : α), fixed_by α β a)
    ≃ {ab : α × β // ab.1 • ab.2 = ab.2} :
        (equiv.subtype_prod_equiv_sigma_subtype _).symm
... ≃ {ba : β × α // ba.2 • ba.1 = ba.1} :
        (equiv.prod_comm α β).subtype_equiv (λ ab, iff.rfl)
... ≃ Σ (b : β), stabilizer α b :
        equiv.subtype_prod_equiv_sigma_subtype (λ (b : β) a, a ∈ stabilizer α b)
... ≃ Σ (ωb : (Σ (ω : Ω), orbit α ω.out')), stabilizer α (ωb.2 : β) :
        (self_equiv_sigma_orbits α β).sigma_congr_left'
... ≃ Σ (ω : Ω), (Σ (b : orbit α ω.out'), stabilizer α (b : β)) :
        equiv.sigma_assoc (λ (ω : Ω) (b : orbit α ω.out'), stabilizer α (b : β))
... ≃ Σ (ω : Ω), (Σ (b : orbit α ω.out'), stabilizer α ω.out') :
        equiv.sigma_congr_right (λ ω, equiv.sigma_congr_right $
          λ ⟨b, hb⟩, (stabilizer_equiv_stabilizer_of_orbit_rel hb).to_equiv)
... ≃ Σ (ω : Ω), orbit α ω.out' × stabilizer α ω.out' :
        equiv.sigma_congr_right (λ ω, equiv.sigma_equiv_prod _ _)
... ≃ Σ (ω : Ω), α :
        equiv.sigma_congr_right (λ ω, orbit_prod_stabilizer_equiv_group α ω.out')
... ≃ Ω × α :
        equiv.sigma_equiv_prod Ω α

/-- **Burnside's lemma** : given a finite group `G` acting on a set `X`, the average number of
elements fixed by each `g ∈ G` is the number of orbits. -/
@[to_additive "**Burnside's lemma** : given a finite additive group `G` acting on a set `X`,
the average number of elements fixed by each `g ∈ G` is the number of orbits. "]
lemma sum_card_fixed_by_eq_card_orbits_mul_card_group [fintype α] [Π a, fintype $ fixed_by α β a]
  [fintype Ω] :
  ∑ (a : α), fintype.card (fixed_by α β a) = fintype.card Ω * fintype.card α :=
by rw [← fintype.card_prod, ← fintype.card_sigma,
        fintype.card_congr (sigma_fixed_by_equiv_orbits_prod_group α β)]

@[to_additive] instance is_pretransitive_quotient (G) [group G] (H : subgroup G) :
  is_pretransitive G (G ⧸ H) :=
{ exists_smul_eq := begin
    rintros ⟨x⟩ ⟨y⟩,
    refine ⟨y * x⁻¹, quotient_group.eq.mpr _⟩,
    simp only [smul_eq_mul, H.one_mem, mul_left_inv, inv_mul_cancel_right],
  end }

end mul_action

namespace subgroup

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

lemma normal_core_eq_ker :
  H.normal_core = (mul_action.to_perm_hom G (G ⧸ H)).ker :=
begin
  refine le_antisymm (λ g hg, equiv.perm.ext (λ q, quotient_group.induction_on q
    (λ g', (mul_action.quotient.smul_mk H g g').trans (quotient_group.eq.mpr _))))
    (subgroup.normal_le_normal_core.mpr (λ g hg, _)),
  { rw [smul_eq_mul, mul_inv_rev, ←inv_inv g', inv_inv],
    exact H.normal_core.inv_mem hg g'⁻¹ },
  { rw [←H.inv_mem_iff, ←mul_one g⁻¹, ←quotient_group.eq, ←mul_one g],
    exact (mul_action.quotient.smul_mk H g 1).symm.trans (equiv.perm.ext_iff.mp hg (1 : G)) },
end

noncomputable instance fintype_quotient_normal_core [fintype (G ⧸ H)] :
  fintype (G ⧸ H.normal_core) :=
begin
  rw H.normal_core_eq_ker,
  classical,
  exact fintype.of_equiv _ (quotient_group.quotient_ker_equiv_range _).symm.to_equiv,
end

end subgroup


import data.equiv.algebra
import group_theory.quotient_group

-- Some stuff is now in mathlib

namespace quotient_group

theorem map_id {G : Type*} [group G] (K : set G) [normal_subgroup K] (g : quotient K) :
map K K id (λ x h, h) g = g := by induction g; refl

theorem map_comp
  {G : Type*} {H : Type*} {J : Type*}
  [group G] [group H] [group J]
  (a : G → H) [is_group_hom a] (b : H → J) [is_group_hom b]
  {G1 : set G} {H1 : set H} {J1 : set J}
  [normal_subgroup G1] [normal_subgroup H1] [normal_subgroup J1]
  (h1 : G1 ⊆ a ⁻¹' H1) (h2 : H1 ⊆ b ⁻¹' J1)
  (g : quotient G1) :
map H1 J1 b h2 (map G1 H1 a h1 g) = map G1 J1 (b ∘ a) (λ _ hx, h2 $ h1 hx) g :=
by induction g; refl

end quotient_group

open quotient_group

-- This version is better (than a previous, deleted version),
-- but Mario points out that really I shuold be using a
-- relation rather than h2 : he.to_equiv ⁻¹' K = J.
def mul_equiv.quotient {G : Type*} {H : Type*} [group G] [group H]
  (he : G ≃* H) (J : set G) [normal_subgroup J] (K : set H) [normal_subgroup K]
  (h2 : he.to_equiv ⁻¹' K = J) :
mul_equiv (quotient_group.quotient J) (quotient_group.quotient K) :=
{ to_fun := quotient_group.lift J (mk ∘ he) begin
    unfold set.preimage at h2,
    intros g hg,
    rw ←h2 at hg,
    rw ←is_group_hom.mem_ker (quotient_group.mk : H → quotient_group.quotient K),
    rwa quotient_group.ker_mk,
  end,
  inv_fun := quotient_group.lift K (mk ∘ he.symm) begin
    intros h hh,
    rw ←is_group_hom.mem_ker (quotient_group.mk : G → quotient_group.quotient J),
    rw quotient_group.ker_mk,
    show he.to_equiv.symm h ∈ J,
    rw ←h2,
    show he.to_equiv (he.to_equiv.symm h) ∈ K,
    convert hh,
    exact he.to_equiv.right_inv h
  end,
  left_inv := λ g, begin
    induction g,
    conv begin
      to_rhs,
      rw ←he.to_equiv.left_inv g,
    end,
    refl, refl,
    end,
  right_inv := λ h, begin
    induction h,
    conv begin
      to_rhs,
      rw ←he.to_equiv.right_inv h,
    end,
    refl, refl,
  end,
  map_mul' := (quotient_group.is_group_hom_quotient_lift J _ _).map_mul }


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

import number_theory.cyclotomic.primitive_roots
import ring_theory.discriminant

/-!
# Discriminant of cyclotomic fields
We compute the discriminant of a `p ^ n`-th cyclotomic extension.

## Main results
* `is_cyclotomic_extension.discr_odd_prime` : if `p` is an odd prime such that
  `is_cyclotomic_extension {p} K L` and `irreducible (cyclotomic p K)`, then
  `discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` for any
  `hζ : is_primitive_root ζ p`.

-/

universes u v

open algebra polynomial nat is_primitive_root power_basis

open_locale polynomial cyclotomic

namespace is_primitive_root

variables {n : ℕ+} {K : Type u} [field K] [char_zero K] {ζ : K}
variables [is_cyclotomic_extension {n} ℚ K]

/-- The discriminant of the power basis given by a primitive root of unity `ζ` is the same as the
discriminant of the power basis given by `ζ - 1`. -/
lemma discr_zeta_eq_discr_zeta_sub_one (hζ : is_primitive_root ζ n) :
  discr ℚ (hζ.power_basis ℚ).basis = discr ℚ (hζ.sub_one_power_basis ℚ).basis :=
begin
  haveI : number_field K := number_field.mk,
  have H₁ : (aeval (hζ.power_basis ℚ).gen) (X - 1 : ℤ[X]) = (hζ.sub_one_power_basis ℚ).gen :=
    by simp,
  have H₂ : (aeval (hζ.sub_one_power_basis ℚ).gen) (X + 1 : ℤ[X]) = (hζ.power_basis ℚ).gen :=
    by simp,
  refine discr_eq_discr_of_to_matrix_coeff_is_integral _
    (λ i j, to_matrix_is_integral H₁ _ _ _ _)
    (λ i j, to_matrix_is_integral H₂ _ _ _ _),
  { exact hζ.is_integral n.pos },
  { refine minpoly.gcd_domain_eq_field_fractions' _ (hζ.is_integral n.pos) },
  { exact is_integral_sub (hζ.is_integral n.pos) is_integral_one },
  { refine minpoly.gcd_domain_eq_field_fractions' _ _,
    exact is_integral_sub (hζ.is_integral n.pos) is_integral_one }
end

end is_primitive_root

namespace is_cyclotomic_extension

variables {p : ℕ+} {k : ℕ} {K : Type u} {L : Type v} {ζ : L} [field K] [field L]
variables [algebra K L]

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ (k + 1).totient) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ (k + 1) : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
begin
  haveI hne := is_cyclotomic_extension.ne_zero' (p ^ (k + 1)) K L,
  have hp2 : p = 2 → 1 ≤ k,
  { intro hp,
    refine one_le_iff_ne_zero.2 (λ h, _),
    rw [h, hp, zero_add, pow_one] at hk,
    exact hk rfl },

  rw [discr_power_basis_eq_norm, finrank _ hirr, hζ.power_basis_gen _,
    ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, pnat.pow_coe, totient_prime_pow hp.out
    (succ_pos k)],
  congr' 1,
  { by_cases hptwo : p = 2,
    { obtain ⟨k₁, hk₁⟩ := nat.exists_eq_succ_of_ne_zero (one_le_iff_ne_zero.1 (hp2 hptwo)),
      rw [hk₁, succ_sub_one, hptwo, pnat.coe_bit0, pnat.one_coe, succ_sub_succ_eq_sub, tsub_zero,
        mul_one, pow_succ, mul_assoc, nat.mul_div_cancel_left _ zero_lt_two,
        nat.mul_div_cancel_left _ zero_lt_two],
      by_cases hk₁zero : k₁ = 0,
      { simp [hk₁zero] },
      obtain ⟨k₂, rfl⟩ := nat.exists_eq_succ_of_ne_zero hk₁zero,
      rw [pow_succ, mul_assoc, pow_mul (-1 : K), pow_mul (-1 : K), neg_one_sq, one_pow, one_pow] },
    { simp only [succ_sub_succ_eq_sub, tsub_zero],
      replace hptwo : ↑p ≠ 2,
      { intro h,
        rw [← pnat.one_coe, ← pnat.coe_bit0, pnat.coe_inj] at h,
        exact hptwo h },
      obtain ⟨a, ha⟩ := even_sub_one_of_prime_ne_two hp.out hptwo,
      rw [mul_comm ((p : ℕ) ^ k), mul_assoc, ha],
      nth_rewrite 0 [← mul_one a],
      nth_rewrite 4 [← mul_one a],
      rw [← nat.mul_succ, mul_comm a, mul_assoc, mul_assoc 2, nat.mul_div_cancel_left _
        zero_lt_two, nat.mul_div_cancel_left _ zero_lt_two, ← mul_assoc, mul_comm
        (a * (p : ℕ) ^ k), pow_mul, ← ha],
      congr' 1,
      refine odd.neg_one_pow (nat.even.sub_odd (nat.succ_le_iff.2 (mul_pos (tsub_pos_iff_lt.2
        hp.out.one_lt) (pow_pos hp.out.pos _))) (even.mul_right (nat.even_sub_one_of_prime_ne_two
        hp.out hptwo) _) odd_one) } },
  { have H := congr_arg derivative (cyclotomic_prime_pow_mul_X_pow_sub_one K p k),
    rw [derivative_mul, derivative_sub, derivative_one, sub_zero, derivative_pow,
      derivative_X, mul_one, derivative_sub, derivative_one, sub_zero, derivative_pow,
      derivative_X, mul_one, ← pnat.pow_coe, hζ.minpoly_eq_cyclotomic_of_irreducible hirr] at H,
    replace H := congr_arg (λ P, aeval ζ P) H,
    simp only [aeval_add, aeval_mul, minpoly.aeval, zero_mul, add_zero, aeval_nat_cast,
      _root_.map_sub, aeval_one, aeval_X_pow] at H,
    replace H := congr_arg (algebra.norm K) H,
    have hnorm : (norm K) (ζ ^ (p : ℕ) ^ k - 1) = p ^ ((p : ℕ) ^ k),
    { by_cases hp : p = 2,
      { exact hζ.pow_sub_one_norm_prime_pow_of_one_le hirr rfl.le (hp2 hp) },
      { exact hζ.pow_sub_one_norm_prime_ne_two hirr rfl.le hp } },
    rw [monoid_hom.map_mul, hnorm, monoid_hom.map_mul, ← map_nat_cast (algebra_map K L),
      algebra.norm_algebra_map, finrank _ hirr, pnat.pow_coe, totient_prime_pow hp.out (succ_pos k),
      nat.sub_one, nat.pred_succ, ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, map_pow,
      hζ.norm_eq_one hk hirr, one_pow, mul_one, cast_pow, ← coe_coe, ← pow_mul, ← mul_assoc,
      mul_comm (k + 1), mul_assoc] at H,
    { have := mul_pos (succ_pos k) (tsub_pos_iff_lt.2 hp.out.one_lt),
      rw [← succ_pred_eq_of_pos this, mul_succ, pow_add _ _ ((p : ℕ) ^ k)] at H,
      replace H := (mul_left_inj' (λ h, _)).1 H,
      { simpa only [← pnat.pow_coe, H, mul_comm _ (k + 1)] },
      { replace h := pow_eq_zero h,
        rw [coe_coe] at h,
        simpa using hne.1 } },
    all_goals { apply_instance } },
  all_goals { apply_instance }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ (p ^ k * (p - 1) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two' [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p : ℕ) ^ k  * (p - 1)) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
by simpa [totient_prime_pow hp.out (succ_pos k)] using discr_prime_pow_ne_two hζ hirr hk

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ k).totient / 2) * p ^ (p ^ (k - 1) * ((p - 1) * k - 1))`
if `irreducible (cyclotomic (p ^ k) K))`. Beware that in the cases `p ^ k = 1` and `p ^ k = 2`
the formula uses `1 / 2 = 0` and `0 - 1 = 0`. It is useful only to have a uniform result.
See also `is_cyclotomic_extension.discr_prime_pow_eq_unit_mul_pow`. -/
lemma discr_prime_pow [hcycl : is_cyclotomic_extension {p ^ k} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ k)) (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ k : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ (k - 1) * ((p - 1) * k - 1)) :=
begin
  unfreezingI { cases k },
  { simp only [coe_basis, pow_zero, power_basis_gen, totient_one, mul_zero, mul_one, show 1 / 2 = 0,
      by refl, discr, trace_matrix],
    have hζone : ζ = 1 := by simpa using hζ,
    rw [hζ.power_basis_dim _, hζone, ← (algebra_map K L).map_one,
      minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective, nat_degree_X_sub_C],
    simp only [trace_matrix, map_one, one_pow, matrix.det_unique, trace_form_apply, mul_one],
    rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr],
    { simp },
    { apply_instance },
    { exact hcycl } },
  { by_cases hk : p ^ (k + 1) = 2,
    { have hp : p = 2,
      { rw [← pnat.coe_inj, pnat.coe_bit0, pnat.one_coe, pnat.pow_coe, ← pow_one 2] at hk,
      replace hk := eq_of_prime_pow_eq (prime_iff.1 hp.out) (prime_iff.1 nat.prime_two)
        (succ_pos _) hk,
      rwa [show 2 = ((2 : ℕ+) : ℕ), by simp, pnat.coe_inj] at hk },
      rw [hp, ← pnat.coe_inj, pnat.pow_coe, pnat.coe_bit0, pnat.one_coe] at hk,
      nth_rewrite 1 [← pow_one 2] at hk,
      replace hk := nat.pow_right_injective rfl.le hk,
      rw [add_left_eq_self] at hk,
      simp only [hp, hk, pow_one, pnat.coe_bit0, pnat.one_coe] at hζ,
      simp only [hp, hk, show 1 / 2 = 0, by refl, coe_basis, pow_one, power_basis_gen,
        pnat.coe_bit0, pnat.one_coe, totient_two, pow_zero, mul_one, mul_zero],
      rw [power_basis_dim, hζ.eq_neg_one_of_two_right, show (-1 : L) = algebra_map K L (-1),
        by simp, minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective,
        nat_degree_X_sub_C],
      simp only [discr, trace_matrix, matrix.det_unique, fin.default_eq_zero, fin.coe_zero,
        pow_zero, trace_form_apply, mul_one],
      rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr, hp, hk],
      { simp },
      { apply_instance },
      { exact hcycl } },
    { exact discr_prime_pow_ne_two hζ hirr hk } }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then there are `u : ℤˣ` and
`n : ℕ` such that the discriminant of `hζ.power_basis K` is `u * p ^ n`. Often this is enough and
less cumbersome to use than `is_cyclotomic_extension.discr_prime_pow`. -/
lemma discr_prime_pow_eq_unit_mul_pow [is_cyclotomic_extension {p ^ k} K L]
  [hp : fact (p : ℕ).prime] (hζ : is_primitive_root ζ ↑(p ^ k))
  (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  ∃ (u : ℤˣ) (n : ℕ), discr K (hζ.power_basis K).basis = u * p ^ n :=
begin
  rw [discr_prime_pow hζ hirr],
  by_cases heven : even (((p ^ k : ℕ).totient) / 2),
  { refine ⟨1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1), by simp [heven.neg_one_pow]⟩ },
  { exact ⟨-1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1),
      by simp [(odd_iff_not_even.2 heven).neg_one_pow]⟩ },
end

/-- If `p` is an odd prime and `is_cyclotomic_extension {p} K L`, then
`discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` if
`irreducible (cyclotomic p K)`. -/
lemma discr_odd_prime [is_cyclotomic_extension {p} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ p) (hirr : irreducible (cyclotomic p K)) (hodd : p ≠ 2) :
  discr K (hζ.power_basis K).basis = (-1) ^ (((p : ℕ) - 1) / 2) * p ^ ((p : ℕ) - 2) :=
begin
  haveI : is_cyclotomic_extension {p ^ (0 + 1)} K L,
  { rw [zero_add, pow_one],
    apply_instance },
  have hζ' : is_primitive_root ζ ↑(p ^ (0 + 1)) := by simpa using hζ,
  convert discr_prime_pow_ne_two hζ' (by simpa [hirr]) (by simp [hodd]),
  { rw [zero_add, pow_one, totient_prime hp.out] },
  { rw [pow_zero, one_mul, zero_add, mul_one, nat.sub_sub] }
end

end is_cyclotomic_extension


import .group_representation
import .morphism
import ring_theory.algebra
open algebra
open linear_map
universe variables u v w
variables {G : Type u}[group G]   {R : Type v}[comm_ring R] {M : Type w}
[add_comm_group M] [module R M]
namespace homothetic
variables  (ρ : group_representation G R M)

open morphism
/-
  Make an R algebra ? subalgebra of sub.type ! To check
-/

def add ( f g : ρ ⟶ ρ ) : ρ ⟶  ρ  := {
    ℓ := f.ℓ +g.ℓ,
    commute := begin intros k,
        ext,simp,
        erw commute_apply,erw commute_apply ρ,  exact rfl,
     end
}
def spectral (t : R)(f  :  ρ ⟶ ρ)   :  ρ ⟶ ρ  := { ℓ := t • f.ℓ,
  commute := begin
        intros g,ext,simp, erw commute_apply, exact rfl,
  end }

instance has_add_morphism : has_add ( ρ ⟶ ρ ) := { add := add ρ  }
instance has_scalar_morphism: has_scalar R ( ρ ⟶ ρ ) := { smul := spectral ρ  }
def id  :=  𝟙 ρ
lemma add_ext ( f g : ρ ⟶ ρ ) : (f+g).ℓ = f.ℓ + g.ℓ := rfl
lemma one_ext : (𝟙 ρ ).ℓ =linear_map.id :=rfl
lemma smul_ext (t : R)(f  :  ρ ⟶ ρ) : (t • f).ℓ  = t • f.ℓ := rfl
def test (t : R)(f  : ρ ⟶ ρ) := f + t • 𝟙 ρ

end homothetic
#check  mul_sub_left_distrib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.basic
import Mathlib.order.rel_iso
import Mathlib.logic.function.iterate
import Mathlib.PostPort

universes u_1

namespace Mathlib

namespace rel_embedding

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def nat_lt {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] (f : ℕ → α) (H : ∀ (n : ℕ), r (f n) (f (n + 1))) : Less ↪r r :=
  of_monotone f sorry

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def nat_gt {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] (f : ℕ → α) (H : ∀ (n : ℕ), r (f (n + 1)) (f n)) : gt ↪r r :=
  rel_embedding.swap (nat_lt f H)

theorem well_founded_iff_no_descending_seq {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] : well_founded r ↔ ¬Nonempty (gt ↪r r) := sorry


import analysis.inner_product_space.basic
import algebra.algebra.bilinear
import to_mathlib.linear_algebra.tensor_power
import linear_algebra.finite_dimensional
import analysis.inner_product_space.gram_schmidt_ortho

noncomputable theory

open set function
open_locale real_inner_product_space tensor_product big_operators

namespace inner_product_space

lemma sum_tensor_sum {α β H I : Type*}
  [add_comm_monoid H] [add_comm_monoid I] [module ℝ H] [module ℝ I]
  (s : finset α) (t : finset β)
  (f : α → H) (g : β → I) :
  (∑ a in s, f a) ⊗ₜ[ℝ] (∑ b in t, g b) =
  (∑ x in finset.product s t, (f x.1) ⊗ₜ[ℝ] (g x.2)) :=
begin
  classical,
  induction s using finset.induction_on with a s' ha ih,
  { rw [finset.sum_empty, tensor_product.zero_tmul, finset.empty_product,
      finset.sum_empty], },
  { rw [finset.sum_insert, tensor_product.add_tmul, ih],
    have : ∑ (x : α × β) in insert a s' ×ˢ t, f x.fst ⊗ₜ[ℝ] g x.snd =
      ∑ (x : α × β) in (s' ×ˢ t) ∪ ({a} ×ˢ t), f x.fst ⊗ₜ g x.snd,
    { apply finset.sum_bij',
      work_on_goal 4
      { refine λ x hx, x, },
      work_on_goal 5
      { refine λ x hx, x, },
      { rintros ⟨a, b⟩ h, refl, },
      { rintros ⟨a, b⟩ h, refl, },
      { rintros ⟨a, b⟩ h, refl, },
      { rintros ⟨a, b⟩ h,
        simp only [finset.singleton_product, finset.mem_union, finset.mem_product, finset.mem_map,
          embedding.coe_fn_mk, prod.mk.inj_iff, exists_prop, exists_eq_right_right,
          finset.mem_insert] at h ⊢,
        tauto, },
      { rintros ⟨a, b⟩ h,
        simp only [finset.mem_product, finset.mem_insert, finset.singleton_product,
          finset.mem_union, finset.mem_map, embedding.coe_fn_mk, prod.mk.inj_iff, exists_prop,
          exists_eq_right_right] at h ⊢,
        tauto, }, },
    rw [this, finset.sum_union, finset.singleton_product, add_comm],
    congr' 1,
    rw [finset.sum_map, tensor_product.tmul_sum], refl,
    { rw finset.disjoint_iff_inter_eq_empty,
      rw finset.eq_empty_iff_forall_not_mem,
      rintros ⟨a', b'⟩ r,
      simp only [finset.singleton_product, finset.mem_inter, finset.mem_product, finset.mem_map,
        embedding.coe_fn_mk, prod.mk.inj_iff, exists_prop, exists_eq_right_right] at r,
      rcases r with ⟨⟨ha', _⟩, _, rfl⟩,
      exact ha ha', },
    assumption },
end

variables (E F : Type*) [inner_product_space ℝ E] [inner_product_space ℝ F]

/-- We can regard the bilinear form of a real inner product space as a linear map on the tensor
square. -/
def as_tensor : E ⊗[ℝ] E →ₗ[ℝ] ℝ :=
tensor_product.lift bilin_form_of_real_inner.to_lin

/-- An auxiliary definition used to help construct the `inner_product_space` on the binary tensor
product below. -/
def tensor_product_aux : (E ⊗[ℝ] F) ⊗[ℝ] (E ⊗[ℝ] F) →ₗ[ℝ] ℝ :=
linear_map.mul' ℝ ℝ ∘ₗ
(tensor_product.map (as_tensor E) (as_tensor F)) ∘ₗ
↑(tensor_product.tensor_tensor_tensor_comm ℝ E F E F)

@[simp] lemma tensor_product_aux_apply (e₁ e₂ : E) (f₁ f₂ : F) :
  tensor_product_aux E F ((e₁ ⊗ₜ[ℝ] f₁) ⊗ₜ[ℝ] (e₂ ⊗ₜ[ℝ] f₂)) = ⟪e₁, e₂⟫ * ⟪f₁, f₂⟫ :=
by simp [tensor_product_aux, as_tensor]

section finite

variables [finite_dimensional ℝ E] [finite_dimensional ℝ F]

@[reducible] def canonical_basis_repr_aux (e : E) (f : F) : fin (finite_dimensional.finrank ℝ E) × fin (finite_dimensional.finrank ℝ F) →₀ ℝ :=
{ support := ((gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis.repr e).support ×ˢ
    ((gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis.repr f).support ,
  to_fun := λ i, (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis.coord i.1 e *
    (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis.coord i.2 f,
  mem_support_to_fun := λ ⟨i, j⟩, begin
    split; intros h;
    simp only [basis.coord_apply, orthonormal_basis.coe_to_basis_repr_apply, ne.def, mul_eq_zero, finset.mem_product,
      finsupp.mem_support_iff] at h ⊢,
    { tauto, }, { tauto },
  end }

@[simps] def canonical_basis_repr :
  E ⊗[ℝ] F →ₗ[ℝ] fin (finite_dimensional.finrank ℝ E) × fin (finite_dimensional.finrank ℝ F) →₀ ℝ :=
tensor_product.lift
{ to_fun := λ e,
  { to_fun := λ f, canonical_basis_repr_aux E F e f,
    map_add' := λ x y, by { ext1, simp only [finsupp.coe_mk, finsupp.add_apply, map_add, mul_add] },
    map_smul' := λ r f, begin
      ext1, simp only [finsupp.coe_mk, ring_hom.id_apply, finsupp.coe_smul, map_smul, pi.smul_apply,
        smul_eq_mul], ring1,
    end },
  map_add' := λ e e', begin
    ext : 2, simp only [linear_map.coe_mk, finsupp.coe_mk, map_add, add_mul, linear_map.add_apply,
      finsupp.add_apply],
  end,
  map_smul' := λ r e, begin
    ext : 2, simp only [linear_map.coe_mk, finsupp.coe_mk, finsupp.coe_smul, ring_hom.id_apply,
      linear_map.smul_apply, map_smul, pi.smul_apply, smul_eq_mul], ring1,
  end }

lemma canonical_basis_repr_tmul (e) (f) (x) :
  canonical_basis_repr E F (e ⊗ₜ f) x =
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis.coord x.1 e *
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis.coord x.2 f :=
by simp only [canonical_basis_repr_apply, tensor_product.lift_aux_tmul, linear_map.coe_mk,
    finsupp.coe_mk]

@[reducible] def canonical_basis_repr_symm :
  (fin (finite_dimensional.finrank ℝ E) × fin (finite_dimensional.finrank ℝ F) →₀ ℝ) →ₗ[ℝ] E ⊗[ℝ] F :=
finsupp.lsum ℝ $ λ (i : fin (finite_dimensional.finrank ℝ E) × fin (finite_dimensional.finrank ℝ F)),
({ to_fun := λ μ, μ • (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E) i.1 ⊗ₜ[ℝ]
    gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F) i.2),
  map_add' := λ r s, add_smul _ _ _,
  map_smul' := λ r x, mul_smul _ _ _ } : ℝ →ₗ[ℝ] E ⊗ F)

lemma canonical_basis_repr_apply_symm_apply :
  (canonical_basis_repr E F).comp (canonical_basis_repr_symm E F) = linear_map.id :=
begin
  ext z a, rw [linear_map.id_comp, linear_map.comp_apply, linear_map.comp_apply,
    finsupp.lsingle_apply, finsupp.lsum_single, linear_map.coe_mk, one_smul, finsupp.single_apply,
    canonical_basis_repr_tmul],
  split_ifs,
  { subst h,
    simp only [basis.coord_apply, orthonormal_basis.coe_to_basis_repr_apply, orthonormal_basis.repr_self,
      euclidean_space.single_apply, eq_self_iff_true, if_true, mul_one], },
  { simp only [basis.coord_apply, orthonormal_basis.coe_to_basis_repr_apply, orthonormal_basis.repr_self,
  euclidean_space.single_apply, boole_mul, ite_eq_right_iff, one_ne_zero],
    intros eq1 eq2, refine h _, ext, rw eq1.symm, rw eq2.symm, },
end

lemma canonical_basis_repr_symm_apply_apply_on_basis (i j) :
  canonical_basis_repr_symm E F (canonical_basis_repr E F $
    (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis i ⊗ₜ
    (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis j) =
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis i ⊗ₜ
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis j :=
begin
  rw [finsupp.lsum_apply, finsupp.sum],
  simp_rw [linear_map.coe_mk, canonical_basis_repr_tmul,
    basis.coord_apply],
  have seq : (canonical_basis_repr E F $
    (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis i ⊗ₜ
    (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis j).support =
  ({i} : finset _).product ({j}),
  { ext, split; intros h;
    simp only [finset.product_singleton, finset.map_singleton, function.embedding.coe_fn_mk,
      finset.mem_singleton, canonical_basis_repr_tmul, finsupp.mem_support_iff] at h ⊢,
    { rw [mul_ne_zero_iff, basis.coord_apply, basis.coord_apply] at h,
      rw [basis.repr_self, basis.repr_self, finsupp.single_apply, finsupp.single_apply] at h,
      rw prod.ext_iff, split_ifs at h with h1 h2, exact ⟨h1.symm, h2.symm⟩,
      exact false.elim (h.2 rfl), exact false.elim (h.1 rfl), exact false.elim (h.1 rfl), },
    { rw prod.ext_iff at h, rw [mul_ne_zero_iff, basis.coord_apply, basis.coord_apply,
        basis.repr_self, basis.repr_self, finsupp.single_apply, finsupp.single_apply,
        if_pos h.1.symm, if_pos h.2.symm], split; norm_num, }, },
    simp_rw seq, rw [finset.singleton_product_singleton, finset.sum_singleton],
    dsimp only, rw [basis.repr_self, basis.repr_self, finsupp.single_apply, finsupp.single_apply,
      if_pos rfl, if_pos rfl, one_mul, one_smul, orthonormal_basis.coe_to_basis,
      orthonormal_basis.coe_to_basis],
end

lemma canonical_basis_repr_symm_apply_apply :
  (canonical_basis_repr_symm E F).comp (canonical_basis_repr E F) = linear_map.id :=
begin
  apply tensor_product.algebra_tensor_module.ext, intros e f,
  conv_lhs { rw [←(gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis.total_repr e,
    ←(gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis.total_repr f] },
  rw [finsupp.total_apply, finsupp.total_apply, finsupp.sum, finsupp.sum, linear_map.id_apply,
    sum_tensor_sum, linear_map.comp_apply, map_sum, map_sum],
  simp_rw [tensor_product.tmul_smul, tensor_product.smul_tmul, tensor_product.tmul_smul, ←mul_smul,
    map_smul, canonical_basis_repr_symm_apply_apply_on_basis],
  conv_rhs { rw [←(gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)).to_basis.total_repr e,
    ←(gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)).to_basis.total_repr f] },
  rw [finsupp.total_apply, finsupp.total_apply, finsupp.sum, finsupp.sum, sum_tensor_sum],
  rw finset.sum_congr rfl,
  rintros ⟨i, j⟩ h, dsimp only,
  rw [tensor_product.tmul_smul, tensor_product.smul_tmul, tensor_product.tmul_smul, ←mul_smul],
end

lemma canonical_basis_repr_surj : function.surjective (canonical_basis_repr E F) :=
λ x, ⟨canonical_basis_repr_symm E F x, fun_like.congr_fun
  (canonical_basis_repr_apply_symm_apply E F) x⟩

lemma canonical_basis_repr_inj : function.injective (canonical_basis_repr E F) :=
begin
  intros x y h,
  apply_fun canonical_basis_repr_symm E F at h,
  erw [fun_like.congr_fun (canonical_basis_repr_symm_apply_apply E F) x,
    fun_like.congr_fun (canonical_basis_repr_symm_apply_apply E F) y] at h,
  exact h,
end

@[simps] def canonical_basis :
  basis (fin (finite_dimensional.finrank ℝ E) × fin (finite_dimensional.finrank ℝ F)) ℝ
 (E ⊗[ℝ] F) :=
⟨{ ..canonical_basis_repr E F,
  ..equiv.of_bijective _ ⟨canonical_basis_repr_inj E F, canonical_basis_repr_surj E F⟩}⟩

lemma canonical_basis_apply (x) :
  (canonical_basis E F x) =
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E)) x.1 ⊗ₜ
  (gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F)) x.2 :=
begin
  change (canonical_basis E F).repr.symm _ = _,
  apply_fun (canonical_basis E F).repr using canonical_basis_repr_inj,
  ext i,
  erw canonical_basis_repr_tmul,
  erw linear_equiv.apply_symm_apply,
  rw finsupp.single_apply,
  simp only [orthonormal_basis.coe_to_basis, basis.coord_apply, orthonormal_basis.coe_to_basis_repr_apply,
    orthonormal_basis.repr_self, euclidean_space.single_apply, boole_mul],
  simp_rw [prod.ext_iff, ite_and], split_ifs; tauto,
end

instance tensor_product_of_finite : inner_product_space ℝ (E ⊗[ℝ] F) :=
of_core
{ inner := λ x y, tensor_product_aux E F (x ⊗ₜ y),
  conj_sym := λ z₁ z₂, tensor_product.induction_on z₁
    (by rw [tensor_product.tmul_zero, map_zero, map_zero, tensor_product.zero_tmul, map_zero])
    (λ x y, tensor_product.induction_on z₂
      (by rw [tensor_product.zero_tmul, map_zero, map_zero, tensor_product.tmul_zero, map_zero])
      (λ e f, by { rw [tensor_product_aux_apply, tensor_product_aux_apply, star_ring_end_apply],
        dsimp, rw [real_inner_comm f y, real_inner_comm e x], })
      (λ x₁ x₂ ih₁ ih₂, by rw [tensor_product.add_tmul, map_add, map_add, ih₁, ih₂,
        tensor_product.tmul_add, map_add]))
    (λ x y ih₁ ih₂, by rw [tensor_product.tmul_add, map_add, map_add, ih₁, ih₂,
      tensor_product.add_tmul, map_add]),
  nonneg_re := begin
    intros z, classical,
    set onb_E := gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E),
    set onb_F := gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F),
    rw [is_R_or_C.re_to_real],
    rw [←(canonical_basis E F).total_repr z, finsupp.total_apply, finsupp.sum,
      sum_tensor_sum, map_sum],
    simp_rw [tensor_product.smul_tmul, tensor_product.tmul_smul, map_smul, ←mul_smul,
      canonical_basis_apply, tensor_product_aux_apply, orthonormal_iff_ite.mp onb_E.orthonormal,
      orthonormal_iff_ite.mp onb_F.orthonormal, ite_mul, one_mul, zero_mul, smul_ite, smul_eq_mul,
      mul_one, mul_zero],
    rw [←finset.sum_filter, ←finset.sum_filter],
    apply finset.sum_nonneg,
    rintros ⟨⟨a, b⟩, ⟨c, d⟩⟩ h,
    simp only [finset.mem_filter, finset.mem_product] at h,
    dsimp only, rw [h.1.2, h.2],
    exact mul_self_nonneg _,
  end,
  definite := λ z hz, begin
    classical,
    set onb_E := gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ E),
    set onb_F := gram_schmidt_orthonormal_basis ℝ (finite_dimensional.fin_basis ℝ F),
    rw [←(canonical_basis E F).total_repr z, finsupp.total_apply, finsupp.sum,
      sum_tensor_sum, map_sum] at hz,
    simp_rw [tensor_product.smul_tmul, tensor_product.tmul_smul, map_smul, ←mul_smul,
      canonical_basis_apply, tensor_product_aux_apply, orthonormal_iff_ite.mp onb_E.orthonormal,
      orthonormal_iff_ite.mp onb_F.orthonormal, ite_mul, one_mul, zero_mul, smul_ite, smul_eq_mul,
      mul_one, mul_zero] at hz,
    rw [←finset.sum_filter, ←finset.sum_filter, finset.sum_eq_zero_iff_of_nonneg] at hz,
    work_on_goal 2
    { rintros ⟨⟨a, b⟩, ⟨c, d⟩⟩ h,
      simp only [finset.mem_filter, finset.mem_product] at h,
      dsimp only, rw [h.1.2, h.2],
      exact mul_self_nonneg _, },
    rw [←(canonical_basis E F).total_repr z, finsupp.total_apply, finsupp.sum],
    apply finset.sum_eq_zero,
    intros x hx, specialize hz (x, x),
    rw [finset.mem_filter, finset.mem_filter, finset.mem_product] at hz,
    specialize hz ⟨⟨⟨hx, hx⟩, rfl⟩, rfl⟩,
    rw [mul_self_eq_zero] at hz, rw [hz, zero_smul],
  end,
  add_left := λ x y z, by rw [tensor_product.add_tmul, map_add],
  smul_left := λ x y r, by rw [is_R_or_C.conj_to_real,
    ← tensor_product.smul_tmul', map_smul, smul_eq_mul] }

end finite

section possibly_infinite

lemma to_fd (e : E) : ∃ (E' : subspace ℝ E) [finite_dimensional ℝ E'], e ∈ E' :=
begin
  classical,
  refine ⟨submodule.span ℝ (finset.image (basis.of_vector_space ℝ E)
    ((basis.of_vector_space ℝ E).repr e).support), _, _⟩,
  { apply finite_dimensional.span_finset,},
  { conv_lhs { rw ←(basis.of_vector_space ℝ E).total_repr e },
    rw finsupp.total_apply,
    convert submodule.sum_mem _ _,
    intros c hc,
    convert submodule.smul_mem _ _ _,
    apply submodule.subset_span,
    rw [finset.coe_image, set.mem_image],
    exact ⟨_, hc, rfl⟩},
end

@[simps] def tensor_submodule (E' : subspace ℝ E) (F' : subspace ℝ F) :
  (E' ⊗[ℝ] F') →ₗ[ℝ] (E ⊗[ℝ] F) :=
tensor_product.lift
{ to_fun := λ e',
  { to_fun := λ f', (e' : E) ⊗ₜ (f' : F),
    map_add' := λ f f', by rw [submodule.coe_add, tensor_product.tmul_add],
    map_smul' := λ r f, by rw [ring_hom.id_apply, submodule.coe_smul, tensor_product.tmul_smul], },
  map_add' := λ e e', linear_map.ext $ λ f, by rw [linear_map.coe_mk, submodule.coe_add,
    tensor_product.add_tmul, linear_map.add_apply, linear_map.coe_mk, linear_map.coe_mk],
  map_smul' := λ r e, linear_map.ext $ λ f, by rw [ring_hom.id_apply, linear_map.smul_apply,
    linear_map.coe_mk, linear_map.coe_mk, submodule.coe_smul, tensor_product.smul_tmul,
    tensor_product.tmul_smul] }

lemma tensor_submodule_mk {E' : subspace ℝ E} {F' : subspace ℝ F} (e : E') (f : F') :
  tensor_submodule E F E' F' (e ⊗ₜ f) = (e : E) ⊗ₜ (f : F) := rfl

lemma tensor_submodule_range_mono1 {E' E'' : subspace ℝ E} (F' : subspace ℝ F)
  (le1 : E' ≤ E'') :
  linear_map.range (tensor_submodule E F E' F') ≤
  linear_map.range (tensor_submodule E F E'' F') := λ x hx,
begin
  obtain ⟨x, rfl⟩ := hx,
  induction x using tensor_product.induction_on with e f x₁ x₂ ih₁ ih₂,
  { rw [map_zero], exact submodule.zero_mem _ },
  { rw [tensor_submodule_mk], exact ⟨⟨e, le1 e.2⟩ ⊗ₜ f, rfl⟩, },
  { rw [map_add], exact submodule.add_mem _ ih₁ ih₂, },
end

lemma tensor_submodule_range_mono2 (E' : subspace ℝ E) {F' F'' : subspace ℝ F}
  (le2 : F' ≤ F'') :
  linear_map.range (tensor_submodule E F E' F') ≤
  linear_map.range (tensor_submodule E F E' F'') := λ x hx,
begin
  obtain ⟨x, rfl⟩ := hx,
  induction x using tensor_product.induction_on with e f x₁ x₂ ih₁ ih₂,
  { rw [map_zero], exact submodule.zero_mem _ },
  { rw [tensor_submodule_mk], exact ⟨e ⊗ₜ ⟨f, le2 f.2⟩, rfl⟩, },
  { rw [map_add], exact submodule.add_mem _ ih₁ ih₂, },
end

lemma tensor_submodule_apply_tmul (E' : subspace ℝ E) (F' : subspace ℝ F) (e : E') (f : F') :
  tensor_submodule E F E' F' (e ⊗ₜ f) = (e : E) ⊗ₜ (f : F) := rfl

lemma to_tensor_fd (z : E ⊗[ℝ] F) : ∃ (E' : subspace ℝ E) (F' : subspace ℝ F)
  [finite_dimensional ℝ E'] [finite_dimensional ℝ F'],
  z ∈ (tensor_submodule E F E' F').range :=
begin
  induction z using tensor_product.induction_on with e f z₁ z₂ ih₁ ih₂,
  { refine ⟨⊥, ⊥, _, _, submodule.zero_mem _⟩,
    exacts [finite_dimensional_bot ℝ E, finite_dimensional_bot ℝ F] },
  { rcases to_fd E e with ⟨E', iE', he⟩,
    rcases to_fd F f with ⟨F', iF', hf⟩,
    exact ⟨E', F', iE', iF', ⟨⟨e, he⟩ ⊗ₜ ⟨f, hf⟩, rfl⟩⟩, },
  { rcases ih₁ with ⟨E1, F1, iE1, iF1, ⟨z1, rfl⟩⟩,
    rcases ih₂ with ⟨E2, F2, iE2, iF2, ⟨z2, rfl⟩⟩,
    resetI,
    have le1 : linear_map.range (tensor_submodule E F E1 F1) ≤
      linear_map.range (tensor_submodule E F (E1 ⊔ E2) (F1 ⊔ F2)),
    { exact (tensor_submodule_range_mono1 E F F1 (le_sup_left : E1 ≤ E1 ⊔ E2)).trans
        (tensor_submodule_range_mono2 E F _ le_sup_left), },
    have le2 : linear_map.range (tensor_submodule E F E2 F2) ≤
      linear_map.range (tensor_submodule E F (E1 ⊔ E2) (F1 ⊔ F2)),
    { exact (tensor_submodule_range_mono1 _ _ _ (le_sup_right : E2 ≤ E1 ⊔ E2)).trans
        (tensor_submodule_range_mono2 _ _ _ le_sup_right), },
    exact ⟨E1 ⊔ E2, F1 ⊔ F2, submodule.finite_dimensional_sup E1 E2,
      submodule.finite_dimensional_sup F1 F2, submodule.add_mem _ (le1 ⟨z1, rfl⟩) (le2 ⟨z2, rfl⟩)⟩ },
end

lemma tensor_product_aux_restrict_apply' (x y : E ⊗[ℝ] F)
  (E' : subspace ℝ E) (F' : subspace ℝ F) (x' y' : E' ⊗[ℝ] F')
  (hx : x = tensor_submodule E F E' F' x')
  (hy : y = tensor_submodule E F E' F' y') :
  (tensor_product_aux E F (x ⊗ₜ y)) =
  (tensor_product_aux E' F' (x' ⊗ₜ y')) :=
begin
  rw [hx, hy], revert x,
  induction x' using tensor_product.induction_on with e' f' x₁ x₂ ih₁ ih₂,
  { simp only [map_zero, tensor_product.zero_tmul], exact λ _ _, rfl, },
  { rw [tensor_submodule_apply_tmul], revert y,
    induction y' using tensor_product.induction_on with e'' f'' y₁ y₂ ih₁ ih₂,
    { simp only [map_zero, tensor_product.tmul_zero], exact λ _ _ _ _, rfl, },
    { intros x h y h', simpa only [tensor_submodule_apply_tmul, tensor_product_aux_apply], },
    { intros x hx y hy,
      rw [map_add, tensor_product.tmul_add, map_add, tensor_product.tmul_add,
        map_add, ih₁, ih₂], refl, refl, refl, refl, }, },
  { intros x hx,
    simp only [tensor_product.add_tmul, map_add],
    rw [ih₁, ih₂], refl, refl, },
end

lemma tensor_product_aux_restrict_apply (x y : E ⊗[ℝ] F)
  (E' : subspace ℝ E) (F' : subspace ℝ F)
  (hx : x ∈ (tensor_submodule E F E' F').range)
  (hy : y ∈ (tensor_submodule E F E' F').range) :
  (tensor_product_aux E F (x ⊗ₜ y)) =
  (tensor_product_aux E' F' (hx.some ⊗ₜ hy.some)) :=
begin
  apply tensor_product_aux_restrict_apply',
  exacts [hx.some_spec.symm, hy.some_spec.symm],
end

instance tensor_product' : inner_product_space ℝ (E ⊗[ℝ] F) :=
of_core
{ inner := λ x y, tensor_product_aux E F (x ⊗ₜ y),
  conj_sym := λ z₁ z₂, tensor_product.induction_on z₁
    (by rw [tensor_product.tmul_zero, map_zero, map_zero, tensor_product.zero_tmul, map_zero])
    (λ x y, tensor_product.induction_on z₂
      (by rw [tensor_product.zero_tmul, map_zero, map_zero, tensor_product.tmul_zero, map_zero])
      (λ e f, by { rw [tensor_product_aux_apply, tensor_product_aux_apply, star_ring_end_apply],
        dsimp, rw [real_inner_comm f y, real_inner_comm e x], })
      (λ x₁ x₂ ih₁ ih₂, by rw [tensor_product.add_tmul, map_add, map_add, ih₁, ih₂,
        tensor_product.tmul_add, map_add]))
    (λ x y ih₁ ih₂, by rw [tensor_product.tmul_add, map_add, map_add, ih₁, ih₂,
      tensor_product.add_tmul, map_add]),
  nonneg_re := begin
    intros z, rw is_R_or_C.re_to_real,
    obtain ⟨E', F', iE', iF', hz⟩ := to_tensor_fd E F z,
    rw tensor_product_aux_restrict_apply E F z z E' F'
      hz hz,
    resetI,
    convert_to 0 ≤ (inner_product_space.tensor_product_of_finite E' F').inner _ _,
    exact real_inner_self_nonneg,
  end,
  definite := begin
    intros z h,
    obtain ⟨E', F', iE', iF', hz⟩ := to_tensor_fd E F z,
    rw tensor_product_aux_restrict_apply E F z z E' F'
      hz hz at h,
    resetI,
    change (inner_product_space.tensor_product_of_finite E' F').inner hz.some hz.some = (0 : ℝ) at h,
    have h' : hz.some = 0 := inner_product_space.core.definite _ _ h,
    have h'' := hz.some_spec,
    rw [h', map_zero] at h'', exact h''.symm,
  end,
  add_left := λ x y z, by rw [tensor_product.add_tmul, map_add],
  smul_left := λ x y r, by rw [is_R_or_C.conj_to_real,
    ← tensor_product.smul_tmul', map_smul, smul_eq_mul] }

@[simp] lemma inner_tprod (e₁ e₂ : E) (f₁ f₂ : F) :
  ⟪e₁ ⊗ₜ[ℝ] f₁, e₂ ⊗ₜ[ℝ] f₂⟫ = ⟪e₁, e₂⟫ * ⟪f₁, f₂⟫ :=
tensor_product_aux_apply E F e₁ e₂ f₁ f₂

end possibly_infinite

end inner_product_space