import .affine_coordinate_framed_space
import .affine_space_type
import data.real.basic
import linear_algebra.affine_space.basic
import .affine_coordinate_space_lib

noncomputable theory
open aff_fr

/-
For now we'll work with real 3-spaces
-/
def dim := 3            -- pick whatever dimension you want here (other than 0? TODO: Check)
abbreviation K := ℝ     -- alternative field could be ℚ for example

/-
Type aliases for vector and point types in raw (frameless) K-dim affine coordinate space
-/
abbreviation aff_vec_coords := (aff_vec_coord_tuple K dim)
abbreviation aff_pt_coords := (aff_pt_coord_tuple K dim)

/-
Create a "raw" standard frame to bootstrap framed coordinate spaces, using

-/
def std_frame_on_raw_coord_space : affine_frame aff_pt_coords K aff_vec_coords (fin dim) :=
    aff_coord_space_std_frame K dim

#check std_frame_on_raw_coord_space

/-
Define type aliases for, respectively, the types of vectors and points with
coordinates in terms of the *raw* standard frame.
-/
abbreviation K_dim_raw_std_fr_vec := aff_coord_vec aff_pt_coords K aff_vec_coords dim (fin dim) std_frame_on_raw_coord_space
abbreviation K_dim_raw_std_fr_pt := aff_coord_pt aff_pt_coords K aff_vec_coords dim (fin dim) std_frame_on_raw_coord_space

/-
Create unframed standard basis vectors and origin points.
-/
def aff_pt_coords1 : aff_pt_coords :=       ⟨[1,0,0,0],sorry,sorry⟩
def aff_vec_coords1 : aff_vec_coords :=     ⟨[0,1,0,0],sorry,sorry⟩
def aff_vec_coords2 : aff_vec_coords :=     ⟨[0,0,1,0],sorry,sorry⟩
def aff_vec_coordsdim : aff_vec_coords :=   ⟨[0,0,0,1],sorry,sorry⟩

/-

structure aff_coord_pt (fr : affine_frame X K V ι) extends aff_pt_coord_tuple K n :=
   -- (tuple : aff_pt_coord_tuple K n)
   mk ::

structure aff_coord_vec (fr : affine_frame X K V ι) extends aff_vec_coord_tuple K n  :=
   -- (tuple : aff_vec_coord_tuple K n)
   mk ::
-/

/-
Lift unframed vectors and point to vectors and point with the raw standard frame
-/
def K_dim_raw_std_fr_vec1 : K_dim_raw_std_fr_vec := ⟨aff_vec_coordsdim⟩
def K_dim_raw_std_fr_vec2 : K_dim_raw_std_fr_vec := ⟨aff_vec_coords1⟩
def K_dim_raw_std_fr_vecdim : K_dim_raw_std_fr_vec := ⟨aff_vec_coords2⟩
def K_dim_raw_std_fr_pt1 : K_dim_raw_std_fr_pt := ⟨aff_pt_coords1⟩

/-
(fin n ) → "My Vector Type"
-/

/-
Define a function to assemble basis vectors into a *basis*
TODO: Fix this. Wrong level of abstraction at this point.
-/
def to_basis (n:ℕ) {vec_type : Type*} (l : vector vec_type n)
    : (fin n) → vec_type :=
    λ i : fin n, l.nth i

/-
Create a standard frame whose points and vectors themselves have frames, namely
the raw standard frame.
-/
def std_frame_complete : affine_frame K_dim_raw_std_fr_pt K K_dim_raw_std_fr_vec (fin dim) :=
    ⟨K_dim_raw_std_fr_pt1, to_basis dim ⟨[K_dim_raw_std_fr_vec1,K_dim_raw_std_fr_vec2,K_dim_raw_std_fr_vecdim],sorry⟩,sorry⟩

/-
Abbreviations for points and vectors in the complete standard frame. The points
and vectors in this complete frame are themselves framed in the raw frame.
-/
abbreviation K_dim_std_frame_complete_vec :=
    aff_coord_vec K_dim_raw_std_fr_pt K K_dim_raw_std_fr_vec dim (fin dim) std_frame_complete
abbreviation K_dim_std_frame_complete_pt :=
    aff_coord_pt K_dim_raw_std_fr_pt K K_dim_raw_std_fr_vec dim (fin dim) std_frame_complete

/-
TODO: Do we want to create a standard frame for A_dim whose points and vectors
are themselves expressed in terms of this standard frame?
-/

/-
Create basis vectors and points in the complete standard frame suitable for
constructing a derived, non-standard frame. Note that the basis vectors in
this case are in different order than 1, 2, dim (now 2, dim, 1).
-/
def K_dim_std_frame_complete_vec1 : K_dim_std_frame_complete_vec := ⟨aff_vec_coords2⟩
def K_dim_std_frame_complete_vec2 : K_dim_std_frame_complete_vec := ⟨aff_vec_coordsdim⟩
def K_dim_std_frame_complete_vecdim : K_dim_std_frame_complete_vec := ⟨aff_vec_coords1⟩
def K_dim_std_frame_complete_pt1 : K_dim_std_frame_complete_pt := ⟨aff_pt_coords1⟩

/-
Use the point and vectors just created to create a non-standard frame.
-/
def non_standard_frame : affine_frame K_dim_std_frame_complete_pt K K_dim_std_frame_complete_vec (fin dim) :=
    ⟨K_dim_std_frame_complete_pt1,to_basis dim ⟨[K_dim_std_frame_complete_vec1,K_dim_std_frame_complete_vec2,K_dim_std_frame_complete_vecdim],sorry⟩,sorry⟩

/-
Abbreviations for points and vectors in this new non-standard frame
-/
abbreviation K_dim_non_standard_frame_vec :=
    aff_coord_vec K_dim_std_frame_complete_pt K K_dim_std_frame_complete_vec dim (fin dim) non_standard_frame
abbreviation K_dim_non_standard_frame_pt :=
    aff_coord_pt K_dim_std_frame_complete_pt K K_dim_std_frame_complete_vec dim (fin dim) non_standard_frame

/-
Some points and vectors in this non-standard frame. (Note that in all cases we're using
raw affine points and vectors to supply coordinate tuples for all of these constructors.)
-/
def K_dim_non_standard_frame_vec1 : K_dim_non_standard_frame_vec := ⟨aff_vec_coords2⟩
def K_dim_non_standard_frame_vec2 : K_dim_non_standard_frame_vec := ⟨aff_vec_coordsdim⟩
def K_dim_non_standard_frame_vecdim : K_dim_non_standard_frame_vec := ⟨aff_vec_coords1⟩
def K_dim_non_standard_frame_pt1 : K_dim_non_standard_frame_pt := ⟨aff_pt_coords1⟩

/-
Test out type checking of affine space algebraic operations: expect succeed.
-/
def vecsub := K_dim_non_standard_frame_vec1 - K_dim_non_standard_frame_vec2 -- expected :pass
def vecptadd := pt_plus_vec K_dim_non_standard_frame_pt1 K_dim_non_standard_frame_vec2 --expected : pass
def vecptaddnotation := K_dim_non_standard_frame_pt1 +ᵥ K_dim_non_standard_frame_vec2 --expected : pass
def ptvecadd := K_dim_non_standard_frame_vec2 +ᵥ K_dim_non_standard_frame_pt1 --expected : pass
def vecptsub := K_dim_non_standard_frame_pt1 -ᵥ K_dim_non_standard_frame_vec2  --K_dim_non_standard_frame_pt1 -ᵥ K_dim_non_standard_frame_vec2 --expected : pass
def pt_sub := K_dim_non_standard_frame_pt1 -ᵥ K_dim_non_standard_frame_pt1 -- expected : pass
def scaled : K_dim_non_standard_frame_vec  := (1:K)•K_dim_non_standard_frame_vec2

/-
Test type checking of affine space operations: expect fail.
-/
def ptvecsub := K_dim_non_standard_frame_vec2 -ᵥ K_dim_non_standard_frame_pt1 -- expected : fail?
def pt_add := K_dim_non_standard_frame_pt1 +ᵥ K_dim_non_standard_frame_pt1 -- expected : fail
def dif_fr := K_dim_std_frame_complete_vec1 - K_dim_non_standard_frame_vec2 -- expected : fail

/-
SUMMARY:

We have two frames:

- K_dim_std_frame_complete_vec [points and vectors of the frame are framed in raw frame]
- K_dim_non_standard_frame_vec [points and vectors of the frame are framed in K_dim_std_frame_complete_vec]

Observation: We have frames but we don't have explicit corresponding affine spaces. (Or do we?)
-/

/-
Define affine spaces with increasingly structured frames.
- The unframed space is a raw affine coordinate space with no explicit frame.
- The raw_std space imposes a frame on this space whose points and vectors in the unframed space.
- The quasi-framed space imposes a frame on this space whose points and vectors are in the raw_std space
- The fully framed space imposes a frame whose points and vectors are in the quasi-framed (compl) space.
-/
def an_unframed_affine_space : affine_space_type aff_pt_coords K aff_vec_coords := ⟨⟩
def a_raw_std_framed_affine_space : affine_space_type K_dim_raw_std_fr_pt K K_dim_raw_std_fr_vec := ⟨⟩
def a_quasi_framed_affine_space : affine_space_type K_dim_std_frame_complete_pt K K_dim_std_frame_complete_vec := ⟨⟩
def a_fully_framed_affine_space : affine_space_type K_dim_non_standard_frame_pt K K_dim_non_standard_frame_vec := ⟨⟩

/-
Now we'll build two more spaces on top of fully_framed
- derived_frame and derived_space
- derived_frame_2 and derived_space_2
-/

/-
Here's derived_frame and derived space
-/
def derived_frame :=
    aff_lib.affine_coord_nspace.mk_derived_frame
    a_fully_framed_affine_space
            ⟨aff_pt_coords1⟩
            ⟨[⟨aff_vec_coordsdim⟩,⟨aff_vec_coords2⟩,⟨aff_vec_coords1⟩],
                    by refl⟩

def derived_space :=
    aff_lib.affine_coord_nspace.mk_derived_from_frame
        a_fully_framed_affine_space
        derived_frame

-- Here's derived_frame_2 with points made in derived_space, followed by derived_space_2
def my_pt := aff_lib.affine_coord_nspace.mk_point derived_space [1,1,1]
def my_v1 := aff_lib.affine_coord_nspace.mk_vec derived_space [0.5,0,0]
def my_v2 := aff_lib.affine_coord_nspace.mk_vec derived_space [0,0.5,1]
def my_v3 := aff_lib.affine_coord_nspace.mk_vec derived_space [0,0,0.5]

def derived_frame_2 :=
    aff_lib.affine_coord_nspace.mk_derived_frame
    derived_space
            (aff_lib.affine_coord_nspace.mk_point derived_space [1,1,1])
            ⟨
                [
                    (aff_lib.affine_coord_nspace.mk_vec derived_space [0.5,0,0]),
                    (aff_lib.affine_coord_nspace.mk_vec derived_space [0,0.5,1]),
                    (aff_lib.affine_coord_nspace.mk_vec derived_space [0,0,0.5])
                ],
                by refl
            ⟩

def derived_space_2 :=
   aff_lib.affine_coord_nspace.mk_derived_from_frame
        derived_space
        derived_frame_2

/-
Given a space returns its base frame (or space), i.e., the frame in terms of which
its frame elements are expressed.
-/

/-

def an_unframed_affine_space
    : affine_space_type aff_pt_coords K aff_vec_coords
    := ⟨⟩
def a_raw_std_framed_affine_space : affine_space_type K_dim_raw_std_fr_pt K K_dim_raw_std_fr_vec := ⟨⟩
def a_quasi_framed_affine_space : affine_space_type K_dim_std_frame_complete_pt K K_dim_std_frame_complete_vec := ⟨⟩
def a_fully_framed_affine_space : affine_space_type K_dim_non_standard_frame_pt K K_dim_non_standard_frame_vec := ⟨⟩

- get_base_space derived_space_2
                    (affine_space aff_coord_pt K aff_coord_vec der_fr)
                    :
        -- expect derived_space
- get_base_space derived_space
        -- expect a_fully_framed_affine_space
- get_base_space a_fully_framed_affine_space
                    (affine_space aff_coord_pt K aff_coord_vec quasi_fr)
        -- expect a_quasi_framed_affine_space
- get_base_space a_quasi_framed_affine_space
                     (affine_space aff_coord_pt K aff_coord_vec raw_fr)
        -- expect a_raw_std_framed_affine_space
- get_base_space a_raw_std_framed_affine_space
                     (affine_space aff_coord_pt K aff_coord_vec unfr_fr)
        -- expect an_unframed_affine_space
- get_base_space an_unframed_affine_space
                    : (affine_space tuple_pt K tuple_vec )
        -- expect ???
-/

#check derived_space_2
#check (aff_lib.affine_coord_nspace dim derived_frame_2)

/-
aff coord space:

    affine_space_type
        (aff_coord_pt X K V n ι fr)
        K
        (aff_coord_vec X K V n ι fr)

def affine_coord_space.get_base_space
    {X : Type u} {K : Type v} {V : Type w} {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    {n : ℕ}
    {fr : affine_frame X K V ι }
    (sp : affine_coord_space n fr)
    :=
        affine_space_type X K V

-/

def derived_space_2_base := aff_lib.affine_coord_space.get_base_space derived_space_2

example : derived_space_2_base = derived_space := rfl       -- nope

def derived_space_base := aff_lib.affine_coord_space.get_base_space derived_space

def a_fully_framed_affine_space_base := aff_lib.affine_coord_space.get_base_space a_fully_framed_affine_space

def another_base := aff_lib.affine_coord_space.get_base_space a_fully_framed_affine_space

def a_quasi_framed_affine_space_base := aff_lib.affine_coord_space.get_base_space a_fully_framed_affine_space

def a_raw_framed_affine_space_base := aff_lib.affine_coord_space.get_base_space a_fully_framed_affine_space

#check derived_space_2_base
/-
    affine_space_type
        (aff_coord_pt X K V n (fin n) fr)
        K
        (aff_coord_vec X K V n (fin n) fr)
-/

/-
inductive affine_coordinate_space_type
| mk_raw (as : affine_space aff_pt K aff_vec) (o : origin)
| mk_der (acs : affine_coordinate_space_type) (acf: affine_coordinate_frame)
-/


/-
Copyright (c) 2021 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving, Simon Hudon
-/
import Mathlib.Control.Random
import Mathlib.Data.List.Perm
import Mathlib.Data.Subtype
import Mathlib.Data.Nat.Basic

/-!
# `Gen` Monad
This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.
This is a port of the Haskell QuickCheck library.

## Main definitions
  * `Gen` monad

## Tags

random testing

## References
  * https://hackage.haskell.org/package/QuickCheck
-/

namespace SlimCheck

open Random

/-- Monad to generate random examples to test properties with.
It has a `Nat` parameter so that the caller can decide on the
size of the examples. -/
abbrev Gen (α : Type u) := ReaderT (ULift Nat) Rand α

namespace Gen

/-- Lift `Random.random` to the `Gen` monad. -/
def chooseAny (α : Type u) [Random α] : Gen α :=
  λ _ => rand α

/-- Lift `BoundedRandom.randomR` to the `Gen` monad. -/
def choose (α : Type u) [Preorder α] [BoundedRandom α] (lo hi : α) (h : lo ≤ hi) :
    Gen {a // lo ≤ a ∧ a ≤ hi} :=
  λ _ => randBound α lo hi h

lemma chooseNatLt_aux {lo hi : Nat} (a : Nat) (h : Nat.succ lo ≤ a ∧ a ≤ hi) :
    lo ≤ Nat.pred a ∧ Nat.pred a < hi :=
  And.intro (Nat.le_pred_of_lt (Nat.lt_of_succ_le h.left)) <|
    show a.pred.succ ≤ hi by
       rw [Nat.succ_pred_eq_of_pos]
       exact h.right
       exact lt_of_le_of_lt (Nat.zero_le lo) h.left

/-- Generate a `Nat` example between `x` and `y` (exclusively). -/
def chooseNatLt (lo hi : Nat) (h : lo < hi) : Gen {a // lo ≤ a ∧ a < hi} :=
  Subtype.map Nat.pred chooseNatLt_aux <$> choose Nat (lo.succ) hi (Nat.succ_le_of_lt h)

/-- Get access to the size parameter of the `Gen` monad. -/
def getSize : Gen Nat :=
  return (← read).down

/-- Apply a function to the size parameter. -/
def resize (f : Nat → Nat) (x : Gen α) : Gen α :=
  withReader (ULift.up ∘ f ∘ ULift.down) x

/-- Create an `Array` of examples using `x`. The size is controlled
by the size parameter of `Gen`. -/
def arrayOf (x : Gen α) : Gen (Array α) := do
  let sz ← choose Nat 0 (←getSize) (Nat.zero_le _)
  let mut res := #[]
  for _ in [0:sz] do
    res := res.push (← x)
  pure res

/-- Create an `List` of examples using `x`. The size is controlled
by the size parameter of `Gen`. -/
def listOf (x : Gen α) : Gen (List α) :=
  arrayOf x >>= pure ∘ Array.toList

/-- Given a list of example generators, choose one to create an example. -/
def oneOf (xs : Array (Gen α)) (pos : 0 < xs.size := by decide) : Gen α := do
  let ⟨x, _, h2⟩ ← chooseNatLt 0 xs.size pos
  xs.get ⟨x, h2⟩

/-- Given a list of examples, choose one to create an example. -/
def elements (xs : List α) (pos : 0 < xs.length) : Gen α := do
  let ⟨x, _, h2⟩ ← chooseNatLt 0 xs.length pos
  pure $ xs.get ⟨x, h2⟩

open List in
/-- Generate a random permutation of a given list. -/
def permutationOf : (xs : List α) → Gen { ys // ys ~ xs }
| [] => pure ⟨[], Perm.nil⟩
| x::xs => do
  let ⟨ys, h1⟩ ← permutationOf xs
  let ⟨n, _, h3⟩ ← choose Nat 0 ys.length (Nat.zero_le _)
  pure ⟨insertNth n x ys, Perm.trans (perm_insertNth _ _ h3) (Perm.cons _ h1)⟩

/-- Given two generators produces a tuple consisting out of the result of both -/
def prodOf {α β : Type u} (x : Gen α) (y : Gen β) : Gen (α × β) := do
  pure (←x, ←y)

end Gen

/-- Execute a `Gen` inside the `IO` monad using `size` as the example size-/
def Gen.run (x : Gen α) (size : Nat) : BaseIO α :=
  IO.runRand $ ReaderT.run x ⟨size⟩

end SlimCheck


import algebra.ofe.complete

universe u

/-- A *step-indexed proposition* is a proposition at each time step `n : ℕ`, such that if `p n`,
we must have `p m` for all `m ≤ n`. -/
@[ext] structure {u'} sprop : Type u' :=
(p : ℕ → Prop)
(mono : antitone p)

instance sprop.fun_like : fun_like sprop.{u} ℕ (λ _, Prop) := {
  coe := sprop.p,
  coe_injective' := λ p q h, by ext1; exact h,
}

@[simp] lemma sprop.coe_fn_mk
  (p : ℕ → Prop) (mono : antitone p) : ((⟨p, mono⟩ : sprop) : ℕ → Prop) = p := rfl

def sprop.const (p : Prop) : sprop := ⟨λ _, p, λ m n hmn h, h⟩

instance : ofe sprop := {
  eq_at := λ n p q, ∀ m ≤ n, p m ↔ q m,
  eq_at_reflexive := by intros _ _ _ _; refl,
  eq_at_symmetric := begin
    intros n p q h m hmn,
    rw h m hmn,
  end,
  eq_at_transitive := begin
    intros n p q r hpq hqr m hmn,
    rw hpq m hmn,
    rw hqr m hmn,
  end,
  eq_at_mono' := begin
    intros m n hmn p q h k hkm,
    rw h _ (hkm.trans hmn),
  end,
  eq_at_limit' := begin
    intros p q h,
    ext n,
    exact h n n le_rfl,
  end,
}

instance : cofe sprop := {
  lim := λ c, ⟨λ n, c n n,
    λ m n hmn h, (c.prop m n hmn m le_rfl).mpr ((c n).mono hmn h)⟩,
  complete := λ n c m hmn, c.prop m n hmn m le_rfl,
}

instance : has_le sprop := ⟨λ p q, (p : ℕ → Prop) ≤ q⟩

instance : partial_order sprop := {
  le_refl := λ p, le_refl (p : ℕ → Prop),
  le_trans := λ p q r hpq hqr, pi.partial_order.le_trans p q r hpq hqr,
  le_antisymm := λ a b h₁ h₂, by ext1; exact pi.partial_order.le_antisymm a b h₁ h₂,
  ..sprop.has_le
}

instance : semilattice_inf sprop := {
  inf := λ p q, ⟨λ n, p n ∧ q n, λ m n hmn h, ⟨p.mono hmn h.1, q.mono hmn h.2⟩⟩,
  inf_le_left := λ p q n h, h.1,
  inf_le_right := λ p q n h, h.2,
  le_inf := λ p q r hpq hpr n h, ⟨hpq n h, hpr n h⟩,
  ..sprop.partial_order
}

instance : semilattice_sup sprop := {
  sup := λ p q, ⟨λ n, p n ∨ q n, λ m n hmn h,
    h.elim (λ h, or.inl $ p.mono hmn h) (λ h, or.inr $ q.mono hmn h)⟩,
  le_sup_left := λ p q n h, or.inl h,
  le_sup_right := λ p q n h, or.inr h,
  sup_le := λ p q r hpr hqr n hpq, hpq.elim
    (λ hpq, hpr n hpq) (λ hpq, hqr n hpq),
  ..sprop.partial_order
}

instance : distrib_lattice sprop := {
  le_sup_inf := λ p q r n h, h.1.elim
    (λ hp, or.inl hp) (λ hq, h.2.elim (λ hp, or.inl hp) (λ hr, or.inr ⟨hq, hr⟩)),
  ..sprop.semilattice_inf,
  ..sprop.semilattice_sup,
}

instance : complete_semilattice_Inf sprop := {
  Inf := λ P, ⟨λ n, ∀ p : sprop, p ∈ P → p n, λ m n hmn h p hp, p.mono hmn (h p hp)⟩,
  Inf_le := λ P p hpP n hpn, hpn p hpP,
  le_Inf := λ P p hP n hpn q hqP, hP q hqP n hpn,
  ..sprop.distrib_lattice
}

instance : complete_semilattice_Sup sprop := {
  Sup := λ P, ⟨λ n, ∃ p : sprop, p ∈ P ∧ p n, λ m n hmn h,
    ⟨h.some, h.some_spec.1, h.some.mono hmn h.some_spec.2⟩⟩,
  le_Sup := λ P p hpP n hpn, ⟨p, hpP, hpn⟩,
  Sup_le := λ P p hP n hpn, hP hpn.some hpn.some_spec.1 n hpn.some_spec.2,
  ..sprop.distrib_lattice
}

instance : complete_lattice sprop := {
  top := ⟨λ n, true, λ n m hmn h, trivial⟩,
  bot := ⟨λ n, false, λ n m hmn h, h⟩,
  le_top := λ p n h, trivial,
  bot_le := λ p n h, false.rec _ h,
  ..sprop.distrib_lattice,
  ..sprop.complete_semilattice_Inf,
  ..sprop.complete_semilattice_Sup,
}

@[simp] lemma sprop.inf_apply {p q : sprop} {n : ℕ} : (p ⊓ q) n ↔ p n ∧ q n := iff.rfl
@[simp] lemma sprop.sup_apply {p q : sprop} {n : ℕ} : (p ⊔ q) n ↔ p n ∨ q n := iff.rfl

lemma sprop.inf_eq_at {p q r s : sprop} {n : ℕ} : p =[n] q → r =[n] s → p ⊓ r =[n] q ⊓ s :=
λ h₁ h₂ m hmn, and_congr (h₁ m hmn) (h₂ m hmn)

lemma sprop.sup_eq_at {p q r s : sprop} {n : ℕ} : p =[n] q → r =[n] s → p ⊔ r =[n] q ⊔ s :=
λ h₁ h₂ m hmn, or_congr (h₁ m hmn) (h₂ m hmn)

def sprop.incln (p q : sprop) (n : ℕ) := ∀ m ≤ n, p m → q m

notation p ` ⊆[`:50 n `] ` q:50 := p.incln q n


import analysis.p_series
import number_theory.arithmetic_function
import algebra.squarefree
import data.list.intervals
import tactic
import measure_theory.integral.interval_integral
import analysis.special_functions.integrals

noncomputable theory
open nat finset list finsupp set function filter measure_theory
open_locale topological_space interval big_operators filter ennreal asymptotics

------ These are unused in the proof but may be useful to include in mathlib
lemma ceil_succ_mem_Icc_of_mem_Ico {R : Type*} [linear_ordered_semiring R] [floor_semiring R]
  {a b : ℕ} {x : R} (hx : x ∈ set.Ico (a : R) ↑b) :
  (⌊x⌋₊ : R) + 1 ∈ set.Icc (a : R) ↑b :=
begin
  rw set.mem_Ico at hx,
  rw set.mem_Icc,
  norm_cast,
  have zero_le_x := le_trans (nat.cast_le.mpr $ zero_le a) hx.left,
  split,
  { exact le_trans ((nat.le_floor_iff zero_le_x).mpr hx.left) (le_succ ⌊x⌋₊), },
  { have := calc ↑⌊x⌋₊ ≤ x : floor_le zero_le_x ... < b : hx.right,
    norm_cast at this,
    exact lt_iff_add_one_le.mp this, },
end

lemma ceil_succ_mem_Icc_of_mem_Ioo {R : Type*} [linear_ordered_semiring R] [floor_semiring R]
  {a b : ℕ} {x : R} (hx : x ∈ set.Ioo (a : R) ↑b) :
  (⌊x⌋₊ : R) + 1 ∈ set.Icc (a : R) ↑b := ceil_succ_mem_Icc_of_mem_Ico ⟨hx.left.le, hx.right⟩

lemma fooooo {x y : ℝ} {a b : ℕ} {f : ℝ → ℝ}  (hxy : x ≤ y)
  (hf : antitone_on f (set.Icc (a : ℝ) ↑b))
  (hx : x ∈ set.Icc (a : ℝ) ↑b) (hy : y ∈ set.Icc (a : ℝ) ↑b) :
  ite (⌊y⌋₊ + 1 ≤ b) (f ↑(⌊y⌋₊ + 1)) (f ↑b) ≤ ite (⌊x⌋₊ + 1 ≤ b) (f ↑(⌊x⌋₊ + 1)) (f ↑b) :=
begin
  have hx_nonneg : 0 ≤ x, calc (0 : ℝ) ≤ a : cast_nonneg a ... ≤ x : hx.left,
  have hy_nonneg : 0 ≤ y, calc (0 : ℝ) ≤ a : cast_nonneg a ... ≤ y : hy.left,
  by_cases hy' : y = b,
  { simp only [floor_coe, hy', add_le_iff_nonpos_right, _root_.le_zero_iff, nat.one_ne_zero, cast_add, cast_one, if_false],
    by_cases hx' : x = b,
    { simp only [floor_coe, hx', add_le_iff_nonpos_right, _root_.le_zero_iff, nat.one_ne_zero, cast_add, cast_one, if_false], },
    { let foo := lt_of_le_of_ne hx.right hx',
      let bar := succ_le_iff.mpr ((floor_lt hx_nonneg).mpr foo),
      simp only [bar, if_true],
      apply hf,
      { split,
        { calc (a : ℝ) ≤ ⌊x⌋₊ : cast_le.mpr (le_floor hx.left) ... ≤ ⌊x⌋₊ + 1 : by linarith },
        { exact cast_le.mpr bar, }, },
      { exact mem_of_eq_of_mem (eq.symm hy') hy, },
      { norm_cast, exact bar, }, }, },
  { have hy'' : y < b, exact lt_of_le_of_ne hy.right hy',
    have hx'' : x < b, calc x ≤ y : hxy ... < b : hy'',

    have aa : ⌊y⌋₊ + 1 ≤ b, exact succ_le_iff.mpr ((floor_lt hy_nonneg).mpr hy''),
    have cc : ⌊x⌋₊ + 1 ≤ ⌊y⌋₊ + 1, linarith [floor_mono hxy],
    have bb : ⌊x⌋₊ + 1 ≤ b, exact succ_le_iff.mpr ((floor_lt hx_nonneg).mpr hx''),
    simp only [aa, bb, cast_add, cast_one, if_true],
    apply hf,
    { exact ceil_succ_mem_Icc_of_mem_Ico ⟨hx.left, hx''⟩, },
    { exact ceil_succ_mem_Icc_of_mem_Ico ⟨hy.left, hy''⟩, },
    { norm_cast, exact cc, }, },
end

/- Not actually used in proof but a reasonable lemma for showing how to deal with integrals -/
lemma blahblah {a b c d : ℝ} {f : ℝ → ℝ}
  (hf : interval_integrable f real.measure_space.volume a b)
  (hac : a ≤ c) (hcd : c ≤ d) (hdb : d ≤ b) :
  interval_integrable f real.measure_space.volume c d :=
begin
  rw interval_integrable_iff,
  apply integrable_on.mono_set hf.left,
  rw interval_oc_of_le hcd,
  exact Ioc_subset_Ioc hac hdb,
end


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

! This file was ported from Lean 3 source module linear_algebra.quadratic_form.basic
! leanprover-community/mathlib commit 11b92770e4d49ff3982504c4dab918ac0887fe33
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Invertible
import Mathbin.LinearAlgebra.Matrix.Determinant
import Mathbin.LinearAlgebra.Matrix.BilinearForm
import Mathbin.LinearAlgebra.Matrix.Symmetric

/-!
# Quadratic forms

This file defines quadratic forms over a `R`-module `M`.
A quadratic form on a ring `R` is a map `Q : M → R` such that:
* `quadratic_form.map_smul`: `Q (a • x) = a * a * Q x`
* `quadratic_form.polar_add_left`, `quadratic_form.polar_add_right`,
  `quadratic_form.polar_smul_left`, `quadratic_form.polar_smul_right`:
  the map `quadratic_form.polar Q := λ x y, Q (x + y) - Q x - Q y` is bilinear.

This notion generalizes to semirings using the approach in [izhakian2016][] which requires that
there be a (possibly non-unique) companion bilinear form `B` such that
`∀ x y, Q (x + y) = Q x + Q y + B x y`. Over a ring, this `B` is precisely `quadratic_form.polar Q`.

To build a `quadratic_form` from the `polar` axioms, use `quadratic_form.of_polar`.

Quadratic forms come with a scalar multiplication, `(a • Q) x = Q (a • x) = a * a * Q x`,
and composition with linear maps `f`, `Q.comp f x = Q (f x)`.

## Main definitions

 * `quadratic_form.of_polar`: a more familiar constructor that works on rings
 * `quadratic_form.associated`: associated bilinear form
 * `quadratic_form.pos_def`: positive definite quadratic forms
 * `quadratic_form.anisotropic`: anisotropic quadratic forms
 * `quadratic_form.discr`: discriminant of a quadratic form

## Main statements

 * `quadratic_form.associated_left_inverse`,
 * `quadratic_form.associated_right_inverse`: in a commutative ring where 2 has
  an inverse, there is a correspondence between quadratic forms and symmetric
  bilinear forms
 * `bilin_form.exists_orthogonal_basis`: There exists an orthogonal basis with
  respect to any nondegenerate, symmetric bilinear form `B`.

## Notation

In this file, the variable `R` is used when a `ring` structure is sufficient and
`R₁` is used when specifically a `comm_ring` is required. This allows us to keep
`[module R M]` and `[module R₁ M]` assumptions in the variables without
confusion between `*` from `ring` and `*` from `comm_ring`.

The variable `S` is used when `R` itself has a `•` action.

## References

 * https://en.wikipedia.org/wiki/Quadratic_form
 * https://en.wikipedia.org/wiki/Discriminant#Quadratic_forms

## Tags

quadratic form, homogeneous polynomial, quadratic polynomial
-/

universe u v w

variable {S : Type _}

variable {R R₁ : Type _} {M : Type _}

open BigOperators

section Polar

variable [Ring R] [CommRing R₁] [AddCommGroup M]

namespace QuadraticForm

/-- Up to a factor 2, `Q.polar` is the associated bilinear form for a quadratic form `Q`.

Source of this name: https://en.wikipedia.org/wiki/Quadratic_form#Generalization
-/
def polar (f : M → R) (x y : M) :=
  f (x + y) - f x - f y
#align quadratic_form.polar QuadraticForm.polar

theorem polar_add (f g : M → R) (x y : M) : polar (f + g) x y = polar f x y + polar g x y :=
  by
  simp only [polar, Pi.add_apply]
  abel
#align quadratic_form.polar_add QuadraticForm.polar_add

theorem polar_neg (f : M → R) (x y : M) : polar (-f) x y = -polar f x y := by
  simp only [polar, Pi.neg_apply, sub_eq_add_neg, neg_add]
#align quadratic_form.polar_neg QuadraticForm.polar_neg

theorem polar_smul [Monoid S] [DistribMulAction S R] (f : M → R) (s : S) (x y : M) :
    polar (s • f) x y = s • polar f x y := by simp only [polar, Pi.smul_apply, smul_sub]
#align quadratic_form.polar_smul QuadraticForm.polar_smul

theorem polar_comm (f : M → R) (x y : M) : polar f x y = polar f y x := by
  rw [polar, polar, add_comm, sub_sub, sub_sub, add_comm (f x) (f y)]
#align quadratic_form.polar_comm QuadraticForm.polar_comm

/-- Auxiliary lemma to express bilinearity of `quadratic_form.polar` without subtraction. -/
theorem polar_add_left_iff {f : M → R} {x x' y : M} :
    polar f (x + x') y = polar f x y + polar f x' y ↔
      f (x + x' + y) + (f x + f x' + f y) = f (x + x') + f (x' + y) + f (y + x) :=
  by
  simp only [← add_assoc]
  simp only [polar, sub_eq_iff_eq_add, eq_sub_iff_add_eq, sub_add_eq_add_sub, add_sub]
  simp only [add_right_comm _ (f y) _, add_right_comm _ (f x') (f x)]
  rw [add_comm y x, add_right_comm _ _ (f (x + y)), add_comm _ (f (x + y)),
    add_right_comm (f (x + y)), add_left_inj]
#align quadratic_form.polar_add_left_iff QuadraticForm.polar_add_left_iff

theorem polar_comp {F : Type _} [Ring S] [AddMonoidHomClass F R S] (f : M → R) (g : F) (x y : M) :
    polar (g ∘ f) x y = g (polar f x y) := by
  simp only [polar, Pi.smul_apply, Function.comp_apply, map_sub]
#align quadratic_form.polar_comp QuadraticForm.polar_comp

end QuadraticForm

end Polar

/-- A quadratic form over a module.

For a more familiar constructor when `R` is a ring, see `quadratic_form.of_polar`. -/
structure QuadraticForm (R : Type u) (M : Type v) [Semiring R] [AddCommMonoid M] [Module R M] where
  toFun : M → R
  toFun_smul : ∀ (a : R) (x : M), to_fun (a • x) = a * a * to_fun x
  exists_companion' : ∃ B : BilinForm R M, ∀ x y, to_fun (x + y) = to_fun x + to_fun y + B x y
#align quadratic_form QuadraticForm

namespace QuadraticForm

section FunLike

variable [Semiring R] [AddCommMonoid M] [Module R M]

variable {Q Q' : QuadraticForm R M}

instance funLike : FunLike (QuadraticForm R M) M fun _ => R
    where
  coe := toFun
  coe_injective' x y h := by cases x <;> cases y <;> congr
#align quadratic_form.fun_like QuadraticForm.funLike

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
instance : CoeFun (QuadraticForm R M) fun _ => M → R :=
  ⟨toFun⟩

variable (Q)

/-- The `simp` normal form for a quadratic form is `coe_fn`, not `to_fun`. -/
@[simp]
theorem toFun_eq_coe : Q.toFun = ⇑Q :=
  rfl
#align quadratic_form.to_fun_eq_coe QuadraticForm.toFun_eq_coe

-- this must come after the coe_to_fun definition
initialize_simps_projections QuadraticForm (toFun → apply)

variable {Q}

@[ext]
theorem ext (H : ∀ x : M, Q x = Q' x) : Q = Q' :=
  FunLike.ext _ _ H
#align quadratic_form.ext QuadraticForm.ext

theorem congr_fun (h : Q = Q') (x : M) : Q x = Q' x :=
  FunLike.congr_fun h _
#align quadratic_form.congr_fun QuadraticForm.congr_fun

theorem ext_iff : Q = Q' ↔ ∀ x, Q x = Q' x :=
  FunLike.ext_iff
#align quadratic_form.ext_iff QuadraticForm.ext_iff

/-- Copy of a `quadratic_form` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (Q : QuadraticForm R M) (Q' : M → R) (h : Q' = ⇑Q) : QuadraticForm R M
    where
  toFun := Q'
  toFun_smul := h.symm ▸ Q.toFun_smul
  exists_companion' := h.symm ▸ Q.exists_companion'
#align quadratic_form.copy QuadraticForm.copy

@[simp]
theorem coe_copy (Q : QuadraticForm R M) (Q' : M → R) (h : Q' = ⇑Q) : ⇑(Q.copy Q' h) = Q' :=
  rfl
#align quadratic_form.coe_copy QuadraticForm.coe_copy

theorem copy_eq (Q : QuadraticForm R M) (Q' : M → R) (h : Q' = ⇑Q) : Q.copy Q' h = Q :=
  FunLike.ext' h
#align quadratic_form.copy_eq QuadraticForm.copy_eq

end FunLike

section Semiring

variable [Semiring R] [AddCommMonoid M] [Module R M]

variable (Q : QuadraticForm R M)

theorem map_smul (a : R) (x : M) : Q (a • x) = a * a * Q x :=
  Q.toFun_smul a x
#align quadratic_form.map_smul QuadraticForm.map_smul

theorem exists_companion : ∃ B : BilinForm R M, ∀ x y, Q (x + y) = Q x + Q y + B x y :=
  Q.exists_companion'
#align quadratic_form.exists_companion QuadraticForm.exists_companion

theorem map_add_add_add_map (x y z : M) :
    Q (x + y + z) + (Q x + Q y + Q z) = Q (x + y) + Q (y + z) + Q (z + x) :=
  by
  obtain ⟨B, h⟩ := Q.exists_companion
  rw [add_comm z x]
  simp [h]
  abel
#align quadratic_form.map_add_add_add_map QuadraticForm.map_add_add_add_map

theorem map_add_self (x : M) : Q (x + x) = 4 * Q x :=
  by
  rw [← one_smul R x, ← add_smul, map_smul]
  norm_num
#align quadratic_form.map_add_self QuadraticForm.map_add_self

@[simp]
theorem map_zero : Q 0 = 0 := by
  rw [← @zero_smul R _ _ _ _ (0 : M), map_smul, MulZeroClass.zero_mul, MulZeroClass.zero_mul]
#align quadratic_form.map_zero QuadraticForm.map_zero

instance zeroHomClass : ZeroHomClass (QuadraticForm R M) M R :=
  { QuadraticForm.funLike with map_zero := map_zero }
#align quadratic_form.zero_hom_class QuadraticForm.zeroHomClass

theorem map_smul_of_tower [CommSemiring S] [Algebra S R] [Module S M] [IsScalarTower S R M] (a : S)
    (x : M) : Q (a • x) = (a * a) • Q x := by
  rw [← IsScalarTower.algebraMap_smul R a x, map_smul, ← RingHom.map_mul, Algebra.smul_def]
#align quadratic_form.map_smul_of_tower QuadraticForm.map_smul_of_tower

end Semiring

section Ring

variable [Ring R] [CommRing R₁] [AddCommGroup M]

variable [Module R M] (Q : QuadraticForm R M)

@[simp]
theorem map_neg (x : M) : Q (-x) = Q x := by
  rw [← @neg_one_smul R _ _ _ _ x, map_smul, neg_one_mul, neg_neg, one_mul]
#align quadratic_form.map_neg QuadraticForm.map_neg

theorem map_sub (x y : M) : Q (x - y) = Q (y - x) := by rw [← neg_sub, map_neg]
#align quadratic_form.map_sub QuadraticForm.map_sub

@[simp]
theorem polar_zero_left (y : M) : polar Q 0 y = 0 := by
  simp only [polar, zero_add, QuadraticForm.map_zero, sub_zero, sub_self]
#align quadratic_form.polar_zero_left QuadraticForm.polar_zero_left

@[simp]
theorem polar_add_left (x x' y : M) : polar Q (x + x') y = polar Q x y + polar Q x' y :=
  polar_add_left_iff.mpr <| Q.map_add_add_add_map x x' y
#align quadratic_form.polar_add_left QuadraticForm.polar_add_left

@[simp]
theorem polar_smul_left (a : R) (x y : M) : polar Q (a • x) y = a * polar Q x y :=
  by
  obtain ⟨B, h⟩ := Q.exists_companion
  simp_rw [polar, h, Q.map_smul, BilinForm.smul_left, sub_sub, add_sub_cancel']
#align quadratic_form.polar_smul_left QuadraticForm.polar_smul_left

@[simp]
theorem polar_neg_left (x y : M) : polar Q (-x) y = -polar Q x y := by
  rw [← neg_one_smul R x, polar_smul_left, neg_one_mul]
#align quadratic_form.polar_neg_left QuadraticForm.polar_neg_left

@[simp]
theorem polar_sub_left (x x' y : M) : polar Q (x - x') y = polar Q x y - polar Q x' y := by
  rw [sub_eq_add_neg, sub_eq_add_neg, polar_add_left, polar_neg_left]
#align quadratic_form.polar_sub_left QuadraticForm.polar_sub_left

@[simp]
theorem polar_zero_right (y : M) : polar Q y 0 = 0 := by
  simp only [add_zero, polar, QuadraticForm.map_zero, sub_self]
#align quadratic_form.polar_zero_right QuadraticForm.polar_zero_right

@[simp]
theorem polar_add_right (x y y' : M) : polar Q x (y + y') = polar Q x y + polar Q x y' := by
  rw [polar_comm Q x, polar_comm Q x, polar_comm Q x, polar_add_left]
#align quadratic_form.polar_add_right QuadraticForm.polar_add_right

@[simp]
theorem polar_smul_right (a : R) (x y : M) : polar Q x (a • y) = a * polar Q x y := by
  rw [polar_comm Q x, polar_comm Q x, polar_smul_left]
#align quadratic_form.polar_smul_right QuadraticForm.polar_smul_right

@[simp]
theorem polar_neg_right (x y : M) : polar Q x (-y) = -polar Q x y := by
  rw [← neg_one_smul R y, polar_smul_right, neg_one_mul]
#align quadratic_form.polar_neg_right QuadraticForm.polar_neg_right

@[simp]
theorem polar_sub_right (x y y' : M) : polar Q x (y - y') = polar Q x y - polar Q x y' := by
  rw [sub_eq_add_neg, sub_eq_add_neg, polar_add_right, polar_neg_right]
#align quadratic_form.polar_sub_right QuadraticForm.polar_sub_right

@[simp]
theorem polar_self (x : M) : polar Q x x = 2 * Q x :=
  by
  rw [polar, map_add_self, sub_sub, sub_eq_iff_eq_add, ← two_mul, ← two_mul, ← mul_assoc]
  norm_num
#align quadratic_form.polar_self QuadraticForm.polar_self

/-- `quadratic_form.polar` as a bilinear form -/
@[simps]
def polarBilin : BilinForm R M where
  bilin := polar Q
  bilin_add_left := polar_add_left Q
  bilin_smul_left := polar_smul_left Q
  bilin_add_right x y z := by simp_rw [polar_comm _ x, polar_add_left Q]
  bilin_smul_right r x y := by simp_rw [polar_comm _ x, polar_smul_left Q]
#align quadratic_form.polar_bilin QuadraticForm.polarBilin

variable [CommSemiring S] [Algebra S R] [Module S M] [IsScalarTower S R M]

@[simp]
theorem polar_smul_left_of_tower (a : S) (x y : M) : polar Q (a • x) y = a • polar Q x y := by
  rw [← IsScalarTower.algebraMap_smul R a x, polar_smul_left, Algebra.smul_def]
#align quadratic_form.polar_smul_left_of_tower QuadraticForm.polar_smul_left_of_tower

@[simp]
theorem polar_smul_right_of_tower (a : S) (x y : M) : polar Q x (a • y) = a • polar Q x y := by
  rw [← IsScalarTower.algebraMap_smul R a y, polar_smul_right, Algebra.smul_def]
#align quadratic_form.polar_smul_right_of_tower QuadraticForm.polar_smul_right_of_tower

/-- An alternative constructor to `quadratic_form.mk`, for rings where `polar` can be used. -/
@[simps]
def ofPolar (to_fun : M → R) (to_fun_smul : ∀ (a : R) (x : M), to_fun (a • x) = a * a * to_fun x)
    (polar_add_left : ∀ x x' y : M, polar to_fun (x + x') y = polar to_fun x y + polar to_fun x' y)
    (polar_smul_left : ∀ (a : R) (x y : M), polar to_fun (a • x) y = a • polar to_fun x y) :
    QuadraticForm R M :=
  { toFun
    toFun_smul
    exists_companion' :=
      ⟨{  bilin := polar to_fun
          bilin_add_left := polar_add_left
          bilin_smul_left := polar_smul_left
          bilin_add_right := fun x y z => by simp_rw [polar_comm _ x, polar_add_left]
          bilin_smul_right := fun r x y => by
            simp_rw [polar_comm _ x, polar_smul_left, smul_eq_mul] },
        fun x y => by rw [BilinForm.coeFn_mk, polar, sub_sub, add_sub_cancel'_right]⟩ }
#align quadratic_form.of_polar QuadraticForm.ofPolar

/-- In a ring the companion bilinear form is unique and equal to `quadratic_form.polar`. -/
theorem choose_exists_companion : Q.exists_companion.some = polarBilin Q :=
  BilinForm.ext fun x y => by
    rw [polar_bilin_apply, polar, Q.exists_companion.some_spec, sub_sub, add_sub_cancel']
#align quadratic_form.some_exists_companion QuadraticForm.choose_exists_companion

end Ring

section SemiringOperators

variable [Semiring R] [AddCommMonoid M] [Module R M]

section SMul

variable [Monoid S] [DistribMulAction S R] [SMulCommClass S R R]

/-- `quadratic_form R M` inherits the scalar action from any algebra over `R`.

When `R` is commutative, this provides an `R`-action via `algebra.id`. -/
instance : SMul S (QuadraticForm R M) :=
  ⟨fun a Q =>
    { toFun := a • Q
      toFun_smul := fun b x => by rw [Pi.smul_apply, map_smul, Pi.smul_apply, mul_smul_comm]
      exists_companion' :=
        let ⟨B, h⟩ := Q.exists_companion
        ⟨a • B, by simp [h]⟩ }⟩

@[simp]
theorem coeFn_smul (a : S) (Q : QuadraticForm R M) : ⇑(a • Q) = a • Q :=
  rfl
#align quadratic_form.coe_fn_smul QuadraticForm.coeFn_smul

@[simp]
theorem smul_apply (a : S) (Q : QuadraticForm R M) (x : M) : (a • Q) x = a • Q x :=
  rfl
#align quadratic_form.smul_apply QuadraticForm.smul_apply

end SMul

instance : Zero (QuadraticForm R M) :=
  ⟨{  toFun := fun x => 0
      toFun_smul := fun a x => by simp only [MulZeroClass.mul_zero]
      exists_companion' := ⟨0, fun x y => by simp only [add_zero, BilinForm.zero_apply]⟩ }⟩

@[simp]
theorem coeFn_zero : ⇑(0 : QuadraticForm R M) = 0 :=
  rfl
#align quadratic_form.coe_fn_zero QuadraticForm.coeFn_zero

@[simp]
theorem zero_apply (x : M) : (0 : QuadraticForm R M) x = 0 :=
  rfl
#align quadratic_form.zero_apply QuadraticForm.zero_apply

instance : Inhabited (QuadraticForm R M) :=
  ⟨0⟩

instance : Add (QuadraticForm R M) :=
  ⟨fun Q Q' =>
    { toFun := Q + Q'
      toFun_smul := fun a x => by simp only [Pi.add_apply, map_smul, mul_add]
      exists_companion' :=
        let ⟨B, h⟩ := Q.exists_companion
        let ⟨B', h'⟩ := Q'.exists_companion
        ⟨B + B', fun x y => by
          simp_rw [Pi.add_apply, h, h', BilinForm.add_apply, add_add_add_comm]⟩ }⟩

@[simp]
theorem coeFn_add (Q Q' : QuadraticForm R M) : ⇑(Q + Q') = Q + Q' :=
  rfl
#align quadratic_form.coe_fn_add QuadraticForm.coeFn_add

@[simp]
theorem add_apply (Q Q' : QuadraticForm R M) (x : M) : (Q + Q') x = Q x + Q' x :=
  rfl
#align quadratic_form.add_apply QuadraticForm.add_apply

instance : AddCommMonoid (QuadraticForm R M) :=
  FunLike.coe_injective.AddCommMonoid _ coeFn_zero coeFn_add fun _ _ => coeFn_smul _ _

/-- `@coe_fn (quadratic_form R M)` as an `add_monoid_hom`.

This API mirrors `add_monoid_hom.coe_fn`. -/
@[simps apply]
def coeFnAddMonoidHom : QuadraticForm R M →+ M → R
    where
  toFun := coeFn
  map_zero' := coeFn_zero
  map_add' := coeFn_add
#align quadratic_form.coe_fn_add_monoid_hom QuadraticForm.coeFnAddMonoidHom

/-- Evaluation on a particular element of the module `M` is an additive map over quadratic forms. -/
@[simps apply]
def evalAddMonoidHom (m : M) : QuadraticForm R M →+ R :=
  (Pi.evalAddMonoidHom _ m).comp coeFnAddMonoidHom
#align quadratic_form.eval_add_monoid_hom QuadraticForm.evalAddMonoidHom

section Sum

@[simp]
theorem coeFn_sum {ι : Type _} (Q : ι → QuadraticForm R M) (s : Finset ι) :
    ⇑(∑ i in s, Q i) = ∑ i in s, Q i :=
  (coeFnAddMonoidHom : _ →+ M → R).map_sum Q s
#align quadratic_form.coe_fn_sum QuadraticForm.coeFn_sum

@[simp]
theorem sum_apply {ι : Type _} (Q : ι → QuadraticForm R M) (s : Finset ι) (x : M) :
    (∑ i in s, Q i) x = ∑ i in s, Q i x :=
  (evalAddMonoidHom x : _ →+ R).map_sum Q s
#align quadratic_form.sum_apply QuadraticForm.sum_apply

end Sum

instance [Monoid S] [DistribMulAction S R] [SMulCommClass S R R] :
    DistribMulAction S (QuadraticForm R M)
    where
  mul_smul a b Q := ext fun x => by simp only [smul_apply, mul_smul]
  one_smul Q := ext fun x => by simp only [QuadraticForm.smul_apply, one_smul]
  smul_add a Q Q' := by
    ext
    simp only [add_apply, smul_apply, smul_add]
  smul_zero a := by
    ext
    simp only [zero_apply, smul_apply, smul_zero]

instance [Semiring S] [Module S R] [SMulCommClass S R R] : Module S (QuadraticForm R M)
    where
  zero_smul Q := by
    ext
    simp only [zero_apply, smul_apply, zero_smul]
  add_smul a b Q := by
    ext
    simp only [add_apply, smul_apply, add_smul]

end SemiringOperators

section RingOperators

variable [Ring R] [AddCommGroup M] [Module R M]

instance : Neg (QuadraticForm R M) :=
  ⟨fun Q =>
    { toFun := -Q
      toFun_smul := fun a x => by simp only [Pi.neg_apply, map_smul, mul_neg]
      exists_companion' :=
        let ⟨B, h⟩ := Q.exists_companion
        ⟨-B, fun x y => by simp_rw [Pi.neg_apply, h, BilinForm.neg_apply, neg_add]⟩ }⟩

@[simp]
theorem coeFn_neg (Q : QuadraticForm R M) : ⇑(-Q) = -Q :=
  rfl
#align quadratic_form.coe_fn_neg QuadraticForm.coeFn_neg

@[simp]
theorem neg_apply (Q : QuadraticForm R M) (x : M) : (-Q) x = -Q x :=
  rfl
#align quadratic_form.neg_apply QuadraticForm.neg_apply

instance : Sub (QuadraticForm R M) :=
  ⟨fun Q Q' => (Q + -Q').copy (Q - Q') (sub_eq_add_neg _ _)⟩

@[simp]
theorem coeFn_sub (Q Q' : QuadraticForm R M) : ⇑(Q - Q') = Q - Q' :=
  rfl
#align quadratic_form.coe_fn_sub QuadraticForm.coeFn_sub

@[simp]
theorem sub_apply (Q Q' : QuadraticForm R M) (x : M) : (Q - Q') x = Q x - Q' x :=
  rfl
#align quadratic_form.sub_apply QuadraticForm.sub_apply

instance : AddCommGroup (QuadraticForm R M) :=
  FunLike.coe_injective.AddCommGroup _ coeFn_zero coeFn_add coeFn_neg coeFn_sub
    (fun _ _ => coeFn_smul _ _) fun _ _ => coeFn_smul _ _

end RingOperators

section Comp

variable [Semiring R] [AddCommMonoid M] [Module R M]

variable {N : Type v} [AddCommMonoid N] [Module R N]

/-- Compose the quadratic form with a linear function. -/
def comp (Q : QuadraticForm R N) (f : M →ₗ[R] N) : QuadraticForm R M
    where
  toFun x := Q (f x)
  toFun_smul a x := by simp only [map_smul, f.map_smul]
  exists_companion' :=
    let ⟨B, h⟩ := Q.exists_companion
    ⟨B.comp f f, fun x y => by simp_rw [f.map_add, h, BilinForm.comp_apply]⟩
#align quadratic_form.comp QuadraticForm.comp

@[simp]
theorem comp_apply (Q : QuadraticForm R N) (f : M →ₗ[R] N) (x : M) : (Q.comp f) x = Q (f x) :=
  rfl
#align quadratic_form.comp_apply QuadraticForm.comp_apply

/-- Compose a quadratic form with a linear function on the left. -/
@[simps (config := { simpRhs := true })]
def LinearMap.compQuadraticForm {S : Type _} [CommSemiring S] [Algebra S R] [Module S M]
    [IsScalarTower S R M] (f : R →ₗ[S] S) (Q : QuadraticForm R M) : QuadraticForm S M
    where
  toFun x := f (Q x)
  toFun_smul b x := by rw [Q.map_smul_of_tower b x, f.map_smul, smul_eq_mul]
  exists_companion' :=
    let ⟨B, h⟩ := Q.exists_companion
    ⟨f.compBilinForm B, fun x y => by simp_rw [h, f.map_add, LinearMap.compBilinForm_apply]⟩
#align linear_map.comp_quadratic_form LinearMap.compQuadraticForm

end Comp

section CommRing

variable [CommSemiring R] [AddCommMonoid M] [Module R M]

/-- The product of linear forms is a quadratic form. -/
def linMulLin (f g : M →ₗ[R] R) : QuadraticForm R M
    where
  toFun := f * g
  toFun_smul a x :=
    by
    simp only [smul_eq_mul, RingHom.id_apply, Pi.mul_apply, LinearMap.map_smulₛₗ]
    ring
  exists_companion' :=
    ⟨BilinForm.linMulLin f g + BilinForm.linMulLin g f, fun x y =>
      by
      simp
      ring⟩
#align quadratic_form.lin_mul_lin QuadraticForm.linMulLin

@[simp]
theorem linMulLin_apply (f g : M →ₗ[R] R) (x) : linMulLin f g x = f x * g x :=
  rfl
#align quadratic_form.lin_mul_lin_apply QuadraticForm.linMulLin_apply

@[simp]
theorem add_linMulLin (f g h : M →ₗ[R] R) : linMulLin (f + g) h = linMulLin f h + linMulLin g h :=
  ext fun x => add_mul _ _ _
#align quadratic_form.add_lin_mul_lin QuadraticForm.add_linMulLin

@[simp]
theorem linMulLin_add (f g h : M →ₗ[R] R) : linMulLin f (g + h) = linMulLin f g + linMulLin f h :=
  ext fun x => mul_add _ _ _
#align quadratic_form.lin_mul_lin_add QuadraticForm.linMulLin_add

variable {N : Type v} [AddCommMonoid N] [Module R N]

@[simp]
theorem linMulLin_comp (f g : M →ₗ[R] R) (h : N →ₗ[R] M) :
    (linMulLin f g).comp h = linMulLin (f.comp h) (g.comp h) :=
  rfl
#align quadratic_form.lin_mul_lin_comp QuadraticForm.linMulLin_comp

variable {n : Type _}

/-- `sq` is the quadratic form mapping the vector `x : R₁` to `x * x` -/
@[simps]
def sq : QuadraticForm R R :=
  linMulLin LinearMap.id LinearMap.id
#align quadratic_form.sq QuadraticForm.sq

/-- `proj i j` is the quadratic form mapping the vector `x : n → R₁` to `x i * x j` -/
def proj (i j : n) : QuadraticForm R (n → R) :=
  linMulLin (@LinearMap.proj _ _ _ (fun _ => R) _ _ i) (@LinearMap.proj _ _ _ (fun _ => R) _ _ j)
#align quadratic_form.proj QuadraticForm.proj

@[simp]
theorem proj_apply (i j : n) (x : n → R) : proj i j x = x i * x j :=
  rfl
#align quadratic_form.proj_apply QuadraticForm.proj_apply

end CommRing

end QuadraticForm

/-!
### Associated bilinear forms

Over a commutative ring with an inverse of 2, the theory of quadratic forms is
basically identical to that of symmetric bilinear forms. The map from quadratic
forms to bilinear forms giving this identification is called the `associated`
quadratic form.
-/

namespace BilinForm

open QuadraticForm

section Semiring

variable [Semiring R] [AddCommMonoid M] [Module R M]

variable {B : BilinForm R M}

/-- A bilinear form gives a quadratic form by applying the argument twice. -/
def toQuadraticForm (B : BilinForm R M) : QuadraticForm R M
    where
  toFun x := B x x
  toFun_smul a x := by simp only [mul_assoc, smul_right, smul_left]
  exists_companion' := ⟨B + BilinForm.flipHom ℕ B, fun x y => by simp [add_add_add_comm, add_comm]⟩
#align bilin_form.to_quadratic_form BilinForm.toQuadraticForm

@[simp]
theorem toQuadraticForm_apply (B : BilinForm R M) (x : M) : B.toQuadraticForm x = B x x :=
  rfl
#align bilin_form.to_quadratic_form_apply BilinForm.toQuadraticForm_apply

section

variable (R M)

@[simp]
theorem toQuadraticForm_zero : (0 : BilinForm R M).toQuadraticForm = 0 :=
  rfl
#align bilin_form.to_quadratic_form_zero BilinForm.toQuadraticForm_zero

end

@[simp]
theorem toQuadraticForm_add (B₁ B₂ : BilinForm R M) :
    (B₁ + B₂).toQuadraticForm = B₁.toQuadraticForm + B₂.toQuadraticForm :=
  rfl
#align bilin_form.to_quadratic_form_add BilinForm.toQuadraticForm_add

@[simp]
theorem toQuadraticForm_smul [Monoid S] [DistribMulAction S R] [SMulCommClass S R R] (a : S)
    (B : BilinForm R M) : (a • B).toQuadraticForm = a • B.toQuadraticForm :=
  rfl
#align bilin_form.to_quadratic_form_smul BilinForm.toQuadraticForm_smul

section

variable (R M)

/-- `bilin_form.to_quadratic_form` as an additive homomorphism -/
@[simps]
def toQuadraticFormAddMonoidHom : BilinForm R M →+ QuadraticForm R M
    where
  toFun := toQuadraticForm
  map_zero' := toQuadraticForm_zero _ _
  map_add' := toQuadraticForm_add
#align bilin_form.to_quadratic_form_add_monoid_hom BilinForm.toQuadraticFormAddMonoidHom

end

@[simp]
theorem toQuadraticForm_list_sum (B : List (BilinForm R M)) :
    B.Sum.toQuadraticForm = (B.map toQuadraticForm).Sum :=
  map_list_sum (toQuadraticFormAddMonoidHom R M) B
#align bilin_form.to_quadratic_form_list_sum BilinForm.toQuadraticForm_list_sum

@[simp]
theorem toQuadraticForm_multiset_sum (B : Multiset (BilinForm R M)) :
    B.Sum.toQuadraticForm = (B.map toQuadraticForm).Sum :=
  map_multiset_sum (toQuadraticFormAddMonoidHom R M) B
#align bilin_form.to_quadratic_form_multiset_sum BilinForm.toQuadraticForm_multiset_sum

@[simp]
theorem toQuadraticForm_sum {ι : Type _} (s : Finset ι) (B : ι → BilinForm R M) :
    (∑ i in s, B i).toQuadraticForm = ∑ i in s, (B i).toQuadraticForm :=
  map_sum (toQuadraticFormAddMonoidHom R M) B s
#align bilin_form.to_quadratic_form_sum BilinForm.toQuadraticForm_sum

@[simp]
theorem toQuadraticForm_eq_zero {B : BilinForm R M} : B.toQuadraticForm = 0 ↔ B.IsAlt :=
  QuadraticForm.ext_iff
#align bilin_form.to_quadratic_form_eq_zero BilinForm.toQuadraticForm_eq_zero

end Semiring

section Ring

variable [Ring R] [AddCommGroup M] [Module R M]

variable {B : BilinForm R M}

theorem polar_to_quadratic_form (x y : M) : polar (fun x => B x x) x y = B x y + B y x := by
  simp only [add_assoc, add_sub_cancel', add_right, polar, add_left_inj, add_neg_cancel_left,
    add_left, sub_eq_add_neg _ (B y y), add_comm (B y x) _]
#align bilin_form.polar_to_quadratic_form BilinForm.polar_to_quadratic_form

@[simp]
theorem toQuadraticForm_neg (B : BilinForm R M) : (-B).toQuadraticForm = -B.toQuadraticForm :=
  rfl
#align bilin_form.to_quadratic_form_neg BilinForm.toQuadraticForm_neg

@[simp]
theorem toQuadraticForm_sub (B₁ B₂ : BilinForm R M) :
    (B₁ - B₂).toQuadraticForm = B₁.toQuadraticForm - B₂.toQuadraticForm :=
  rfl
#align bilin_form.to_quadratic_form_sub BilinForm.toQuadraticForm_sub

end Ring

end BilinForm

namespace QuadraticForm

open BilinForm

section AssociatedHom

variable [Ring R] [CommRing R₁] [AddCommGroup M] [Module R M] [Module R₁ M]

variable (S) [CommSemiring S] [Algebra S R]

variable [Invertible (2 : R)] {B₁ : BilinForm R M}

/-- `associated_hom` is the map that sends a quadratic form on a module `M` over `R` to its
associated symmetric bilinear form.  As provided here, this has the structure of an `S`-linear map
where `S` is a commutative subring of `R`.

Over a commutative ring, use `associated`, which gives an `R`-linear map.  Over a general ring with
no nontrivial distinguished commutative subring, use `associated'`, which gives an additive
homomorphism (or more precisely a `ℤ`-linear map.) -/
def associatedHom : QuadraticForm R M →ₗ[S] BilinForm R M
    where
  toFun Q :=
    ((· • ·) : Submonoid.center R → BilinForm R M → BilinForm R M)
      ⟨⅟ 2, fun x => (Commute.one_right x).bit0_right.invOf_right⟩ Q.polarBilin
  map_add' Q Q' := by
    ext
    simp only [BilinForm.add_apply, BilinForm.smul_apply, [anonymous], polar_bilin_apply, polar_add,
      coe_fn_add, smul_add]
  map_smul' s Q := by
    ext
    simp only [RingHom.id_apply, polar_smul, smul_comm s, polar_bilin_apply, [anonymous],
      coe_fn_smul, BilinForm.smul_apply]
#align quadratic_form.associated_hom QuadraticForm.associatedHom

variable (Q : QuadraticForm R M) (S)

@[simp]
theorem associated_apply (x y : M) : associatedHom S Q x y = ⅟ 2 * (Q (x + y) - Q x - Q y) :=
  rfl
#align quadratic_form.associated_apply QuadraticForm.associated_apply

theorem associatedIsSymm : (associatedHom S Q).IsSymm := fun x y => by
  simp only [associated_apply, add_comm, add_left_comm, sub_eq_add_neg]
#align quadratic_form.associated_is_symm QuadraticForm.associatedIsSymm

@[simp]
theorem associated_comp {N : Type v} [AddCommGroup N] [Module R N] (f : N →ₗ[R] M) :
    associatedHom S (Q.comp f) = (associatedHom S Q).comp f f :=
  by
  ext
  simp only [QuadraticForm.comp_apply, BilinForm.comp_apply, associated_apply, LinearMap.map_add]
#align quadratic_form.associated_comp QuadraticForm.associated_comp

theorem associated_toQuadraticForm (B : BilinForm R M) (x y : M) :
    associatedHom S B.toQuadraticForm x y = ⅟ 2 * (B x y + B y x) := by
  simp only [associated_apply, ← polar_to_quadratic_form, polar, to_quadratic_form_apply]
#align quadratic_form.associated_to_quadratic_form QuadraticForm.associated_toQuadraticForm

theorem associated_left_inverse (h : B₁.IsSymm) : associatedHom S B₁.toQuadraticForm = B₁ :=
  BilinForm.ext fun x y => by
    rw [associated_to_quadratic_form, is_symm.eq h x y, ← two_mul, ← mul_assoc, invOf_mul_self,
      one_mul]
#align quadratic_form.associated_left_inverse QuadraticForm.associated_left_inverse

theorem toQuadraticForm_associated : (associatedHom S Q).toQuadraticForm = Q :=
  QuadraticForm.ext fun x =>
    calc
      (associatedHom S Q).toQuadraticForm x = ⅟ 2 * (Q x + Q x) := by
        simp only [add_assoc, add_sub_cancel', one_mul, to_quadratic_form_apply, add_mul,
          associated_apply, map_add_self, bit0]
      _ = Q x := by rw [← two_mul (Q x), ← mul_assoc, invOf_mul_self, one_mul]

#align quadratic_form.to_quadratic_form_associated QuadraticForm.toQuadraticForm_associated

-- note: usually `right_inverse` lemmas are named the other way around, but this is consistent
-- with historical naming in this file.
theorem associated_rightInverse :
    Function.RightInverse (associatedHom S) (BilinForm.toQuadraticForm : _ → QuadraticForm R M) :=
  fun Q => toQuadraticForm_associated S Q
#align quadratic_form.associated_right_inverse QuadraticForm.associated_rightInverse

theorem associated_eq_self_apply (x : M) : associatedHom S Q x x = Q x :=
  by
  rw [associated_apply, map_add_self]
  suffices ⅟ 2 * (2 * Q x) = Q x by
    convert this
    simp only [bit0, add_mul, one_mul]
    abel
  simp only [← mul_assoc, one_mul, invOf_mul_self]
#align quadratic_form.associated_eq_self_apply QuadraticForm.associated_eq_self_apply

/-- `associated'` is the `ℤ`-linear map that sends a quadratic form on a module `M` over `R` to its
associated symmetric bilinear form. -/
abbrev associated' : QuadraticForm R M →ₗ[ℤ] BilinForm R M :=
  associatedHom ℤ
#align quadratic_form.associated' QuadraticForm.associated'

/-- Symmetric bilinear forms can be lifted to quadratic forms -/
instance canLift : CanLift (BilinForm R M) (QuadraticForm R M) (associatedHom ℕ) BilinForm.IsSymm
    where prf B hB := ⟨B.toQuadraticForm, associated_left_inverse _ hB⟩
#align quadratic_form.can_lift QuadraticForm.canLift

/-- There exists a non-null vector with respect to any quadratic form `Q` whose associated
bilinear form is non-zero, i.e. there exists `x` such that `Q x ≠ 0`. -/
theorem exists_quadraticForm_ne_zero {Q : QuadraticForm R M} (hB₁ : Q.associated' ≠ 0) :
    ∃ x, Q x ≠ 0 := by
  rw [← not_forall]
  intro h
  apply hB₁
  rw [(QuadraticForm.ext h : Q = 0), LinearMap.map_zero]
#align quadratic_form.exists_quadratic_form_ne_zero QuadraticForm.exists_quadraticForm_ne_zero

end AssociatedHom

section Associated

variable [CommRing R₁] [AddCommGroup M] [Module R₁ M]

variable [Invertible (2 : R₁)]

-- Note:  When possible, rather than writing lemmas about `associated`, write a lemma applying to
-- the more general `associated_hom` and place it in the previous section.
/-- `associated` is the linear map that sends a quadratic form over a commutative ring to its
associated symmetric bilinear form. -/
abbrev associated : QuadraticForm R₁ M →ₗ[R₁] BilinForm R₁ M :=
  associatedHom R₁
#align quadratic_form.associated QuadraticForm.associated

@[simp]
theorem associated_linMulLin (f g : M →ₗ[R₁] R₁) :
    (linMulLin f g).Associated = ⅟ (2 : R₁) • (BilinForm.linMulLin f g + BilinForm.linMulLin g f) :=
  by
  ext
  simp only [smul_add, Algebra.id.smul_eq_mul, BilinForm.linMulLin_apply,
    QuadraticForm.linMulLin_apply, BilinForm.smul_apply, associated_apply, BilinForm.add_apply,
    LinearMap.map_add]
  ring
#align quadratic_form.associated_lin_mul_lin QuadraticForm.associated_linMulLin

end Associated

section Anisotropic

section Semiring

variable [Semiring R] [AddCommMonoid M] [Module R M]

/-- An anisotropic quadratic form is zero only on zero vectors. -/
def Anisotropic (Q : QuadraticForm R M) : Prop :=
  ∀ x, Q x = 0 → x = 0
#align quadratic_form.anisotropic QuadraticForm.Anisotropic

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x «expr ≠ » 0) -/
theorem not_anisotropic_iff_exists (Q : QuadraticForm R M) :
    ¬Anisotropic Q ↔ ∃ (x : _)(_ : x ≠ 0), Q x = 0 := by
  simp only [anisotropic, not_forall, exists_prop, and_comm']
#align quadratic_form.not_anisotropic_iff_exists QuadraticForm.not_anisotropic_iff_exists

theorem Anisotropic.eq_zero_iff {Q : QuadraticForm R M} (h : Anisotropic Q) {x : M} :
    Q x = 0 ↔ x = 0 :=
  ⟨h x, fun h => h.symm ▸ map_zero Q⟩
#align quadratic_form.anisotropic.eq_zero_iff QuadraticForm.Anisotropic.eq_zero_iff

end Semiring

section Ring

variable [Ring R] [AddCommGroup M] [Module R M]

/-- The associated bilinear form of an anisotropic quadratic form is nondegenerate. -/
theorem nondegenerateOfAnisotropic [Invertible (2 : R)] (Q : QuadraticForm R M)
    (hB : Q.Anisotropic) : Q.associated'.Nondegenerate :=
  by
  intro x hx
  refine' hB _ _
  rw [← hx x]
  exact (associated_eq_self_apply _ _ x).symm
#align quadratic_form.nondegenerate_of_anisotropic QuadraticForm.nondegenerateOfAnisotropic

end Ring

end Anisotropic

section PosDef

variable {R₂ : Type u} [OrderedRing R₂] [AddCommMonoid M] [Module R₂ M]

variable {Q₂ : QuadraticForm R₂ M}

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x «expr ≠ » 0) -/
/-- A positive definite quadratic form is positive on nonzero vectors. -/
def PosDef (Q₂ : QuadraticForm R₂ M) : Prop :=
  ∀ (x) (_ : x ≠ 0), 0 < Q₂ x
#align quadratic_form.pos_def QuadraticForm.PosDef

theorem PosDef.smul {R} [LinearOrderedCommRing R] [Module R M] {Q : QuadraticForm R M}
    (h : PosDef Q) {a : R} (a_pos : 0 < a) : PosDef (a • Q) := fun x hx => mul_pos a_pos (h x hx)
#align quadratic_form.pos_def.smul QuadraticForm.PosDef.smul

variable {n : Type _}

theorem PosDef.nonneg {Q : QuadraticForm R₂ M} (hQ : PosDef Q) (x : M) : 0 ≤ Q x :=
  (eq_or_ne x 0).elim (fun h => h.symm ▸ (map_zero Q).symm.le) fun h => (hQ _ h).le
#align quadratic_form.pos_def.nonneg QuadraticForm.PosDef.nonneg

theorem PosDef.anisotropic {Q : QuadraticForm R₂ M} (hQ : Q.PosDef) : Q.Anisotropic := fun x hQx =>
  by_contradiction fun hx =>
    lt_irrefl (0 : R₂) <| by
      have := hQ _ hx
      rw [hQx] at this
      exact this
#align quadratic_form.pos_def.anisotropic QuadraticForm.PosDef.anisotropic

theorem posDefOfNonneg {Q : QuadraticForm R₂ M} (h : ∀ x, 0 ≤ Q x) (h0 : Q.Anisotropic) :
    PosDef Q := fun x hx => lt_of_le_of_ne (h x) (Ne.symm fun hQx => hx <| h0 _ hQx)
#align quadratic_form.pos_def_of_nonneg QuadraticForm.posDefOfNonneg

theorem posDef_iff_nonneg {Q : QuadraticForm R₂ M} : PosDef Q ↔ (∀ x, 0 ≤ Q x) ∧ Q.Anisotropic :=
  ⟨fun h => ⟨h.NonNeg, h.Anisotropic⟩, fun ⟨n, a⟩ => posDefOfNonneg n a⟩
#align quadratic_form.pos_def_iff_nonneg QuadraticForm.posDef_iff_nonneg

theorem PosDef.add (Q Q' : QuadraticForm R₂ M) (hQ : PosDef Q) (hQ' : PosDef Q') :
    PosDef (Q + Q') := fun x hx => add_pos (hQ x hx) (hQ' x hx)
#align quadratic_form.pos_def.add QuadraticForm.PosDef.add

theorem linMulLinSelfPosDef {R} [LinearOrderedCommRing R] [Module R M] (f : M →ₗ[R] R)
    (hf : LinearMap.ker f = ⊥) : PosDef (linMulLin f f) := fun x hx =>
  mul_self_pos.2 fun h => hx <| LinearMap.ker_eq_bot'.mp hf _ h
#align quadratic_form.lin_mul_lin_self_pos_def QuadraticForm.linMulLinSelfPosDef

end PosDef

end QuadraticForm

section

/-!
### Quadratic forms and matrices

Connect quadratic forms and matrices, in order to explicitly compute with them.
The convention is twos out, so there might be a factor 2⁻¹ in the entries of the
matrix.
The determinant of the matrix is the discriminant of the quadratic form.
-/

variable {n : Type w} [Fintype n] [DecidableEq n]

variable [CommRing R₁] [AddCommMonoid M] [Module R₁ M]

/-- `M.to_quadratic_form` is the map `λ x, col x ⬝ M ⬝ row x` as a quadratic form. -/
def Matrix.toQuadraticForm' (M : Matrix n n R₁) : QuadraticForm R₁ (n → R₁) :=
  M.toBilin'.toQuadraticForm
#align matrix.to_quadratic_form' Matrix.toQuadraticForm'

variable [Invertible (2 : R₁)]

/-- A matrix representation of the quadratic form. -/
def QuadraticForm.toMatrix' (Q : QuadraticForm R₁ (n → R₁)) : Matrix n n R₁ :=
  Q.Associated.toMatrix'
#align quadratic_form.to_matrix' QuadraticForm.toMatrix'

open QuadraticForm

theorem QuadraticForm.toMatrix'_smul (a : R₁) (Q : QuadraticForm R₁ (n → R₁)) :
    (a • Q).toMatrix' = a • Q.toMatrix' := by
  simp only [to_matrix', LinearEquiv.map_smul, LinearMap.map_smul]
#align quadratic_form.to_matrix'_smul QuadraticForm.toMatrix'_smul

theorem QuadraticForm.isSymm_toMatrix' (Q : QuadraticForm R₁ (n → R₁)) : Q.toMatrix'.IsSymm :=
  by
  ext (i j)
  rw [to_matrix', BilinForm.toMatrix'_apply, BilinForm.toMatrix'_apply, associated_is_symm]
#align quadratic_form.is_symm_to_matrix' QuadraticForm.isSymm_toMatrix'

end

namespace QuadraticForm

variable {n : Type w} [Fintype n]

variable [CommRing R₁] [DecidableEq n] [Invertible (2 : R₁)]

variable {m : Type w} [DecidableEq m] [Fintype m]

open Matrix

@[simp]
theorem toMatrix'_comp (Q : QuadraticForm R₁ (m → R₁)) (f : (n → R₁) →ₗ[R₁] m → R₁) :
    (Q.comp f).toMatrix' = f.toMatrix'ᵀ ⬝ Q.toMatrix' ⬝ f.toMatrix' :=
  by
  ext
  simp only [QuadraticForm.associated_comp, BilinForm.toMatrix'_comp, to_matrix']
#align quadratic_form.to_matrix'_comp QuadraticForm.toMatrix'_comp

section Discriminant

variable {Q : QuadraticForm R₁ (n → R₁)}

/-- The discriminant of a quadratic form generalizes the discriminant of a quadratic polynomial. -/
def discr (Q : QuadraticForm R₁ (n → R₁)) : R₁ :=
  Q.toMatrix'.det
#align quadratic_form.discr QuadraticForm.discr

theorem discr_smul (a : R₁) : (a • Q).discr = a ^ Fintype.card n * Q.discr := by
  simp only [discr, to_matrix'_smul, Matrix.det_smul]
#align quadratic_form.discr_smul QuadraticForm.discr_smul

theorem discr_comp (f : (n → R₁) →ₗ[R₁] n → R₁) :
    (Q.comp f).discr = f.toMatrix'.det * f.toMatrix'.det * Q.discr := by
  simp only [Matrix.det_transpose, mul_left_comm, QuadraticForm.toMatrix'_comp, mul_comm,
    Matrix.det_mul, discr]
#align quadratic_form.discr_comp QuadraticForm.discr_comp

end Discriminant

end QuadraticForm

namespace QuadraticForm

end QuadraticForm

namespace BilinForm

section Semiring

variable [Semiring R] [AddCommMonoid M] [Module R M]

/-- A bilinear form is nondegenerate if the quadratic form it is associated with is anisotropic. -/
theorem nondegenerateOfAnisotropic {B : BilinForm R M} (hB : B.toQuadraticForm.Anisotropic) :
    B.Nondegenerate := fun x hx => hB _ (hx x)
#align bilin_form.nondegenerate_of_anisotropic BilinForm.nondegenerateOfAnisotropic

end Semiring

variable [Ring R] [AddCommGroup M] [Module R M]

/-- There exists a non-null vector with respect to any symmetric, nonzero bilinear form `B`
on a module `M` over a ring `R` with invertible `2`, i.e. there exists some
`x : M` such that `B x x ≠ 0`. -/
theorem exists_bilinForm_self_ne_zero [htwo : Invertible (2 : R)] {B : BilinForm R M} (hB₁ : B ≠ 0)
    (hB₂ : B.IsSymm) : ∃ x, ¬B.IsOrtho x x :=
  by
  lift B to QuadraticForm R M using hB₂ with Q
  obtain ⟨x, hx⟩ := QuadraticForm.exists_quadraticForm_ne_zero hB₁
  exact ⟨x, fun h => hx (Q.associated_eq_self_apply ℕ x ▸ h)⟩
#align bilin_form.exists_bilin_form_self_ne_zero BilinForm.exists_bilinForm_self_ne_zero

open FiniteDimensional

variable {V : Type u} {K : Type v} [Field K] [AddCommGroup V] [Module K V]

variable [FiniteDimensional K V]

/-- Given a symmetric bilinear form `B` on some vector space `V` over a field `K`
in which `2` is invertible, there exists an orthogonal basis with respect to `B`. -/
theorem exists_orthogonal_basis [hK : Invertible (2 : K)] {B : BilinForm K V} (hB₂ : B.IsSymm) :
    ∃ v : Basis (Fin (finrank K V)) K V, B.IsOrthoᵢ v :=
  by
  induction' hd : finrank K V with d ih generalizing V
  · exact ⟨basisOfFinrankZero hd, fun _ _ _ => zero_left _⟩
  haveI := finrank_pos_iff.1 (hd.symm ▸ Nat.succ_pos d : 0 < finrank K V)
  -- either the bilinear form is trivial or we can pick a non-null `x`
  obtain rfl | hB₁ := eq_or_ne B 0
  · let b := FiniteDimensional.finBasis K V
    rw [hd] at b
    refine' ⟨b, fun i j hij => rfl⟩
  obtain ⟨x, hx⟩ := exists_bilin_form_self_ne_zero hB₁ hB₂
  rw [← Submodule.finrank_add_eq_of_isCompl (is_compl_span_singleton_orthogonal hx).symm,
    finrank_span_singleton (ne_zero_of_not_is_ortho_self x hx)] at hd
  let B' := B.restrict (B.orthogonal <| K ∙ x)
  obtain ⟨v', hv₁⟩ := ih (B.restrict_symm hB₂ _ : B'.is_symm) (Nat.succ.inj hd)
  -- concatenate `x` with the basis obtained by induction
  let b :=
    Basis.mkFinCons x v'
      (by
        rintro c y hy hc
        rw [add_eq_zero_iff_neg_eq] at hc
        rw [← hc, Submodule.neg_mem_iff] at hy
        have := (is_compl_span_singleton_orthogonal hx).Disjoint
        rw [Submodule.disjoint_def] at this
        have := this (c • x) (Submodule.smul_mem _ _ <| Submodule.mem_span_singleton_self _) hy
        exact (smul_eq_zero.1 this).resolve_right fun h => hx <| h.symm ▸ zero_left _)
      (by
        intro y
        refine' ⟨-B x y / B x x, fun z hz => _⟩
        obtain ⟨c, rfl⟩ := Submodule.mem_span_singleton.1 hz
        rw [is_ortho, smul_left, add_right, smul_right, div_mul_cancel _ hx, add_neg_self,
          MulZeroClass.mul_zero])
  refine' ⟨b, _⟩
  · rw [Basis.coe_mkFinCons]
    intro j i
    refine' Fin.cases _ (fun i => _) i <;> refine' Fin.cases _ (fun j => _) j <;> intro hij <;>
      simp only [Function.onFun, Fin.cons_zero, Fin.cons_succ, Function.comp_apply]
    · exact (hij rfl).elim
    · rw [is_ortho, hB₂]
      exact (v' j).Prop _ (Submodule.mem_span_singleton_self x)
    · exact (v' i).Prop _ (Submodule.mem_span_singleton_self x)
    · exact hv₁ (ne_of_apply_ne _ hij)
#align bilin_form.exists_orthogonal_basis BilinForm.exists_orthogonal_basis

end BilinForm

namespace QuadraticForm

open Finset BilinForm

variable {M₁ : Type _} [Semiring R] [CommSemiring R₁] [AddCommMonoid M] [AddCommMonoid M₁]

variable [Module R M] [Module R M₁]

variable {ι : Type _} [Fintype ι] {v : Basis ι R M}

/-- Given a quadratic form `Q` and a basis, `basis_repr` is the basis representation of `Q`. -/
noncomputable def basisRepr (Q : QuadraticForm R M) (v : Basis ι R M) : QuadraticForm R (ι → R) :=
  Q.comp v.equivFun.symm
#align quadratic_form.basis_repr QuadraticForm.basisRepr

@[simp]
theorem basisRepr_apply (Q : QuadraticForm R M) (w : ι → R) :
    Q.basis_repr v w = Q (∑ i : ι, w i • v i) :=
  by
  rw [← v.equiv_fun_symm_apply]
  rfl
#align quadratic_form.basis_repr_apply QuadraticForm.basisRepr_apply

section

variable (R₁)

/-- The weighted sum of squares with respect to some weight as a quadratic form.

The weights are applied using `•`; typically this definition is used either with `S = R₁` or
`[algebra S R₁]`, although this is stated more generally. -/
def weightedSumSquares [Monoid S] [DistribMulAction S R₁] [SMulCommClass S R₁ R₁] (w : ι → S) :
    QuadraticForm R₁ (ι → R₁) :=
  ∑ i : ι, w i • proj i i
#align quadratic_form.weighted_sum_squares QuadraticForm.weightedSumSquares

end

@[simp]
theorem weightedSumSquares_apply [Monoid S] [DistribMulAction S R₁] [SMulCommClass S R₁ R₁]
    (w : ι → S) (v : ι → R₁) : weightedSumSquares R₁ w v = ∑ i : ι, w i • (v i * v i) :=
  QuadraticForm.sum_apply _ _ _
#align quadratic_form.weighted_sum_squares_apply QuadraticForm.weightedSumSquares_apply

/-- On an orthogonal basis, the basis representation of `Q` is just a sum of squares. -/
theorem basisRepr_eq_of_isOrthoCat {R₁ M} [CommRing R₁] [AddCommGroup M] [Module R₁ M]
    [Invertible (2 : R₁)] (Q : QuadraticForm R₁ M) (v : Basis ι R₁ M)
    (hv₂ : (associated Q).IsOrthoᵢ v) : Q.basis_repr v = weightedSumSquares _ fun i => Q (v i) :=
  by
  ext w
  rw [basis_repr_apply, ← @associated_eq_self_apply R₁, sum_left, weighted_sum_squares_apply]
  refine' sum_congr rfl fun j hj => _
  rw [← @associated_eq_self_apply R₁, sum_right, sum_eq_single_of_mem j hj]
  · rw [smul_left, smul_right, smul_eq_mul]
    ring
  · intro i _ hij
    rw [smul_left, smul_right, show associated_hom R₁ Q (v j) (v i) = 0 from hv₂ hij.symm,
      MulZeroClass.mul_zero, MulZeroClass.mul_zero]
#align quadratic_form.basis_repr_eq_of_is_Ortho QuadraticForm.basisRepr_eq_of_isOrthoCat

end QuadraticForm


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Estimators.
-/
import .util .tactics .tensor .id .graph .expected_value .tgrads

namespace certigrad
namespace estimators
open list

lemma score {ishapes : list S} {oshape tshape : S} (op : rand.op ishapes oshape) (args : T tshape → dvec T ishapes) (θ : T tshape)
    (H_op_pre : op^.pre (args θ))
    (f : T oshape → ℝ)
    (H_pdf_diff : ∀ (v : T oshape), T.is_cdifferentiable (λ x₀, op^.pdf (args x₀) v) θ)
    (H_f_uint : T.is_uniformly_integrable_around (λ θ₀ x, rand.op.pdf op (args θ₀) x ⬝ f x) θ)
    (H_f_grad_uint : T.is_uniformly_integrable_around (λ θ₀ x, ∇ (λ θ₀, rand.op.pdf op (args θ₀) x ⬝ f x) θ₀) θ) :
  ∇ (λ θ₀, E (sprog.prim op (args θ₀)) (λ x, f x^.head)) θ
  =
  E (sprog.prim op (args θ)) (λ x₀, f x₀^.head ⬝ ∇ (λ θ₀, T.log (op^.pdf (args θ₀) x₀^.head)) θ) :=
have H_pdf_pos : ∀ x, op^.pdf (args θ) x > 0, from rand.op.pdf_pos op (args θ) H_op_pre,

have H_f_diff : ∀ x, T.is_cdifferentiable (λ θ₀, rand.op.pdf op (args θ₀) x ⬝ f x) θ, from
assume x, iff.mp (T.is_cdifferentiable_fscale _ _ _) (H_pdf_diff x),

begin
dunfold E T.dintegral,
erw T.grad_integral _ _ H_f_diff H_f_uint H_f_grad_uint,

apply congr_arg,
apply funext,
intro x,
dunfold dvec.head rand.op.pdf,

rw (T.grad_log_f θ _ (H_pdf_pos x)),

erw [-T.smul_group, -T.smul_group],
dsimp,
rw [mul_assoc, mul_comm (f x), -mul_assoc],
rw (T.mul_inv_cancel (H_pdf_pos x)),
rw one_mul,
rw -T.grad_scale_f,
apply T.grad_congr, intro y, rw T.smul_comm
end

lemma pathwise {ishapes : list S} {oshape tshape : S} {f : T oshape → T tshape → ℝ}
               (op : rand.op ishapes oshape) (args : dvec T ishapes) (θ : T tshape)
               (H_f_diff : ∀ (x : T oshape), T.is_cdifferentiable (f x) θ)
               (H_uint : T.is_uniformly_integrable_around (λ θ₀ x, rand.op.pdf op args x ⬝ f x θ₀) θ)
               (H_grad_uint : T.is_uniformly_integrable_around (λ θ₀ x, ∇ (λ θ₁, rand.op.pdf op args x ⬝ f x θ₁) θ₀) θ) :
    ∇ (λ θ₀, E (sprog.prim op args) (λ x, f x^.head θ₀)) θ
    =
    E (sprog.prim op args) (λ x, ∇ (λ θ₀, f x^.head θ₀) θ) :=
show ∇ (λ (θ₀ : T tshape), ∫ (λ (x : T oshape), op^.pdf args x ⬝ f x θ₀)) θ
     =
     ∫ (λ (x : T oshape), op^.pdf args x ⬝ ∇ (λ (θ₀ : T tshape), f x θ₀) θ), from
have H_pdf_f_diff : ∀ x, T.is_cdifferentiable (λ θ₀, op^.pdf args x ⬝ f x θ₀) θ, from
assume x, iff.mp (T.is_cdifferentiable_scale_f _ _ _) (H_f_diff x),

suffices H_suffices :
         ∫ (λ (x : T oshape), ∇ (λ (θ₀ : T tshape), op^.pdf args x ⬝ f x θ₀) θ)
         =
         ∫ (λ (x : T oshape), op^.pdf args x ⬝ ∇ (λ (θ₀ : T tshape), f x θ₀) θ), from
  begin rw T.grad_integral _ _ H_pdf_f_diff H_uint H_grad_uint, exact H_suffices end,

suffices H_suffices : ∀ (x : T oshape),
                         ∇ (λ (θ₀ : T tshape), op^.pdf args x ⬝ f x θ₀) θ
                         =
                         op^.pdf args x ⬝ ∇ (λ (θ₀ : T tshape), f x θ₀) θ, begin apply T.integral_congr, exact H_suffices end,
assume (x : T oshape),
by apply T.grad_scale_f

lemma hybrid_general {parents : list reference} {tgt : reference} {oshape : S} (m : env)
    (H_tgt_in_inputs : env.has_key tgt m)
    (op : rand.op parents^.p2 oshape)
    (H_op_pre : op^.pre (env.get_ks parents m))
    (f : T oshape → T tgt.2 → ℝ)
    -- Just a convenience, so we can write θ
    -- TODO(dhs): when I make θ implicit, nothing happens
    (θ : T tgt.2) (H_θ : θ = env.get tgt m)

    (H_f_diff : ∀ (x : T oshape), T.is_cdifferentiable (f x) θ)
    (H_f_uint : T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T oshape), rand.op.pdf op (env.get_ks parents (env.insert tgt θ m)) x ⬝ f x θ₀) θ)
    (H_f_grad_uint : T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T oshape), ∇ (λ (θ₁ : T (tgt.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ m)) x ⬝ f x θ₁) θ₀) θ)

    (H_d'_pdf_diff : ∀ {idx : ℕ}, at_idx parents idx tgt →
           ∀ (v : T oshape), T.is_cdifferentiable (λ (x₀ : T (tgt.snd)), rand.op.pdf op (dvec.update_at x₀ (env.get_ks parents (env.insert tgt θ m)) idx) v) θ)

    (H_d'_uint : ∀ {idx : ℕ}, at_idx parents idx tgt →
                    T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T oshape),
                        rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x ⬝ f x θ) θ)
    (H_d'_grad_uint : ∀ {idx : ℕ}, at_idx parents idx tgt →
                        T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T oshape),
                             ∇ (λ (θ₀ : T (tgt.snd)), rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x ⬝ f x θ) θ₀) θ)
    :
    let g : dvec T parents^.p2 → T tgt.2 → ℝ := (λ (xs : dvec T parents^.p2) (θ : T tgt.2), E (sprog.prim op xs) (λ (y : dvec T [oshape]), f y^.head θ)) in

  ∀ (H_diff₁ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), g (env.get_ks parents (env.insert tgt θ m)) θ₀) θ)
    (H_diff₂ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), g (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) θ)
                                                                    (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ)

    (H_int₁ : E.is_eintegrable (sprog.prim op (env.get_ks parents (env.insert tgt θ m))) (λ (x : dvec T [oshape]), ∇ (f x^.head) θ))
    (H_int₂ : E.is_eintegrable (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
                              (λ (x : dvec T [oshape]), sumr (map (λ (idx : ℕ), f x^.head θ ⬝ ∇ (λ (θ₀ : T (tgt.snd)), T.log (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) (dvec.head x))) θ) (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))))),

∇ (λ θ₀, E (sprog.prim op (env.get_ks parents (env.insert tgt θ₀ m))) (λ x₀, f x₀^.head θ₀)) θ
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ x₀, ∇ (λ θ₀, f x₀^.head θ₀) θ
  + sumr (map (λ (idx : ℕ),
                f x₀^.head θ ⬝ ∇ (λ θ₀, T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x₀^.head)) θ)
             (filter (λ idx, tgt = dnth parents idx) (riota $ length parents)))) :=
let g : dvec T parents^.p2 → T tgt.2 → ℝ := (λ (xs : dvec T parents^.p2) (θ : T tgt.2), E (sprog.prim op xs) (λ (y : dvec T [oshape]), f y^.head θ)) in
assume H_diff₁ H_diff₂ H_int₁ H_int₂,

show
∇ (λ θ₀, g (env.get_ks parents (env.insert tgt θ₀ m)) θ₀) θ
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ x₀, ∇ (λ θ₀, f x₀^.head θ₀) θ
  + sumr (map (λ (idx : ℕ),
                f x₀^.head θ ⬝ ∇ (λ θ₀, T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x₀^.head)) θ)
             (filter (λ idx, tgt = dnth parents idx) (riota $ length parents)))), from

suffices H_suffices :
∇ (λ (θ₀ : T tgt.2),
    E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
      (λ (y : dvec T [oshape]), f y^.head θ₀))
   θ
+
sumr (map (λ (idx : ℕ),
            ∇ (λ (θ₀ : T tgt.2),
                E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
                  (λ (y : dvec T [oshape]), f y^.head θ))
              θ)
         (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (x₀ : dvec T [oshape]), ∇ (λ (θ₀ : T tgt.2), f x₀^.head θ₀) θ)
+
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (x₀ : dvec T [oshape]),
    sumr (map (λ (idx : ℕ),
               f x₀^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2), T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x₀^.head)) θ)
             (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))), from
  begin
  rw T.multiple_args_general, revert g, dsimp, rw E.E_add _ _ _ H_int₁ H_int₂, exact H_suffices, exact H_diff₁, exact H_diff₂
  end,

have H_term₁ :
∇ (λ (θ₀ : T tgt.2),
    E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
      (λ (y : dvec T [oshape]), f y^.head θ₀))
   θ
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (x₀ : dvec T [oshape]), ∇ (λ (θ₀ : T tgt.2), f x₀^.head θ₀) θ), from
  pathwise _ _ _ H_f_diff H_f_uint H_f_grad_uint,

suffices H_suffices :
sumr (map (λ (idx : ℕ),
            ∇ (λ (θ₀ : T tgt.2),
                E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
                  (λ (y : dvec T [oshape]), f y^.head θ))
              θ)
         (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (x₀ : dvec T [oshape]),
    sumr (map (λ (idx : ℕ),
               f x₀^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2), T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) x₀^.head)) θ)
             (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))), begin rw H_term₁, apply congr_arg, exact H_suffices end,

suffices H_suffices :
sumr (map (λ (idx : ℕ),
            ∇ (λ (θ₀ : T tgt.2),
                E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
                  (λ (y : dvec T [oshape]), f y^.head θ))
              θ)
         (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))
=
sumr (map (λ (x : ℕ),
           E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
             (λ (y : dvec T [oshape]),
               f y^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2),
                            T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) x) y^.head)) θ))
         (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))), from
  begin rw -E.E_pull_out_of_sum _ _ _ _ _ H_int₂, exact H_suffices, rw H_θ, rw env.insert_get_same H_tgt_in_inputs, exact H_op_pre end,

suffices H_suffices :
∀ (idx : ℕ), idx ∈ riota (length parents) → tgt = dnth parents idx →

∇ (λ (θ₀ : T tgt.2),
    E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
      (λ (y : dvec T [oshape]), f y^.head θ))
  θ
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (y : dvec T [oshape]),
      f y^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2),
                 T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) y^.head)) θ), from
  begin apply congr_arg, apply map_filter_congr, exact H_suffices end,

assume (idx : ℕ)
       (H_idx_in_riota : idx ∈ riota (length parents))
       (H_tgt_eq_dnth_idx : tgt = dnth parents idx),

let mk_args : T tgt.2 → dvec T parents^.p2 :=
      (λ (v : T tgt.2),
         dvec.update_at v (env.get_ks parents (env.insert tgt θ m)) idx) in

show
∇ (λ (θ₀ : T tgt.2),
    E (sprog.prim op (mk_args θ₀))
      (λ (y : dvec T [oshape]), f y^.head θ))
  θ
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (y : dvec T [oshape]),
      f y^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2),
                 T.log (op^.pdf (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) y^.head)) θ), from

have H_idx_lt_len_parents : idx < length parents, from in_riota_lt H_idx_in_riota,

have H_tgt_at_idx : at_idx parents idx tgt, from ⟨in_riota_lt H_idx_in_riota, H_tgt_eq_dnth_idx⟩,
have H_tgt_in_parents : tgt ∈ parents, from mem_of_at_idx H_tgt_at_idx,

have H_op'_pre : op^.pre (mk_args θ),
  begin dsimp, rw H_θ, rw env.insert_get_same H_tgt_in_inputs, rw (env.dvec_update_at_env _ H_tgt_at_idx), exact H_op_pre end,

suffices H_suffices :
E (sprog.prim op (dvec.update_at θ (env.get_ks parents (env.insert tgt θ m)) idx))
  (λ (x₀ : dvec T [oshape]),
     f x₀^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2), T.log (op^.pdf (mk_args θ₀) x₀^.head)) θ)
=
E (sprog.prim op (env.get_ks parents (env.insert tgt θ m)))
  (λ (y : dvec T [oshape]),
     f y^.head θ ⬝ ∇ (λ (θ₀ : T tgt.2), T.log (op^.pdf (mk_args θ₀) y^.head)) θ),
  begin rw (score op mk_args θ H_op'_pre (λ y, f y θ) (H_d'_pdf_diff H_tgt_at_idx) (H_d'_uint H_tgt_at_idx) (H_d'_grad_uint H_tgt_at_idx)),
        exact H_suffices end,

have H_remove_dvec_update : dvec.update_at θ (env.get_ks parents (env.insert tgt θ m)) idx = env.get_ks parents (env.insert tgt θ m),
  begin
  rw [H_θ, env.insert_get_same H_tgt_in_inputs],
  rw (env.dvec_update_at_env m ⟨H_idx_lt_len_parents, H_tgt_eq_dnth_idx⟩)
  end,

by rw H_remove_dvec_update

end estimators
end certigrad


import pq_group_homo_locus_pres_prod

universe u

section pq_group_homo_locus_pres_iso_ker_counit

variables {G : Type u} [group G]

lemma counit_pq_group_homo_locus_pres_prod_iso_backward (x : homo_locus_pres G) (a : G) : counit (pq_group_homo_locus_pres_prod_iso_backward ⟨x, a⟩) = a :=
begin
  unfold pq_group_homo_locus_pres_prod_iso_backward,
  simp only [monoid_hom.coe_mk],
  simp only [counit_of, counit_ker_counit, one_mul, monoid_hom.map_mul],
end

lemma counit_pq_group_homo_locus_pres_prod_iso_backward_unsplit (x : homo_locus_pres_prod G) : counit (pq_group_homo_locus_pres_prod_iso_backward x) = x.a :=
begin
  unfold pq_group_homo_locus_pres_prod_iso_backward,
  simp only [monoid_hom.coe_mk],
  simp only [counit_of, counit_ker_counit, one_mul, monoid_hom.map_mul],
end

lemma a_pq_group_homo_locus_pres_prod_iso_forward (x : pq_group G) : (pq_group_homo_locus_pres_prod_iso_forward x).a = counit x :=
begin
  rw ←pq_group_homo_locus_pres_prod_iso_left_inv x,
  rw counit_pq_group_homo_locus_pres_prod_iso_backward_unsplit,
  rw pq_group_homo_locus_pres_prod_iso_left_inv x,
end

def homo_locus_pres_iso : (counit : pq_group G →* G).ker ≃* homo_locus_pres G := {
  to_fun := λ x, (pq_group_homo_locus_pres_prod_iso_forward (x.val)).x,
  inv_fun := λ x, ⟨(pq_group_homo_locus_pres_prod_iso_backward ⟨x, 1⟩), begin
    refine counit.mem_ker.mpr _,
    rw counit_pq_group_homo_locus_pres_prod_iso_backward,
  end⟩,
  left_inv := begin
    rintros ⟨x, hx⟩,
    simp only,
    ext1,
    simp only [subtype.coe_mk],
    suffices : ({x := (pq_group_homo_locus_pres_prod_iso_forward x).x, a := 1} : homo_locus_pres_prod G) = pq_group_homo_locus_pres_prod_iso_forward x,
    {
      rw this,
      rw pq_group_homo_locus_pres_prod_iso_left_inv,
    },
    ext1,
    {
      refl,
    },
    {
      simp only,
      rw a_pq_group_homo_locus_pres_prod_iso_forward,
      symmetry,
      exact hx,
    },
  end,
  right_inv := begin
    intros x,
    simp only,
    rw pq_group_homo_locus_pres_prod_iso_right_inv,
  end,
  map_mul' := begin
    rintros ⟨x, hx⟩ ⟨y, hy⟩,
    show (pq_group_homo_locus_pres_prod_iso_forward (x * y)).x = (pq_group_homo_locus_pres_prod_iso_forward (x)).x * (pq_group_homo_locus_pres_prod_iso_forward (y)).x,
    simp only [monoid_hom.map_mul],
    rw homo_locus_pres_prod_mul_def_unsplit,
    simp only,
    rw a_pq_group_homo_locus_pres_prod_iso_forward,
    rw a_pq_group_homo_locus_pres_prod_iso_forward,
    suffices : homo_locus_of (counit x, counit y) = 1,
    {
      rw this,
      rw mul_one,
    },
    suffices : counit x = 1,
    {
      rw this,
      rw homo_locus_of_one,
      exact homo_locus_closed_left_one (counit y),
    },
    exact hx,
  end }

end pq_group_homo_locus_pres_iso_ker_counit