import random_lemmas
import target_affine_scheme

noncomputable theory

universe u

open category_theory category_theory.limits
open topological_space
open Top.presheaf Top.sheaf
open opposite

namespace algebraic_geometry

namespace Scheme

variables (X : Scheme.{u}) (R : CommRing.{u}) [local_ring R]

structure point_affine_open_stalk_ring_hom_triple :=
(pt : X.carrier)
(aopen : opens X.carrier)
(mem_aopen : pt ∈ aopen)
(aopen_is_affine : is_affine_open aopen)
(ring_hom_ : X.stalk pt ⟶ R)
[ring_hom_local : is_local_ring_hom ring_hom_]

namespace point_affine_open_stalk_ring_hom_triple

variables (P Q : point_affine_open_stalk_ring_hom_triple X R)

local notation X `|_` P := (X.restrict (P.aopen.open_embedding) : Scheme)

instance is_affine_restrict : is_affine $ X |_ P :=
P.aopen_is_affine

variables {X R}

structure refine : Prop :=
(subset : P.aopen ≤ Q.aopen)
(pt_eq : P.pt = Q.pt)
(ring_hom_eq : stalk_specializes X.presheaf (by rw pt_eq) ≫ P.ring_hom_ = Q.ring_hom_)

def restrict_stalk_iso : (X |_ P).stalk ⟨P.pt, P.mem_aopen⟩  ≅ X.stalk P.pt:=
PresheafedSpace.restrict_stalk_iso X.to_PresheafedSpace
  (P.aopen.open_embedding) ⟨P.pt, _⟩

def restrict_Γ_iso : (Γ.obj $ op $ X |_ P) ≅ X.presheaf.obj (op P.aopen) :=
{ hom := X.presheaf.map $ (hom_of_le
    begin
      rintros x (hx : x ∈ P.aopen),
      refine ⟨⟨x, hx⟩, ⟨⟩, rfl⟩,
    end : P.aopen ⟶ ((_ : is_open_map _).functor.obj ⊤)).op,
  inv := X.presheaf.map $ (hom_of_le
    begin
      rintros _ ⟨x, -, rfl⟩,
      exact x.2,
    end : (_ : is_open_map _).functor.obj ⊤ ⟶ P.aopen).op,
  hom_inv_id' := by erw [←X.presheaf.map_comp, X.presheaf.map_id]; refl,
  inv_hom_id' := by erw [←X.presheaf.map_comp, X.presheaf.map_id]; refl }

def to_Spec_local_ring_to_Scheme_restrict : Spec_obj R ⟶ X.restrict P.aopen.open_embedding :=
(hom.target_AffineScheme (Spec_obj R) _).symm $
    (P.restrict_Γ_iso.hom ≫ germ _ ⟨P.pt, P.mem_aopen⟩ ≫ P.ring_hom_ : Γ.obj (op $ X |_ P) ⟶ R)
  ≫ (structure_sheaf.global_sections_iso R).hom

def to_Spec_local_ring_to_Scheme : Spec_obj R ⟶ X :=
P.to_Spec_local_ring_to_Scheme_restrict ≫ X.of_restrict _

section refine

variables (P Q)

@[reducible] def restrict_of_refine (h : P.refine Q) : (X |_ P) ⟶ (X |_ Q) :=
is_open_immersion.lift
  (X.of_restrict Q.aopen.open_embedding)
  (X.of_restrict P.aopen.open_embedding)
begin
  rintros _ ⟨⟨x, hx⟩, rfl⟩,
  refine ⟨⟨x, h.subset hx⟩, rfl⟩,
end

@[reducible] def restrict_of_refine' (h : P.refine Q) : (X |_ P) ⟶ (X |_ Q) :=
(hom.target_AffineScheme (X |_ P) (X |_ Q)).symm $
X.presheaf.map $ (hom_of_le
  begin
    rintros _ ⟨⟨x, hx⟩, -, rfl⟩,
    refine ⟨⟨x, h.subset hx⟩, ⟨⟩, rfl⟩,
  end : (_ : is_open_map _).functor.obj ⊤ ⟶ (_ : is_open_map _).functor.obj ⊤).op

example (h : P.refine Q) :
  P.restrict_of_refine' _ h =
  P.restrict_of_refine _ h :=
begin
  dsimp only [restrict_of_refine, restrict_of_refine'],
  refine is_open_immersion.lift_uniq _ _ _ _ _,
  sorry
end

lemma restrict_of_refine_comp_of_restrict (h : P.refine Q) :
  X.of_restrict (P.aopen.open_embedding) =
  P.restrict_of_refine _ h ≫ X.of_restrict _ :=
by rw is_open_immersion.lift_fac

/--
Spec R ⟶ X | P
    \       ↓
      --> X | Q
-/
lemma to_Spec_local_ring_to_Scheme_restrict_eq_of_refine (h : P.refine Q) :
  Q.to_Spec_local_ring_to_Scheme_restrict =
  P.to_Spec_local_ring_to_Scheme_restrict ≫ restrict_of_refine _ _ h :=
begin
  dsimp only [to_Spec_local_ring_to_Scheme_restrict],
  -- haveI : is_open_immersion (P.restrict_of_refine Q h) := sorry,
  -- have := is_open_immersion.lift_fac
  --   (restrict_of_refine _ _ h) (Q.to_Spec_local_ring_to_Scheme_restrict),
end

def to_Spec_local_ring_to_Scheme.resp_refine (h : P.refine Q) :
  P.to_Spec_local_ring_to_Scheme = Q.to_Spec_local_ring_to_Scheme :=
begin
  dsimp [to_Spec_local_ring_to_Scheme],
  rw [restrict_of_refine_comp_of_restrict _ _ h, ←category.assoc],
  congr' 1,
end

end refine

end point_affine_open_stalk_ring_hom_triple

structure point_stalk_ring_hom_pair :=
(pt : X.carrier)
(stalk_ : CommRing.{u})
(stalk_iso : stalk_ ≅ X.presheaf.stalk pt)
(ring_hom_ : stalk_ ⟶ R)
[is_local_ring_hom_ : is_local_ring_hom ring_hom_]

attribute [instance] point_stalk_ring_hom_pair.is_local_ring_hom_

namespace point_stalk_ring_hom_pair

variables {X R} (P Q S : point_stalk_ring_hom_pair X R)

@[reducible]
def ring_hom_' : X.presheaf.stalk P.pt ⟶ R :=
  P.stalk_iso.inv ≫ P.ring_hom_

variables {P Q S}

@[simps]
def stalk_equiv_of_pt_eq (pt_eq : P.pt = Q.pt) :
  P.stalk_ ≅ Q.stalk_ :=
{ hom := P.stalk_iso.hom
    ≫ stalk_specializes X.presheaf (by rw pt_eq : Q.pt ⤳ P.pt)
    ≫ Q.stalk_iso.inv,
  inv := Q.stalk_iso.hom
    ≫ stalk_specializes X.presheaf (by rw pt_eq : P.pt ⤳ Q.pt)
    ≫ P.stalk_iso.inv,
  hom_inv_id' :=
  begin
    rw [category.assoc, category.assoc, iso.inv_hom_id_assoc,
      ←category.assoc, ←category.assoc, iso.comp_inv_eq, category.id_comp,
      category.assoc],
    convert category.comp_id _,
    refine stalk_hom_ext _ _,
    intros U h,
    rw [germ_stalk_specializes'_assoc],
    erw [category.comp_id, germ_stalk_specializes'],
    refl,
  end,
  inv_hom_id' :=
  begin
    rw [category.assoc, category.assoc, iso.inv_hom_id_assoc,
      ←category.assoc, ←category.assoc, iso.comp_inv_eq, category.id_comp,
      category.assoc],
    convert category.comp_id _,
    refine stalk_hom_ext _ _,
    intros U h,
    rw [germ_stalk_specializes'_assoc],
    erw [category.comp_id, germ_stalk_specializes'],
    refl,
  end }

variables (P Q S)
structure equiv : Prop :=
(pt_eq : P.pt = Q.pt)
(ring_hom_eq : P.ring_hom_ = (stalk_equiv_of_pt_eq pt_eq).hom ≫ Q.ring_hom_)

structure equiv' : Prop :=
(pt_eq : P.pt = Q.pt)
(ring_hom_eq : (stalk_equiv_of_pt_eq pt_eq).inv ≫ P.ring_hom_ = Q.ring_hom_)

@[refl] lemma equiv_self : P.equiv P :=
{ pt_eq := rfl,
  ring_hom_eq :=
  begin
    symmetry,
    convert category.id_comp _,
    rw [stalk_equiv_of_pt_eq_hom, ←category.assoc, iso.comp_inv_eq,
      category.id_comp],
    convert category.comp_id _,
    apply stalk_hom_ext,
    intros U h,
    rw [germ_stalk_specializes'],
    erw category.comp_id _,
    refl,
  end }

variables {P Q S}

@[symm] lemma equiv_symm (h : P.equiv Q) : Q.equiv P :=
{ pt_eq := h.pt_eq.symm,
  ring_hom_eq :=
  begin
    rw [h.ring_hom_eq, ←category.assoc],
    symmetry,
    convert category.id_comp _,
    rw [stalk_equiv_of_pt_eq_hom, stalk_equiv_of_pt_eq_hom, category.assoc,
      category.assoc, iso.inv_hom_id_assoc, ←category.assoc, ←category.assoc,
      iso.comp_inv_eq, category.id_comp, category.assoc],
    convert category.comp_id _,
    apply stalk_hom_ext,
    intros U h,
    rw [germ_stalk_specializes'_assoc, germ_stalk_specializes'],
    erw category.comp_id,
    refl,
  end }

@[trans] lemma equiv_trans (h1 : P.equiv Q) (h2 : Q.equiv S) : P.equiv S :=
{ pt_eq := h1.pt_eq.trans h2.pt_eq,
  ring_hom_eq :=
  begin
    rw [h1.ring_hom_eq, h2.ring_hom_eq, stalk_equiv_of_pt_eq_hom,
      stalk_equiv_of_pt_eq_hom, stalk_equiv_of_pt_eq_hom, category.assoc,
      category.assoc, category.assoc, iso.inv_hom_id_assoc, ←category.assoc,
      ←category.assoc],
    congr' 1,
    rw [←category.assoc, ←category.assoc],
    congr' 1,
    rw [category.assoc],
    congr' 1,
    apply stalk_hom_ext,
    intros U h,
    rw [germ_stalk_specializes'_assoc, germ_stalk_specializes,
      germ_stalk_specializes],
  end }

variables (P Q S)

@[simps]
def stalk_cocone : cocone ((open_nhds.inclusion P.pt).op ⋙ X.presheaf) :=
{ X := P.stalk_,
  ι :=
  { app := λ j, colimit.ι ((open_nhds.inclusion P.pt).op ⋙ X.presheaf) j ≫
      P.stalk_iso.inv,
    naturality' := λ U V i,
    begin
      dsimp,
      rw [category.comp_id, ←category.assoc],
      erw colimit.w ((open_nhds.inclusion P.pt).op ⋙ X.presheaf) i,
    end }  }

def stalk_cocone_is_colimit : is_colimit (P.stalk_cocone) :=
{ desc := λ s, P.stalk_iso.hom ≫ (colimit.is_colimit ((open_nhds.inclusion P.pt).op ⋙ X.presheaf)).desc s,
  fac' := λ s j,
  begin
    rw ←(colimit.is_colimit ((open_nhds.inclusion P.pt).op ⋙ X.presheaf)).fac s j,
    rw [←category.assoc],
    congr' 1,
    dsimp,
    rw [category.assoc, iso.inv_hom_id, category.comp_id],
  end,
  uniq' := λ s m j,
  begin
    rw ←(colimit.is_colimit ((open_nhds.inclusion P.pt).op ⋙ X.presheaf)).uniq s (_ ≫ m) j,
    rw iso.hom_inv_id_assoc,
  end }

section affine

variables [is_affine X]

def stalk_iso_localization (P : point_stalk_ring_hom_pair X R) :
  P.stalk_ ≅ CommRing.of (localization.at_prime (X.iso_Spec.hom.1 P.pt).as_ideal) :=
P.stalk_iso ≪≫
(PresheafedSpace.stalk_map.stalk_iso
  ({ hom := X.iso_Spec.hom.1,
    inv := X.iso_Spec.inv.1,
    hom_inv_id' := by erw [←Scheme.comp_val, iso.hom_inv_id]; refl,
    inv_hom_id' := by erw [←Scheme.comp_val, iso.inv_hom_id]; refl } : X.to_PresheafedSpace ≅ (Spec_obj $ Γ.obj $ op X).to_PresheafedSpace) P.pt).symm
≪≫ (structure_sheaf.stalk_iso _ _)

def Γ_to_germ (P : point_stalk_ring_hom_pair X R) :
  (Γ.obj $ op X) ⟶ P.stalk_ :=
(structure_sheaf.global_sections_iso (Γ.obj $ op X)).hom ≫
  X.iso_Spec.hom.1.c.app (op ⊤) ≫ P.stalk_cocone.ι.app (op ⊤)

end affine

end point_stalk_ring_hom_pair

section affine

variables {X R} [is_affine X]

def from_point_stalk_ring_hom_pair_of_affine (P : point_stalk_ring_hom_pair X R) :
  Spec_obj R ⟶ X :=
(hom.target_AffineScheme (Spec_obj R) X).symm $
  local_ring.from_point_local_ring_hom_pair
  { pt := X.iso_Spec.hom.1.base P.pt,
    localized_ring := X.presheaf.stalk P.pt,
    algebra_localized_ring := infer_instance,
    is_localization := infer_instance,
    ring_hom_ := P.stalk_iso.inv ≫ P.ring_hom_
      ≫ (structure_sheaf.global_sections_iso R.α).hom,
    is_local_ring_hom_ := infer_instance }

lemma from_point_stalk_ring_hom_pair_of_affine.resp_equiv
  (P Q : point_stalk_ring_hom_pair X R) (h : P.equiv Q) :
  from_point_stalk_ring_hom_pair_of_affine P =
  from_point_stalk_ring_hom_pair_of_affine Q :=
begin
  dsimp only [from_point_stalk_ring_hom_pair_of_affine],
  congr' 1,
  refine local_ring.from_point_local_ring_hom_pair.resp_equiv _,
  fconstructor,
  { dsimp only, rw h.pt_eq, },
  { dsimp only,
    simp_rw h.ring_hom_eq,
    rw [point_stalk_ring_hom_pair.stalk_equiv_of_pt_eq_hom, category.assoc,
      category.assoc, iso.inv_hom_id_assoc, category.assoc],
    congr' 1,
    -- use the fact they are both "colimit", so unique up to a **unique**
    -- isomorphism
    sorry, },
end

@[simps]
def to_point_stalk_ring_hom_pair_of_affine (α : Spec_obj R ⟶ X) :
  point_stalk_ring_hom_pair X R :=
let P := local_ring.to_point_local_ring_hom_pair
  ((hom.target_AffineScheme (Spec_obj R) X) α) in
{ pt := X.iso_Spec.inv.1.base P.pt,
  stalk_ := CommRing.of P.localized_ring,
  stalk_iso :=
    let α := @is_localization.alg_equiv (Γ.obj $ op X) _
      P.pt.as_ideal.prime_compl P.localized_ring _ _ _
      (X.stalk (X.iso_Spec.inv.1.base P.pt)) _
      (X.global_sections_algebra _) (X.stalk_is_localization P.pt) in
  { hom := α.to_ring_equiv.to_ring_hom,
    inv := α.to_ring_equiv.symm.to_ring_hom,
    hom_inv_id' :=
    begin
      ext : 1,
      rw [comp_apply, id_apply,
        ring_equiv.symm_to_ring_hom_apply_to_ring_hom_apply],
    end,
    inv_hom_id' :=
    begin
      ext : 1,
      rw [comp_apply, id_apply,
        ring_equiv.to_ring_hom_apply_symm_to_ring_hom_apply],
    end },
  ring_hom_ := P.ring_hom_ ≫ (structure_sheaf.global_sections_iso _).inv,
  is_local_ring_hom_ := infer_instance }

end affine

end Scheme

end algebraic_geometry


/-symplectic manifolds is the basis of the Hamiltonian formalization of classical mechanics and should
serve as the basis for describing a phase sapce-/
import linear_algebra.bilinear_form

universes u_1 u_2
variables {R : Type u_1} {M : Type u_2} [ring R] [add_comm_monoid M] [module R M] (B : bilin_form R M)

def bilin_form.is_skew_symm := ∀ x y : M, B x y = - B y x

@[protected] lemma is_skew_symm.eq (h : B.is_skew_symm) (x y : M) : B x y = - B y x := h x y


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.mul_add
import Mathlib.algebra.field
import Mathlib.algebra.opposites
import Mathlib.PostPort

universes u_4 u_5 l u_1 u_2 u_3

namespace Mathlib

/-!
# (Semi)ring equivs

In this file we define extension of `equiv` called `ring_equiv`, which is a datatype representing an
isomorphism of `semiring`s, `ring`s, `division_ring`s, or `field`s. We also introduce the
corresponding group of automorphisms `ring_aut`.

## Notations

The extended equiv have coercions to functions, and the coercion is the canonical notation when
treating the isomorphism as maps.

## Implementation notes

The fields for `ring_equiv` now avoid the unbundled `is_mul_hom` and `is_add_hom`, as these are
deprecated.

Definition of multiplication in the groups of automorphisms agrees with function composition,
multiplication in `equiv.perm`, and multiplication in `category_theory.End`, not with
`category_theory.comp`.

## Tags

equiv, mul_equiv, add_equiv, ring_equiv, mul_aut, add_aut, ring_aut
-/

/-- An equivalence between two (semi)rings that preserves the algebraic structure. -/
structure ring_equiv (R : Type u_4) (S : Type u_5) [Mul R] [Add R] [Mul S] [Add S]
    extends R ≃* S, R ≃ S, R ≃+ S where

infixl:25 " ≃+* " => Mathlib.ring_equiv

/-- The "plain" equivalence of types underlying an equivalence of (semi)rings. -/
/-- The equivalence of additive monoids underlying an equivalence of (semi)rings. -/
/-- The equivalence of multiplicative monoids underlying an equivalence of (semi)rings. -/
namespace ring_equiv

protected instance has_coe_to_fun {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] :
    has_coe_to_fun (R ≃+* S) :=
  has_coe_to_fun.mk (fun (x : R ≃+* S) => R → S) to_fun

@[simp] theorem to_fun_eq_coe_fun {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (f : R ≃+* S) : to_fun f = ⇑f :=
  rfl

/-- A ring isomorphism preserves multiplication. -/
@[simp] theorem map_mul {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (e : R ≃+* S)
    (x : R) (y : R) : coe_fn e (x * y) = coe_fn e x * coe_fn e y :=
  map_mul' e x y

/-- A ring isomorphism preserves addition. -/
@[simp] theorem map_add {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (e : R ≃+* S)
    (x : R) (y : R) : coe_fn e (x + y) = coe_fn e x + coe_fn e y :=
  map_add' e x y

/-- Two ring isomorphisms agree if they are defined by the
    same underlying function. -/
theorem ext {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] {f : R ≃+* S}
    {g : R ≃+* S} (h : ∀ (x : R), coe_fn f x = coe_fn g x) : f = g :=
  sorry

protected theorem congr_arg {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    {f : R ≃+* S} {x : R} {x' : R} : x = x' → coe_fn f x = coe_fn f x' :=
  sorry

protected theorem congr_fun {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    {f : R ≃+* S} {g : R ≃+* S} (h : f = g) (x : R) : coe_fn f x = coe_fn g x :=
  h ▸ rfl

theorem ext_iff {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] {f : R ≃+* S}
    {g : R ≃+* S} : f = g ↔ ∀ (x : R), coe_fn f x = coe_fn g x :=
  { mp := fun (h : f = g) (x : R) => h ▸ rfl, mpr := ext }

protected instance has_coe_to_mul_equiv {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S]
    [Add S] : has_coe (R ≃+* S) (R ≃* S) :=
  has_coe.mk to_mul_equiv

protected instance has_coe_to_add_equiv {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S]
    [Add S] : has_coe (R ≃+* S) (R ≃+ S) :=
  has_coe.mk to_add_equiv

theorem coe_mul_equiv {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (f : R ≃+* S)
    (a : R) : coe_fn (↑f) a = coe_fn f a :=
  rfl

theorem coe_add_equiv {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (f : R ≃+* S)
    (a : R) : coe_fn (↑f) a = coe_fn f a :=
  rfl

/-- The identity map is a ring isomorphism. -/
protected def refl (R : Type u_1) [Mul R] [Add R] : R ≃+* R :=
  mk (mul_equiv.to_fun (mul_equiv.refl R)) (mul_equiv.inv_fun (mul_equiv.refl R)) sorry sorry sorry
    sorry

@[simp] theorem refl_apply (R : Type u_1) [Mul R] [Add R] (x : R) :
    coe_fn (ring_equiv.refl R) x = x :=
  rfl

@[simp] theorem coe_add_equiv_refl (R : Type u_1) [Mul R] [Add R] :
    ↑(ring_equiv.refl R) = add_equiv.refl R :=
  rfl

@[simp] theorem coe_mul_equiv_refl (R : Type u_1) [Mul R] [Add R] :
    ↑(ring_equiv.refl R) = mul_equiv.refl R :=
  rfl

protected instance inhabited (R : Type u_1) [Mul R] [Add R] : Inhabited (R ≃+* R) :=
  { default := ring_equiv.refl R }

/-- The inverse of a ring isomorphism is a ring isomorphism. -/
protected def symm {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (e : R ≃+* S) :
    S ≃+* R :=
  mk (mul_equiv.to_fun (mul_equiv.symm (to_mul_equiv e)))
    (mul_equiv.inv_fun (mul_equiv.symm (to_mul_equiv e))) sorry sorry sorry sorry

/-- See Note [custom simps projection] -/
def simps.inv_fun {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S] (e : R ≃+* S) :
    S → R :=
  ⇑(ring_equiv.symm e)

@[simp] theorem symm_symm {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) : ring_equiv.symm (ring_equiv.symm e) = e :=
  ext fun (x : R) => rfl

@[simp] theorem coe_symm_mk {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (f : R → S) (g : S → R) (h₁ : function.left_inverse g f) (h₂ : function.right_inverse g f)
    (h₃ : ∀ (x y : R), f (x * y) = f x * f y) (h₄ : ∀ (x y : R), f (x + y) = f x + f y) :
    ⇑(ring_equiv.symm (mk f g h₁ h₂ h₃ h₄)) = g :=
  rfl

/-- Transitivity of `ring_equiv`. -/
protected def trans {R : Type u_1} {S : Type u_2} {S' : Type u_3} [Mul R] [Add R] [Mul S] [Add S]
    [Mul S'] [Add S'] (e₁ : R ≃+* S) (e₂ : S ≃+* S') : R ≃+* S' :=
  mk (mul_equiv.to_fun (mul_equiv.trans (to_mul_equiv e₁) (to_mul_equiv e₂)))
    (mul_equiv.inv_fun (mul_equiv.trans (to_mul_equiv e₁) (to_mul_equiv e₂))) sorry sorry sorry
    sorry

@[simp] theorem trans_apply {A : Type u_1} {B : Type u_2} {C : Type u_3} [semiring A] [semiring B]
    [semiring C] (e : A ≃+* B) (f : B ≃+* C) (a : A) :
    coe_fn (ring_equiv.trans e f) a = coe_fn f (coe_fn e a) :=
  rfl

protected theorem bijective {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) : function.bijective ⇑e :=
  equiv.bijective (to_equiv e)

protected theorem injective {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) : function.injective ⇑e :=
  equiv.injective (to_equiv e)

protected theorem surjective {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) : function.surjective ⇑e :=
  equiv.surjective (to_equiv e)

@[simp] theorem apply_symm_apply {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) (x : S) : coe_fn e (coe_fn (ring_equiv.symm e) x) = x :=
  equiv.apply_symm_apply (to_equiv e)

@[simp] theorem symm_apply_apply {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) (x : R) : coe_fn (ring_equiv.symm e) (coe_fn e x) = x :=
  equiv.symm_apply_apply (to_equiv e)

theorem image_eq_preimage {R : Type u_1} {S : Type u_2} [Mul R] [Add R] [Mul S] [Add S]
    (e : R ≃+* S) (s : set R) : ⇑e '' s = ⇑(ring_equiv.symm e) ⁻¹' s :=
  equiv.image_eq_preimage (to_equiv e) s

/-- A commutative ring is isomorphic to its opposite. -/
def to_opposite (R : Type u_1) [comm_semiring R] : R ≃+* (Rᵒᵖ) :=
  mk (equiv.to_fun opposite.equiv_to_opposite) (equiv.inv_fun opposite.equiv_to_opposite) sorry
    sorry sorry sorry

@[simp] theorem to_opposite_apply (R : Type u_1) [comm_semiring R] (r : R) :
    coe_fn (to_opposite R) r = opposite.op r :=
  rfl

@[simp] theorem to_opposite_symm_apply (R : Type u_1) [comm_semiring R] (r : Rᵒᵖ) :
    coe_fn (ring_equiv.symm (to_opposite R)) r = opposite.unop r :=
  rfl

/-- A ring isomorphism sends one to one. -/
@[simp] theorem map_one {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S) :
    coe_fn f 1 = 1 :=
  mul_equiv.map_one ↑f

/-- A ring isomorphism sends zero to zero. -/
@[simp] theorem map_zero {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S) :
    coe_fn f 0 = 0 :=
  add_equiv.map_zero ↑f

@[simp] theorem map_eq_one_iff {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S)
    {x : R} : coe_fn f x = 1 ↔ x = 1 :=
  mul_equiv.map_eq_one_iff ↑f

@[simp] theorem map_eq_zero_iff {R : Type u_1} {S : Type u_2} [semiring R] [semiring S]
    (f : R ≃+* S) {x : R} : coe_fn f x = 0 ↔ x = 0 :=
  add_equiv.map_eq_zero_iff ↑f

theorem map_ne_one_iff {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S)
    {x : R} : coe_fn f x ≠ 1 ↔ x ≠ 1 :=
  mul_equiv.map_ne_one_iff ↑f

theorem map_ne_zero_iff {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S)
    {x : R} : coe_fn f x ≠ 0 ↔ x ≠ 0 :=
  add_equiv.map_ne_zero_iff ↑f

/-- Produce a ring isomorphism from a bijective ring homomorphism. -/
def of_bijective {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R →+* S)
    (hf : function.bijective ⇑f) : R ≃+* S :=
  mk (equiv.to_fun (equiv.of_bijective (⇑f) hf)) (equiv.inv_fun (equiv.of_bijective (⇑f) hf)) sorry
    sorry (ring_hom.map_mul' f) (ring_hom.map_add' f)

@[simp] theorem map_neg {R : Type u_1} {S : Type u_2} [ring R] [ring S] (f : R ≃+* S) (x : R) :
    coe_fn f (-x) = -coe_fn f x :=
  add_equiv.map_neg (↑f) x

@[simp] theorem map_sub {R : Type u_1} {S : Type u_2} [ring R] [ring S] (f : R ≃+* S) (x : R)
    (y : R) : coe_fn f (x - y) = coe_fn f x - coe_fn f y :=
  add_equiv.map_sub (↑f) x y

@[simp] theorem map_neg_one {R : Type u_1} {S : Type u_2} [ring R] [ring S] (f : R ≃+* S) :
    coe_fn f (-1) = -1 :=
  map_one f ▸ map_neg f 1

/-- Reinterpret a ring equivalence as a ring homomorphism. -/
def to_ring_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (e : R ≃+* S) : R →+* S :=
  ring_hom.mk (monoid_hom.to_fun (mul_equiv.to_monoid_hom (to_mul_equiv e))) sorry sorry sorry sorry

theorem to_ring_hom_injective {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] :
    function.injective to_ring_hom :=
  fun (f g : R ≃+* S) (h : to_ring_hom f = to_ring_hom g) => ext (iff.mp ring_hom.ext_iff h)

protected instance has_coe_to_ring_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] :
    has_coe (R ≃+* S) (R →+* S) :=
  has_coe.mk to_ring_hom

theorem coe_ring_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S) (a : R) :
    coe_fn (↑f) a = coe_fn f a :=
  rfl

theorem coe_ring_hom_inj_iff {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R ≃+* S)
    (g : R ≃+* S) : f = g ↔ ↑f = ↑g :=
  { mp := congr_arg fun (f : R ≃+* S) => ↑f,
    mpr := fun (h : ↑f = ↑g) => ext (iff.mp ring_hom.ext_iff h) }

/-- Reinterpret a ring equivalence as a monoid homomorphism. -/
def to_monoid_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (e : R ≃+* S) : R →* S :=
  ring_hom.to_monoid_hom (to_ring_hom e)

/-- Reinterpret a ring equivalence as an `add_monoid` homomorphism. -/
def to_add_monoid_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (e : R ≃+* S) :
    R →+ S :=
  ring_hom.to_add_monoid_hom (to_ring_hom e)

@[simp] theorem to_ring_hom_refl {R : Type u_1} [semiring R] :
    to_ring_hom (ring_equiv.refl R) = ring_hom.id R :=
  rfl

@[simp] theorem to_monoid_hom_refl {R : Type u_1} [semiring R] :
    to_monoid_hom (ring_equiv.refl R) = monoid_hom.id R :=
  rfl

@[simp] theorem to_add_monoid_hom_refl {R : Type u_1} [semiring R] :
    to_add_monoid_hom (ring_equiv.refl R) = add_monoid_hom.id R :=
  rfl

@[simp] theorem to_ring_hom_apply_symm_to_ring_hom_apply {R : Type u_1} {S : Type u_2} [semiring R]
    [semiring S] (e : R ≃+* S) (y : S) :
    coe_fn (to_ring_hom e) (coe_fn (to_ring_hom (ring_equiv.symm e)) y) = y :=
  equiv.apply_symm_apply (to_equiv e)

@[simp] theorem symm_to_ring_hom_apply_to_ring_hom_apply {R : Type u_1} {S : Type u_2} [semiring R]
    [semiring S] (e : R ≃+* S) (x : R) :
    coe_fn (to_ring_hom (ring_equiv.symm e)) (coe_fn (to_ring_hom e) x) = x :=
  equiv.symm_apply_apply (to_equiv e)

@[simp] theorem to_ring_hom_trans {R : Type u_1} {S : Type u_2} {S' : Type u_3} [semiring R]
    [semiring S] [semiring S'] (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
    to_ring_hom (ring_equiv.trans e₁ e₂) = ring_hom.comp (to_ring_hom e₂) (to_ring_hom e₁) :=
  rfl

@[simp] theorem to_ring_hom_comp_symm_to_ring_hom {R : Type u_1} {S : Type u_2} [semiring R]
    [semiring S] (e : R ≃+* S) :
    ring_hom.comp (to_ring_hom e) (to_ring_hom (ring_equiv.symm e)) = ring_hom.id S :=
  sorry

@[simp] theorem symm_to_ring_hom_comp_to_ring_hom {R : Type u_1} {S : Type u_2} [semiring R]
    [semiring S] (e : R ≃+* S) :
    ring_hom.comp (to_ring_hom (ring_equiv.symm e)) (to_ring_hom e) = ring_hom.id R :=
  sorry

/--
Construct an equivalence of rings from homomorphisms in both directions, which are inverses.
-/
def of_hom_inv {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (hom : R →+* S)
    (inv : S →+* R) (hom_inv_id : ring_hom.comp inv hom = ring_hom.id R)
    (inv_hom_id : ring_hom.comp hom inv = ring_hom.id S) : R ≃+* S :=
  mk (ring_hom.to_fun hom) ⇑inv sorry sorry (ring_hom.map_mul' hom) (ring_hom.map_add' hom)

@[simp] theorem of_hom_inv_apply {R : Type u_1} {S : Type u_2} [semiring R] [semiring S]
    (hom : R →+* S) (inv : S →+* R) (hom_inv_id : ring_hom.comp inv hom = ring_hom.id R)
    (inv_hom_id : ring_hom.comp hom inv = ring_hom.id S) (r : R) :
    coe_fn (of_hom_inv hom inv hom_inv_id inv_hom_id) r = coe_fn hom r :=
  rfl

@[simp] theorem of_hom_inv_symm_apply {R : Type u_1} {S : Type u_2} [semiring R] [semiring S]
    (hom : R →+* S) (inv : S →+* R) (hom_inv_id : ring_hom.comp inv hom = ring_hom.id R)
    (inv_hom_id : ring_hom.comp hom inv = ring_hom.id S) (s : S) :
    coe_fn (ring_equiv.symm (of_hom_inv hom inv hom_inv_id inv_hom_id)) s = coe_fn inv s :=
  rfl

end ring_equiv

namespace mul_equiv

/-- Gives a `ring_equiv` from a `mul_equiv` preserving addition.-/
def to_ring_equiv {R : Type u_1} {S : Type u_2} [Add R] [Add S] [Mul R] [Mul S] (h : R ≃* S)
    (H : ∀ (x y : R), coe_fn h (x + y) = coe_fn h x + coe_fn h y) : R ≃+* S :=
  ring_equiv.mk (equiv.to_fun (to_equiv h)) (equiv.inv_fun (to_equiv h)) sorry sorry (map_mul' h)
    sorry

end mul_equiv

namespace ring_equiv

@[simp] theorem trans_symm {R : Type u_1} {S : Type u_2} [Add R] [Add S] [Mul R] [Mul S]
    (e : R ≃+* S) : ring_equiv.trans e (ring_equiv.symm e) = ring_equiv.refl R :=
  ext (left_inv e)

@[simp] theorem symm_trans {R : Type u_1} {S : Type u_2} [Add R] [Add S] [Mul R] [Mul S]
    (e : R ≃+* S) : ring_equiv.trans (ring_equiv.symm e) e = ring_equiv.refl S :=
  ext (right_inv e)

/-- If two rings are isomorphic, and the second is an integral domain, then so is the first. -/
protected theorem is_integral_domain {A : Type u_1} (B : Type u_2) [ring A] [ring B]
    (hB : is_integral_domain B) (e : A ≃+* B) : is_integral_domain A :=
  sorry

/-- If two rings are isomorphic, and the second is an integral domain, then so is the first. -/
protected def integral_domain {A : Type u_1} (B : Type u_2) [ring A] [integral_domain B]
    (e : A ≃+* B) : integral_domain A :=
  integral_domain.mk ring.add ring.add_assoc ring.zero ring.zero_add ring.add_zero ring.neg ring.sub
    ring.add_left_neg ring.add_comm ring.mul ring.mul_assoc ring.one ring.one_mul ring.mul_one
    ring.left_distrib ring.right_distrib sorry sorry sorry

end ring_equiv

namespace equiv

/-- In a division ring `K`, the unit group `units K`
is equivalent to the subtype of nonzero elements. -/
-- TODO: this might already exist elsewhere for `group_with_zero`

-- deduplicate or generalize

def units_equiv_ne_zero (K : Type u_4) [division_ring K] :
    units K ≃ ↥(set_of fun (a : K) => a ≠ 0) :=
  mk (fun (a : units K) => { val := units.val a, property := sorry })
    (fun (a : ↥(set_of fun (a : K) => a ≠ 0)) => units.mk0 (subtype.val a) sorry) sorry sorry

@[simp] theorem coe_units_equiv_ne_zero {K : Type u_4} [division_ring K] (a : units K) :
    ↑(coe_fn (units_equiv_ne_zero K) a) = ↑a :=
  rfl

end Mathlib


import tactic.auto_cases
import tactic.tidy
import tactic.with_local_reducibility
import tactic.show_term
import analysis.calculus.fderiv

import analysis.special_functions.exp_log

/-- User attribute used to mark tactics used by `differentiability`. -/
@[user_attribute]
meta def differentiability : user_attribute :=
{ name := `differentiability,
  descr := "lemmas usable to prove differentiablility" }

-- Mark some differentiability lemmas already defined in `topology.basic`
attribute [differentiability]
  differentiable_at_id
  differentiable_at_const

-- As we will be using `apply_rules` with `md := semireducible`,
-- we need another version of `differentiable_id`.
@[differentiability] lemma differentiable_at_id_t
    {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
    {E : Type*} [normed_group E] [normed_space 𝕜 E] {x : E} : differentiable_at 𝕜 id x :=
(has_fderiv_at_id x).differentiable_at

namespace tactic

meta def apply_differentiability.comp : tactic unit :=
`[fail_if_success { exact differentiable_at_const };
  refine differentiable_at.comp _ _;
  fail_if_success { exact differentiable_at_id }]

/-- List of tactics used by `differentiability` internally. -/
meta def differentiability_tactics (md : transparency := reducible) : list (tactic string) :=
[
  intros1               >>= λ ns, pure ("intros " ++ (" ".intercalate (ns.map (λ e, e.to_string)))),
  apply_rules [``(differentiability)] 50 { md := md }
                        >> pure "apply_rules differentiablity",
  apply_differentiability.comp >> pure "refine differentiable_at.comp _ _"
]

namespace interactive
setup_tactic_parser

/--
Solve goals of the form `differentiable f`. `differentiability?` reports back the proof term it found.
-/
meta def differentiability
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) : tactic unit :=
let md              := if bang.is_some then semireducible else reducible,
    differentiability_core := tactic.tidy { tactics := differentiability_tactics md, ..cfg },
    trace_fn        := if trace.is_some then show_term else id in
trace_fn differentiability_core

/-- Version of `differentiability` for use with auto_param. -/
meta def differentiability' : tactic unit := differentiability none none {}

/--
`differentiability` solves goals of the form `differentiable f` by applying lemmas tagged with the
`differentiability` user attribute.

I have no idea what it does, I just stole Reid's code and changed a few things.

You can also use `differentiability!`, which applies lemmas with `{ md := semireducible }`.
The default behaviour is more conservative, and only unfolds `reducible` definitions
when attempting to match lemmas with the goal.

`differentiability?` reports back the proof term it found.
-/
add_tactic_doc
{ name := "differentiability / differentiability'",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.differentiability, `tactic.interactive.differentiability'],
  tags := ["lemma application"]
}

end interactive

end tactic


import set_theory.surreal tactic.ring
import set_theory.game

open pgame
namespace pgame
universe u

local infix ` ≈ ` := pgame.equiv

def sub_congr {w x y z : pgame}
  (h₁ : w ≈ x) (h₂ : y ≈ z) : (w - y) ≈ (x - z) :=
sorry

meta def try_inl_inr : tactic unit :=
`[assumption]
    <|> (do `[apply sum.inr], try_inl_inr )
    <|> (do `[apply sum.inl], try_inl_inr )
    <|> (do `[apply prod.mk], try_inl_inr, try_inl_inr )

lemma equiv_of_mk_equiv {x y : pgame} (L : x.left_moves ≃ y.left_moves) (R : x.right_moves ≃ y.right_moves)
         (hl : ∀ (i : x.left_moves), (x.move_left i).equiv (y.move_left (L i)))
         (hr : ∀ (j : y.right_moves), (x.move_right (R.symm j)).equiv (y.move_right j)) :
       x.equiv y :=
sorry

/-- `(x + y) * z` is equivalent to `x * z + y * z.`-/
theorem right_distrib_equiv (x y z : pgame) : (x + y) * z ≈ x * z + y * z :=
sorry

theorem left_distrib_equiv : Π (x y z : pgame), (x * (y + z)).equiv (x * y + x * z)
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
sorry

set_option trace.solve_by_elim true

lemma aux'' {a b c d x y z c' : pgame} :
  (a + b - c) * z + x * y * c' - (a + b - c) * d
  ≈ a * z + b * z - c * z + x * y * c' - a * d + b * d + c * d :=
sorry

lemma aux' {a b c x y z : pgame} :
a * (y * z) + x * (b * z) - a * (b * z) + x * (y * c) - a * (y * c) + x * (b * c) + a * (b * c)
  ≈ a * (y * z) + x * (b * z + y * c - b * c) - a * (b * z + y * c - b * c)
:= sorry

theorem eq_of_mk_eq {x y : pgame}
  (L : x.left_moves ≃ y.left_moves) (R : x.right_moves ≃ y.right_moves)
  (hl : ∀ (i : x.left_moves), ⟦x.move_left i⟧ = ⟦y.move_left (L i)⟧)
  (hr : ∀ (j : y.right_moves), ⟦x.move_right (R.symm j)⟧ = ⟦y.move_right j⟧) :
  ⟦x⟧ = ⟦y⟧ := sorry

theorem left_distrib : Π (x y z : pgame), ⟦x * (y + z)⟧ = ⟦x * y⟧ + ⟦x * z⟧
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  let z := mk zl zr zL zR,
  refine eq_of_mk_eq _ _ _ _,
  { fsplit,
    { rintros (⟨_,(_|_)⟩|⟨_,(_|_)⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintros ((⟨_,_⟩|⟨_,_⟩)|(⟨_,_⟩|⟨_,_⟩));
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintros (⟨_,(_|_)⟩|⟨_,(_|_)⟩); refl },
    { rintros ((⟨_,_⟩|⟨_,_⟩)|(⟨_,_⟩|⟨_,_⟩)); refl } },
  { fsplit,
    { rintros (⟨_,(_|_)⟩|⟨_,(_|_)⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintros ((⟨_,_⟩|⟨_,_⟩)|(⟨_,_⟩|⟨_,_⟩));
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintros (⟨_,(_|_)⟩|⟨_,(_|_)⟩); refl },
    { rintros ((⟨_,_⟩|⟨_,_⟩)|(⟨_,_⟩|⟨_,_⟩)); refl } },
    { rintros (⟨i,(j|k)⟩|⟨i,(j|k)⟩),
      { change ⟦xL i * (y + z) + x * (yL j + z) - xL i * (yL j + z)⟧
                = ⟦xL i * y + x * yL j - xL i * yL j + x * z⟧,
        simp[left_distrib], abel },
      { change ⟦xL i * (y + z) + x * (y + zL k) - xL i * (y + zL k)⟧
              = ⟦x * y + (xL i * z + x * zL k - xL i * zL k)⟧,
        simp[left_distrib], abel },
      { change ⟦xR i * (y + z) + x * (yR j + z) - xR i * (yR j + z)⟧
              = ⟦xR i * y + x * yR j - xR i * yR j + x * z⟧,
        simp[left_distrib], abel },
      { change ⟦xR i * (y + z) + x * (y + zR k) - xR i * (y + zR k)⟧
              = ⟦x * y + (xR i * z + x * zR k - xR i * zR k)⟧,
        simp[left_distrib], abel } },
    { rintros ((⟨i,j⟩|⟨i,j⟩)|(⟨i,k⟩|⟨i,k⟩)),
      { change ⟦xL i * (y + z) + x * (yR j + z) - xL i * (yR j + z)⟧
              = ⟦xL i * y + x * yR j - xL i * yR j + x * z⟧,
        simp[left_distrib], abel },
      { change ⟦xR i * (y + z) + x * (yL j + z) - xR i * (yL j + z)⟧
              = ⟦xR i * y + x * yL j - xR i * yL j + x * z⟧,
        simp[left_distrib], abel },
      { change ⟦xL i * (y + z) + x * (y + zR k) - xL i * (y + zR k)⟧
              = ⟦x * y + (xL i * z + x * zR k - xL i * zR k)⟧,
        simp[left_distrib], abel },
      { change ⟦xR i * (y + z) + x * (y + zL k) - xR i * (y + zL k)⟧
              = ⟦x * y + (xR i * z + x * zL k - xR i * zL k)⟧,
        simp[left_distrib], abel } }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem mul_zero : Π (x : pgame), ⟦x * 0⟧ = ⟦0⟧ := sorry
theorem mul_one : Π (x : pgame), ⟦x * 1⟧ = ⟦x⟧
| (mk xl xr xL xR) :=
begin
  let x := mk xl xr xL xR,
  refine eq_of_mk_eq _ _ _ _,
  { fsplit,
     rintros (⟨_, ⟨ ⟩⟩ | ⟨_, ⟨ ⟩⟩), assumption,
     rintros i,  exact sum.inl(i, punit.star),
     rintros (⟨_, ⟨ ⟩⟩ | ⟨_, ⟨ ⟩⟩), refl,
     rintros i, refl,
  },
  { fsplit,
    rintros (⟨_, ⟨ ⟩⟩ | ⟨_, ⟨ ⟩⟩), assumption,
    rintros i,  exact sum.inr(i, punit.star),
    rintros (⟨_, ⟨ ⟩⟩ | ⟨_, ⟨ ⟩⟩), refl,
    rintros i, refl,
  },
  rintros (⟨i, ⟨ ⟩⟩ | ⟨i, ⟨ ⟩⟩),
  change ⟦xL i * 1 + x * 0 - xL i * 0⟧ = ⟦xL i⟧,
  simp [mul_zero, mul_one],

  rintros j,
  change ⟦xR j * 1 + x * 0 - xR j * 0⟧ = ⟦xR j⟧,
  simp [mul_zero, mul_one],
end

#check left_distrib
theorem mul_assoc_equiv : Π (x y z : pgame), ((x * y) * z).equiv (x * (y * z))
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  let z := mk zl zr zL zR,
  refine equiv_of_mk_equiv _ _ _ _,
  { fsplit,
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩); try_inl_inr },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_,⟨_, _⟩ | ⟨_, _⟩⟩); try_inl_inr },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_,_⟩ | ⟨_, _⟩,_⟩); refl },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_,⟨_, _⟩ | ⟨_, _⟩⟩); refl } },
  { fsplit,
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩,_⟩); try_inl_inr },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_,⟨_, _⟩ | ⟨_, _⟩⟩); try_inl_inr },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_,_⟩ | ⟨_, _⟩,_⟩); refl },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩); refl } },
  { rintro (⟨⟨i, j⟩ | ⟨i, j⟩, k⟩ | ⟨⟨i, j⟩ | ⟨i, j⟩, k⟩),
    { calc
        (xL i * y + x * yL j - xL i * yL j) * z + (x * y) * zL k
          - (xL i * y + x * yL j - xL i * yL j) * zL k
            ≈ (xL i * y) * z + (x * yL j) * z - (xL i * yL j) * z + (x * y) * zL k
                  - (xL i * y) * zL k + (x * yL j) * zL k + (xL i * yL j) * zL k
            : aux''
        ... ≈ xL i * (y * z) + x * (yL j * z) - xL i * (yL j * z) + x * (y * zL k)
                 - xL i * (y * zL k) + x * (yL j * zL k) + xL i * (yL j * zL k)
            : by { repeat { apply add_congr <|> apply neg_congr }; apply mul_assoc_equiv }
        ... ≈ xL i * (y * z) + x * (yL j * z + y * zL k - yL j * zL k)
                 - xL i * (yL j * z + y * zL k - yL j * zL k)
            : aux' },

    repeat {sorry}, },
  repeat {sorry},
end

end pgame


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

Deterministic operators.
-/
import .tgrads .util .tcont .det

namespace certigrad
open T list

namespace ops

section tactic
open tactic

meta def idx_over : tactic unit :=
do exfalso, to_expr ```(at_idx_over H_at_idx dec_trivial) >>= exact

meta def simp_simple : tactic unit :=
do s₀ ← simp_lemmas.mk_default,
   s ← return $ simp_lemmas.erase s₀ $ [`add_comm, `add_left_comm, `mul_comm, `mul_left_comm],
   simplify_goal s {} >> try triv >> try (reflexivity reducible)

meta def prove_odiff : tactic unit :=
do get_local `f_odiff >>= clear,
   to_expr ```(shape = fshape) >>= λ ty, to_expr ```(eq.symm H_at_idx^.right) >>= λ val, assertv `H_fshape_eq ty val,
   get_local `H_fshape_eq >>= subst,
   dunfold [`certigrad.det.is_odifferentiable],
   try simp_simple,
   try dsimp,
   prove_differentiable

meta def prove_pb_correct_init : tactic unit :=
do get_local `f_pb_correct >>= clear,
   to_expr ```(shape = fshape) >>= λ ty, to_expr ```(eq.symm H_at_idx^.right) >>= λ val, assertv `H_fshape_eq ty val,
   get_local `H_fshape_eq >>= subst,
   to_expr ```(T shape → ℝ) >>= λ ty, to_expr ```(λ (z : T shape), T.dot z g_out) >>= definev `k ty,
   to_expr ```(∇ k y = g_out) >>= assert `H_k_grad, dsimp, rewrite `certigrad.T.grad_dot₁,
   get_local `H_k_grad >>= rewrite_core reducible tt tt occurrences.all tt,
   get_local `H_y >>= subst

meta def prove_pb_correct : tactic unit :=
do prove_pb_correct_init,
   try simp_simple,
   try dsimp,
   mk_const `certigrad.T.grad_tmulT >>= rewrite_core reducible tt tt occurrences.all tt,
   simplify_grad,
   try simp,
   try reflexivity

meta def prove_ocont_init : tactic unit :=
do get_local `f_ocont >>= clear,
   to_expr ```(shape = ishape) >>= λ ty, to_expr ```(eq.symm H_at_idx^.right) >>= λ val, assertv `H_ishape_eq ty val,
   get_local `H_ishape_eq >>= subst,
   try simp_simple,
   try dsimp

meta def prove_ocont : tactic unit :=
do prove_ocont_init,
   repeat (prove_continuous_core <|> prove_preconditions_core)

end tactic

open det

namespace scale

def f (α : ℝ) {shape : S} (xs : dvec T [shape]) : T shape := α ⬝ xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb (α : ℝ) {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (α ⬝ gy) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff (α : ℝ) {shape : S} : is_odifferentiable (@f α shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct (α : ℝ) {shape : S} : pullback_correct (@f α shape) (@f_pre shape) (@f_pb α shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont (α : ℝ) {shape : S} : is_ocontinuous (@f α shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end scale

section open scale
def scale (α : ℝ) (shape : S) : det.op [shape] shape :=
det.op.mk "scale" (f α) f_pre (f_pb α) (f_odiff α) (f_pb_correct α) (f_ocont α)

end

namespace neg

def f {shape : S} (xs : dvec T [shape]) : T shape := - xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (-gy) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end neg

section open neg
def neg (shape : S) : det.op [shape] shape :=
det.op.mk "neg" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace exp

def f {shape : S} (xs : dvec T [shape]) : T shape := exp xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (gy * y) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end exp

section open exp
def exp (shape : S) : det.op [shape] shape :=
det.op.mk "exp" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace log

def f {shape : S} (xs : dvec T [shape]) : T shape := log xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, xs^.head > 0
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (gy / xs^.head) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end log

section open log
def log (shape : S) : det.op [shape] shape :=
det.op.mk "log" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace sqrt

def f {shape : S} (xs : dvec T [shape]) : T shape := sqrt xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, 0 < xs^.head
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (gy / (2 * y)) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end sqrt

section open sqrt
def sqrt (shape : S) : det.op [shape] shape :=
det.op.mk "sqrt" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace sigmoid

def f {shape : S} (xs : dvec T [shape]) : T shape := sigmoid xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape :=
force (gy * y * (1 - y)) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end sigmoid

section open sigmoid
def sigmoid (shape : S) : det.op [shape] shape :=
det.op.mk "sigmoid" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace softplus

def f {shape : S} (xs : dvec T [shape]) : T shape := softplus xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape :=
force (gy / (1 + T.exp (- xs^.head))) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| xs H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| xs (n+1) ishape H_at_idx H_pre := by idx_over

end softplus

section open softplus
def softplus (shape : S) : det.op [shape] shape :=
det.op.mk "softplus" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace add

def f {shape : S} (xs : dvec T [shape, shape]) : T shape := xs^.head + xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : T shape) (idx : ℕ) (fshape : S) : T fshape := force (gy) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x, y⟧ H_pre 0 fshape H_at_idx k H_k := by { prove_odiff }
| ⟦x, y⟧ H_pre 1 fshape H_at_idx k H_k := by { prove_odiff }
| xs    H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x₁, x₂⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| ⟦x₁, x₂⟧ y H_y g_out 1 fshape H_at_idx H_pre := by prove_pb_correct
| xs      y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x₁, x₂⟧ 0     ishape H_at_idx H_pre := by prove_ocont
| ⟦x₁, x₂⟧ 1     ishape H_at_idx H_pre := by prove_ocont
| xs      (n+2) ishape H_at_idx H_pre := by idx_over

end add

section open add
def add (shape : S) : det.op [shape, shape] shape :=
det.op.mk "add" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace mul

def f {shape : S} (xs : dvec T [shape, shape]) : T shape := xs^.head * xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, true

def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : T shape) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy * xs^.head2) fshape
| 1     fshape := force (gy * xs^.head) fshape
| (n+2) fshape := T.error "mul: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x, y⟧ H_pre 0 fshape H_at_idx k H_k := by { prove_odiff }
| ⟦x, y⟧ H_pre 1 fshape H_at_idx k H_k := by { prove_odiff }
| xs    H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x₁, x₂⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| ⟦x₁, x₂⟧ y H_y g_out 1 fshape H_at_idx H_pre := by prove_pb_correct
| xs      y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x₁, x₂⟧ 0     ishape H_at_idx H_pre := by prove_ocont
| ⟦x₁, x₂⟧ 1     ishape H_at_idx H_pre := by prove_ocont
| xs      (n+2) ishape H_at_idx H_pre := by idx_over

end mul

section open mul
def mul (shape : S) : det.op [shape, shape] shape :=
det.op.mk "mul" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace sub

def f {shape : S} (xs : dvec T [shape, shape]) : T shape := xs^.head - xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, true

def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : T shape) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy) fshape
| 1     fshape := force (- gy) fshape
| (n+2) fshape := T.error "sub: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x, y⟧ H_pre 0 fshape H_at_idx k H_k := by { prove_odiff }
| ⟦x, y⟧ H_pre 1 fshape H_at_idx k H_k := by { prove_odiff }
| xs    H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x₁, x₂⟧ y H_y g_out 0 fshape H_at_idx H_pre := by prove_pb_correct
| ⟦x₁, x₂⟧ y H_y g_out 1 fshape H_at_idx H_pre := by prove_pb_correct
| xs      y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x₁, x₂⟧ 0     ishape H_at_idx H_pre := by prove_ocont
| ⟦x₁, x₂⟧ 1     ishape H_at_idx H_pre := by prove_ocont
| xs      (n+2) ishape H_at_idx H_pre := by idx_over

end sub

section open sub
def sub (shape : S) : det.op [shape, shape] shape :=
det.op.mk "sub" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace div

def f {shape : S} (xs : dvec T [shape, shape]) : T shape := xs^.head / xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, 0 < T.square xs^.head2

def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : T shape) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy / xs^.head2) fshape
| 1     fshape := force (- (gy * xs^.head) / (T.square xs^.head2)) fshape
| (n+2) fshape := T.error "div: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x, y⟧ H_pre 0 fshape H_at_idx k H_k := by { prove_odiff }
| ⟦x, y⟧ H_pre 1 fshape H_at_idx k H_k := by { prove_odiff }
| xs    H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x₁, x₂⟧ y H_y g_out 0 fshape H_at_idx H_pre := begin prove_pb_correct end
| ⟦x₁, x₂⟧ y H_y g_out 1 fshape H_at_idx H_pre := by prove_pb_correct
| xs      y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x₁, x₂⟧ 0     ishape H_at_idx H_pre := by prove_ocont
| ⟦x₁, x₂⟧ 1     ishape H_at_idx H_pre := by prove_ocont
| xs      (n+2) ishape H_at_idx H_pre := by idx_over

end div

section open div
def div (shape : S) : det.op [shape, shape] shape :=
det.op.mk "div" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace sum

def f {shape : S} (xs : dvec T [shape]) : ℝ := T.sum xs^.head
def f_pre {shape : S} : precondition [shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape]) (y gy : ℝ) (idx : ℕ) (fshape : S) : T fshape := force (T.const gy shape) fshape

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦x⟧ H_pre 0 fshape H_at_idx k H_k := by prove_odiff
| ⟦x⟧ H_pre (n+1) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦x⟧ y H_y g_out 0 fshape H_at_idx H_pre :=
begin
clear f_pb_correct,
assertv H_fshape_eq : shape = fshape := eq.symm H_at_idx^.right,
subst H_fshape_eq,
definev k : ℝ → ℝ := (λ θ, dot g_out θ),
assert H_grad : ∇ k y = g_out,
{ change ∇ (λ θ, dot g_out θ) y = g_out, rw certigrad.T.grad_dot₂ },
rw -H_grad,
subst H_y,
simp, dsimp,
dunfold dvec.get dvec.head dvec.update_at,
rw -T.grad_tmulT,
rw T.grad_sum k,
simp [T.smul.def]
end

| xs y H_y g_out (n+1) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦x⟧ 0 ishape H_at_idx H_pre := by prove_ocont
| ⟦x⟧ (n+1) ishape H_at_idx H_pre := by idx_over

end sum

section open sum
-- TODO(dhs): why won't it find `f` without `sum.`? Bug in Lean?
def sum (shape : S) : det.op [shape] [] :=
det.op.mk "sum" sum.f sum.f_pre sum.f_pb sum.f_odiff sum.f_pb_correct sum.f_ocont
end

namespace gemm

def f {m n p : ℕ} (xs : dvec T [[m, n], [n, p]]) : T [m, p] := gemm xs^.head xs^.head2
def f_pre {m n p : ℕ} : precondition [[m, n], [n, p]] := λ xs, true
def f_pb {m n p : ℕ} (xs : dvec T [[m, n], [n, p]]) (y gy : T [m, p]) : Π (idx : ℕ) (fshape : S), T fshape
| 0 fshape := force (T.gemm gy (transpose $ xs^.head2)) fshape
| 1 fshape := force (T.gemm (transpose $ xs^.head) gy) fshape
| (n+2) fshape := T.error "gemm: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {m n p : ℕ} : is_odifferentiable (@f m n p) (@f_pre m n p)
| ⟦x₁, x₂⟧ H_pre 0 fshape H_at_idx k H_k := begin definev shape : S := [m, n], prove_odiff end
| ⟦x₁, x₂⟧ H_pre 1 fshape H_at_idx k H_k := begin definev shape : S := [n, p], prove_odiff end
| xs      H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {m n p : ℕ} : pullback_correct (@f m n p) (@f_pre m n p) (@f_pb m n p)
| ⟦x₁, x₂⟧ y H_y g_out 0 fshape H_fshape_at_idx H_pre :=
begin
clear f_pb_correct,
assertv H_fshape_eq : [m, n] = fshape := eq.symm H_fshape_at_idx^.right,
subst H_fshape_eq,
definev k : T [m, p] → ℝ := (λ θ, dot g_out θ),
assert H_grad : ∇ k y = g_out,
{ change ∇ (λ θ, dot g_out θ) y = g_out, rw certigrad.T.grad_dot₂ },
rw -H_grad,
subst H_y,
simp, dsimp,
rw [-T.grad_tmulT, T.grad_gemm₁ k]
end

| ⟦x₁, x₂⟧ y H_y g_out 1 fshape H_fshape_at_idx H_pre :=
begin
clear f_pb_correct,
assertv H_fshape_eq : [n, p] = fshape := eq.symm H_fshape_at_idx^.right,
subst H_fshape_eq,
definev k : T [m, p] → ℝ := (λ θ, dot g_out θ),
assert H_grad : ∇ k y = g_out,
{ change ∇ (λ θ, dot g_out θ) y = g_out, rw certigrad.T.grad_dot₂ },
rw -H_grad,
subst H_y,
simp, dsimp,
rw [-T.grad_tmulT, T.grad_gemm₂ k]
end

| xs y H_y g_out (n+2) fshape H_fshape_at_idx H_pre := false.rec _ (at_idx_over H_fshape_at_idx (by tactic.dec_triv))

lemma f_ocont {m n p : ℕ} : is_ocontinuous (@f m n p) (@f_pre m n p)
| ⟦x₁, x₂⟧ 0     ishape H_at_idx H_pre := by { pose shape := [m, n], prove_ocont }
| ⟦x₁, x₂⟧ 1     ishape H_at_idx H_pre := by { pose shape := [n, p], prove_ocont }
| xs      (n+2) ishape H_at_idx H_pre := by idx_over

end gemm

section open gemm
def gemm (m n p : ℕ) : det.op [[m, n], [n, p]] [m, p] :=
det.op.mk "gemm" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace mvn_kl

def f {shape : S} (xs : dvec T [shape, shape]) : ℝ := mvn_kl xs^.head xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, 0 < xs^.head2

def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : ℝ) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy ⬝ xs^.head) fshape
| 1     fshape := force (gy ⬝ (xs^.head2 - (1 / xs^.head2))) fshape
| (n+2) fshape := T.error "mvn_kl: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦μ, σ⟧ H_pre 0     fshape H_at_idx k H_k := by prove_odiff
| ⟦μ, σ⟧ H_pre 1     fshape H_at_idx k H_k := by prove_odiff
| xs    H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦μ, σ⟧ y H_y g_out 0 fshape H_fshape_at_idx H_pre :=
begin
clear f_pb_correct,
assertv H_fshape_eq : shape = fshape := eq.symm H_fshape_at_idx^.right,
subst H_fshape_eq,
definev k : ℝ → ℝ := λ (x : ℝ), x * g_out,
assertv H_k_grad : ∇ k y = g_out :=  by { dsimp, erw [T.grad_mul₁ id, T.grad_id, one_mul] },
rw -H_k_grad,
subst H_y,
dsimp,
simp,
rw -T.grad_tmulT,
simplify_grad,
simp [T.smul.def]
end

| ⟦μ, σ⟧ y H_y g_out 1 fshape H_at_idx H_pre :=
have H_σ₂ : square σ > 0, from square_pos_of_pos H_pre,
have H_diff₁ : is_cdifferentiable (λ (θ₀ : T shape), g_out * (-2⁻¹ * T.sum (1 + T.log (square θ₀) - square μ - square σ))) σ, by prove_differentiable,
have H_diff₂ : is_cdifferentiable (λ (θ₀ : T shape), g_out * (-2⁻¹ * T.sum (1 + T.log (square σ) - square μ - square θ₀))) σ, by prove_differentiable,
begin
clear f_pb_correct,
assertv H_fshape_eq : shape = fshape := eq.symm H_at_idx^.right,
subst H_fshape_eq,
definev k : ℝ → ℝ := λ (x : ℝ), x * g_out,
assertv H_k_grad : ∇ k y = g_out :=  by { dsimp, erw [T.grad_mul₁ id, T.grad_id, one_mul] },
rw -H_k_grad,
subst H_y,
dsimp,
simp,
rw -T.grad_tmulT,
dunfold T.mvn_kl,

rw (T.grad_binary (λ θ₁ θ₂, g_out * ((- 2⁻¹) * T.sum (1 + T.log (square θ₁) - square μ - square θ₂))) _ H_diff₁ H_diff₂),
dsimp,
simplify_grad,

simp [T.smul.def, T.const_neg, T.const_mul, T.const_zero,
      T.const_one, T.const_bit0, T.const_bit1, T.const_inv,
      left_distrib, right_distrib],
rw T.mul_inv_cancel two_pos,
erw T.neg_div,
simp [mul_neg_eq_neg_mul_symm, neg_mul_eq_neg_mul_symm],
apply congr_arg, apply congr_arg,
simp only [T.mul_div_mul, square],
rw [-mul_assoc, T.mul_div_mul, (@T.div_self_square _ σ H_pre)],
simp,
rw [T.mul_inv_cancel two_pos],
simp,
rw T.div_mul_inv,
end

| ⟦μ, σ⟧ y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦μ, σ⟧ 0     ishape H_at_idx H_pre := by { prove_ocont, apply T.continuous_mvn_kl₁, exact H_pre }
| ⟦μ, σ⟧ 1     ishape H_at_idx H_pre := by { prove_ocont }
| ⟦μ, σ⟧ (n+2) ishape H_at_idx H_pre := by idx_over

end mvn_kl

section open mvn_kl
def mvn_kl (shape : S) : det.op [shape, shape] [] :=
det.op.mk "mvn_kl" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

-- Seems silly but saves some fresh-name tracking in reparam
namespace mul_add

def f {shape : S} (xs : dvec T [shape, shape, shape]) : T shape := (xs^.head * xs^.head2) + xs^.head3
def f_pre {shape : S} : precondition [shape, shape, shape] := λ xs, true
def f_pb {shape : S} (xs : dvec T [shape, shape, shape]) (y gy : T shape) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy * xs^.head2) fshape
| 1     fshape := force (gy * xs^.head) fshape
| 2     fshape := force gy fshape
| (n+3) _      := T.error "mul_add: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦z, σ, μ⟧ H_pre 0     fshape H_at_idx k H_k := by prove_odiff
| ⟦z, σ, μ⟧ H_pre 1     fshape H_at_idx k H_k := by prove_odiff
| ⟦z, σ, μ⟧ H_pre 2     fshape H_at_idx k H_k := by prove_odiff
| xs       H_pre (n+3) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦z, σ, μ⟧ y H_y g_out 0 fshape H_at_idx H_pre :=
begin
prove_pb_correct_init,
simp only [f, f_pre, f_pb, force_ok, dif_pos],
dsimp,
simp only [dif_pos, dif_neg],
dsimp,
rw -T.grad_tmulT,
simplify_grad,
reflexivity
end

| ⟦z, σ, μ⟧ y H_y g_out 1 fshape H_at_idx H_pre :=
begin
prove_pb_correct_init,
simp without mul_comm add_comm,
dsimp,
rw -T.grad_tmulT,
simplify_grad,
reflexivity
end

| ⟦z, σ, μ⟧ y H_y g_out 2 fshape H_at_idx H_pre :=
begin
prove_pb_correct_init,
simp without mul_comm add_comm,
dsimp,
rw -T.grad_tmulT,
simplify_grad,
reflexivity
end

| xs y H_y g_out (n+3) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦z, σ, μ⟧ 0     ishape H_at_idx H_pre := by prove_ocont
| ⟦z, σ, μ⟧ 1     ishape H_at_idx H_pre := by prove_ocont
| ⟦z, σ, μ⟧ 2     ishape H_at_idx H_pre := by prove_ocont
| xs       (n+3) ishape H_at_idx H_pre := by idx_over

end mul_add

section open mul_add
def mul_add (shape : S) : det.op [shape, shape, shape] shape :=
det.op.mk "mul_add" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

namespace bernoulli_neglogpdf

def f {shape : S} (xs : dvec T [shape, shape]) : ℝ := bernoulli_neglogpdf xs^.head xs^.head2
def f_pre {shape : S} : precondition [shape, shape] := λ xs, 0 < xs^.head ∧ xs^.head < 1

def f_pb {shape : S} (xs : dvec T [shape, shape]) (y gy : ℝ) : Π (idx : ℕ) (fshape : S), T fshape
| 0     fshape := force (gy ⬝ (1 - xs^.head2) / (eps shape + (1 - xs^.head)) - gy ⬝ (xs^.head2 / (eps shape + xs^.head))) fshape
| 1     fshape := force (gy ⬝ T.log (eps shape + (1 - xs^.head)) - gy ⬝ T.log (eps shape + xs^.head)) fshape
| (n+2) fshape := T.error "bernoulli_neglogpdf: index too large"

attribute [simp] f f_pre f_pb

lemma f_odiff {shape : S} : is_odifferentiable (@f shape) (@f_pre shape)
| ⟦p, z⟧ H_pre 0 fshape H_at_idx k H_k :=
have H_p₁ : p > 0, from H_pre^.left,
have H_p₂ : p < 1, from H_pre^.right,
by prove_odiff

| ⟦p, z⟧ H_pre 1 fshape H_at_idx k H_k := by prove_odiff
| ⟦μ, σ⟧ H_pre (n+2) fshape H_at_idx k H_k := by idx_over

lemma f_pb_correct {shape : S} : pullback_correct (@f shape) (@f_pre shape) (@f_pb shape)
| ⟦p, z⟧ y H_y g_out 0 fshape H_at_idx H_pre :=
have H_p : p > 0, from H_pre^.left,
have H_1mp : 1 - p > 0, from lt1_alt H_pre^.right,
have H_diff₁ : is_cdifferentiable (λ (θ₀ : T shape), g_out * -T.sum (z * T.log (eps shape + θ₀) + (1 - z) * T.log (eps shape + (1 - p)))) p, by prove_differentiable,
have H_diff₂ : is_cdifferentiable (λ (θ₀ : T shape), g_out * -T.sum (z * T.log (eps shape + p) + (1 - z) * T.log (eps shape + (1 - θ₀)))) p, by prove_differentiable,

begin
clear f_pb_correct,
assertv H_fshape_eq : shape = fshape := eq.symm H_at_idx^.right,
subst H_fshape_eq,
definev k : ℝ → ℝ := λ (x : ℝ), x * g_out,
assertv H_k_grad : ∇ k y = g_out :=  by { dsimp, erw [T.grad_mul₁ id, T.grad_id, one_mul] },
rw -H_k_grad,
subst H_y,
dsimp,
simp ,
rw -T.grad_tmulT,
dunfold T.bernoulli_neglogpdf,
rw T.grad_binary (λ θ₁ θ₂, g_out * - T.sum (z * T.log (eps shape + θ₁) + (1 - z) * T.log (eps shape + (1 - θ₂)))) _ H_diff₁ H_diff₂,
dsimp,
note H₁ := H_pre^.left,
note H₂ := lt1_alt H_pre^.right,
simplify_grad,
simp [T.smul.def, T.neg_div, T.const_neg],
rw [T.mul_div_mul],
simp [T.div_mul_inv],
end

| ⟦p, z⟧ y H_y g_out 1 fshape H_at_idx H_pre :=
have H_diff₁ : is_cdifferentiable (λ (θ₀ : T shape), g_out * -T.sum (θ₀ * T.log (eps shape + p) + (1 - z) * T.log (eps shape + (1 - p)))) z, by prove_differentiable,
have H_diff₂ : is_cdifferentiable (λ (θ₀ : T shape), g_out * -T.sum (z * T.log (eps shape + p) + (1 - θ₀) * T.log (eps shape + (1 - p)))) z, by prove_differentiable,

begin
clear f_pb_correct,
assertv H_fshape_eq : shape = fshape := eq.symm H_at_idx^.right,
subst H_fshape_eq,
definev k : ℝ → ℝ := λ (x : ℝ), x * g_out,
assertv H_k_grad : ∇ k y = g_out :=  by { dsimp, erw [T.grad_mul₁ id, T.grad_id, one_mul] },
rw -H_k_grad,
subst H_y,
dsimp,
simp,
rw -T.grad_tmulT,
dunfold T.bernoulli_neglogpdf,
rw T.grad_binary (λ θ₁ θ₂, g_out * - T.sum (θ₁ * T.log (eps shape + p) + (1 - θ₂) * T.log (eps shape + (1 - p)))) _ H_diff₁ H_diff₂,
dsimp,
simplify_grad,
simp [T.smul.def, const_neg],
end

| xs y H_y g_out (n+2) fshape H_at_idx H_pre := by idx_over

lemma f_ocont {shape : S} : is_ocontinuous (@f shape) (@f_pre shape)
| ⟦μ, σ⟧ 0     ishape H_at_idx H_pre := by { prove_ocont_init, apply continuous_bernoulli_neglogpdf₁, exact H_pre^.left, exact lt1_alt H_pre^.right }
| ⟦μ, σ⟧ 1     ishape H_at_idx H_pre := by { prove_ocont_init, apply continuous_bernoulli_neglogpdf₂, exact H_pre^.left, exact lt1_alt H_pre^.right }
| ⟦μ, σ⟧ (n+2) ishape H_at_idx H_pre := by idx_over

end bernoulli_neglogpdf

section
open bernoulli_neglogpdf
def bernoulli_neglogpdf (shape : S) : det.op [shape, shape] [] :=
det.op.mk "bernoulli_neglogpdf" f f_pre f_pb f_odiff f_pb_correct f_ocont
end

end ops

-- TODO(dhs): confirm I don't need this any more
/-
lemma mvn_kl_pre {shape : S} (xs : dvec T [shape, shape]) :
  det.op.pre (det.op.special (det.special.mvn_kl shape)) xs = (dvec.head2 xs > 0) := rfl
-/
end certigrad


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j),
  from by auto [int.fract_eq_iff, hα_irrat, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_iff, int.fract_eq_
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by auto [abs_sub_lt_iff] using [linarith],

  assume (h7 : ε > 0),

  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by auto [lt_of_le_of_lt, le_max_left, le_max_right],

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by auto [h8, h10, h5, h9],

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by auto [h11] using [linarith],

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by auto [h5, h15],

end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


variable {U V}

def f : (U → V) → (U → U) := sorry
def add  {U} : U → U → U := sorry

@[simp] theorem foo  (u : U) : f (add u) = id := sorry

def bar (u v : U) : f (add u) v =  id v := by
  simp


import data.set

import unitb.refinement.basic
import unitb.scheduling
import unitb.models.nondet

import util.cast

import temporal_logic

namespace hidden_state

universe variable u

open nondet temporal predicate classical

section defs

variables {α β σ : Type}

structure refined
       (f : α → σ)
       (ma : program α)
       (g : β → σ)
       (mc : program β) :=
  (glue : α → β → Prop)
  (obs_cons : ∀ a c, glue a c → f a = g c)
  (bij : mc.lbl = ma.lbl)
  (sim_init : ∀ c₀, mc^.first c₀
            → ∃ a₀, ma^.first a₀ ∧ glue a₀ c₀)
  (sim' : ∀ e c c' a, glue a c
           → mc.step_of e c c'
           → ∃ a',  ma.step_of (e.cast bij) a a'
                  ∧ glue a' c')
  (coarse : ∀ e a c, glue a c
               → (  mc.coarse_sch_of e c
                  ↔ ma.coarse_sch_of (e.cast bij) a))
  (fine : ∀ e a c, glue a c
               → (  mc.fine_sch_of e c
                  ↔ ma.fine_sch_of (e.cast bij) a))

end defs

open unitb.refinement

section thm

open unitb

parameters {α β σ : Type}

parameters
       {f : α → σ}
       {ma : program α}
       {g : β → σ}
       {mc : program β}

parameter R : refined f ma g mc

parameter [nonempty (unitb.state (program α))]
parameter Tc : stream (unitb.state (program β))
parameter Hc : system_sem.ex mc Tc

open nat

parameters Tc mc
def Tevts  : stream (set (option (mc.lbl))) :=
  λ i, { e | mc.step_of e (Tc i) (Tc (succ i)) }
parameters {Tc mc}

include Hc
lemma Tevts_ne_empty (i : ℕ)
: Tevts i ≠ ∅ :=
begin
  apply set.ne_empty_of_exists_mem,
  unfold Tevts,
  simp [mem_set_of],
  have H := system_sem.safety _ _ Hc i,
  rw action_drop at H,
  apply H,
end
omit Hc

open scheduling

-- noncomputable def Tevt [sched mc.lbl] : stream (option (mc.lbl)) :=
-- fair_sched_of (Tevts ∘ list.length)

-- include Hc

instance mc_sched : sched mc.lbl := mc.lbl_is_sched

instance ma_sched : sched ma.lbl := ma.lbl_is_sched

-- instance option_ma_sched : sched (option ma.lbl) :=
-- by { apply scheduling.sched_option,
--      apply hidden_state.ma_sched }

-- include mc_sched

-- example (i : ℕ) : mc.step_of (Tevt i) (Tc i) (Tc $ succ i) :=
-- begin
--   unfold Tevt Tevts,
--   assert H : Tevts mc Tc i ≠ ∅,
--   { unfold Tevts,
--     note Hsaf := Hc.safety i,
--     rw [action_drop] at Hsaf,
--     cases Hsaf with e He,
--     apply @set.ne_empty_of_mem _ _ e He },
--   note H' := fair_sched_of_mem' (Tevts mc Tc) i H,
--   unfold Tevts at H',
--   apply H',
-- end

-- omit Hc

structure sim_state :=
  (index : ℕ)
  (abs_state : α)
  (glued : R.glue abs_state (Tc index))

noncomputable def mk_state {p : α → Prop}  {i : ℕ} (P : ∃ x, p x ∧ R.glue x (Tc i))
: sim_state :=
⟨i,some P,and.right $ some_spec P⟩

lemma fst_mk_state {p : α → Prop}  {i : ℕ} (P : ∃ x, p x ∧ R.glue x (Tc i))
: (mk_state P).index = i := rfl

include Hc
def object_req_ne_emp (i : ℕ)
: {l' : option (ma.lbl) | option.cast' l' (R.bij) ∈ Tevts i} ≠ ∅ :=
begin
  have H : {l' : option (ma.lbl) | option.cast' l' (R.bij) ∈ Tevts mc Tc i}
          = (λ l, option.cast l R.bij) <$> Tevts mc Tc i,
  { apply set.ext, intro l,
    have Hinj : function.injective (λ (l : option (mc.lbl)), option.cast l (R.bij)) :=
       option_cast_injective R.bij,
    rw [mem_set_of,set.mem_fmap_iff_mem_of_bij Hinj],
    apply option.cast_left_inverse, },
  simp [H,set.fmap_eq_empty_iff_eq_empty],
  apply Tevts_ne_empty Hc,
end
omit Hc

noncomputable def next_state (l : option ma.lbl) (x : α) (i : ℕ)
  (P : R.glue x (Tc i))
  (Q : program.step_of mc (option.cast' l (R.bij)) (Tc i) (Tc (succ i)))
: sim_state :=
mk_state $ R.sim' (l.cast' R.bij) (Tc i) (Tc $ succ i) x P Q

noncomputable def object : unitb.target_mch (option ma.lbl) :=
{ σ := sim_state
, s₀ := mk_state $ R.sim_init (Tc 0) Hc.init
, req := λ s, { l' | l'.cast' R.bij ∈ Tevts s.index }
, req_nemp := λ s, object_req_ne_emp s.index
, next := λ l s Q, next_state l s.abs_state _ s.glued Q }

-- include ma_sched

noncomputable def Ta' : stream object.σ :=
let this : sched (option ma.lbl) :=
by { apply scheduling.sched_option }
in @fair_sched _ this _ object

noncomputable def Ta : stream (unitb.state (program α)) :=
stream.map sim_state.abs_state Ta'

lemma Ta_fair : fair object Ta' :=
fair_sched_of_spec object

lemma object_next_eq_next_state (l : option ma.lbl) (s : object.σ)
   (P : l ∈ object.req s)
: (object.next l _ P) = next_state l s.abs_state _ s.glued P :=
begin
  cases s with i s, refl,
end

lemma Ta_index (i : ℕ)
: (Ta' i).index = i :=
begin
  induction i with i IH,
  { rw Ta_fair.init, refl },
  { cases fair_sched_succ _ i (Ta_fair R Hc) with l h,
    cases h with P h,
    rw [h,object_next_eq_next_state],
    unfold next_state, rw [fst_mk_state,IH] },
end

include Hc

lemma init_simmed
: R.glue (Ta 0) (Tc 0) ∧ ma^.first (Ta 0) :=
begin
  unfold Ta stream.map stream.nth,
  rw Ta_fair.init,
  dunfold object unitb.target_mch.s₀,
  dunfold mk_state sim_state.abs_state,
  rw and_comm,
  apply some_spec (object._proof_1 R Hc),
end

-- include R

-- lemma conc_step (i : ℕ)
-- : mc.step_of (Tevt i) (Tc i) (Tc (succ i)) :=
-- begin
--   unfold Tevt Tevts,
--   assert H : Tevts mc Tc i ≠ ∅,
--   { unfold Tevts,
--     note Hsaf := Hc.safety i,
--     rw [action_drop] at Hsaf,
--     cases Hsaf with e He,
--     apply @set.ne_empty_of_mem _ _ e He },
--   note H' := fair_sched_of_mem' (Tevts mc Tc) i H,
--   unfold Tevts at H',
--   apply H',
-- end

-- lemma abs_step (i : ℕ) [nonempty α]
--   (J : R.glue (Ta i) (Tc i))
-- :   R.glue (Ta (succ i)) (Tc (succ i))
--   ∧ ma.step_of ((Tevt i).cast R.bij) (Ta i) (Ta (succ i)) :=
-- begin
--   unfold Ta,
--   pose P := (λ a, R.glue a (Tc (succ i)) ∧ ma.step_of ((Tevt _ Tc i).cast R.bij) (Ta _ _ _ _ R Tc i) a),
--   apply @epsilon_spec _ P,
--   revert P, simp,
--   note H' := R.sim' (Tevt _ Tc i) _ (Tc $ succ i) (Ta _ ma _ _ R Tc i) J (conc_step _ _ _ _ R Tc Hc i),
--   apply exists_imp_exists _ H',
--   intro, apply (and_comm _ _).mp,
-- end

theorem glued [nonempty α] (i : ℕ) : R.glue (Ta i) (Tc i) :=
begin
  have H := (Ta' R Hc i).glued,
  rw Ta_index at H,
  apply H,
end

-- include R

theorem simmed [nonempty α] (i : ℕ) : is_step ma (Ta i) (Ta (succ i)) :=
begin
  apply exists_imp_exists _ (fair_sched_succ _ i $ Ta_fair R Hc),
  intros e h, cases h with P h,
  unfold Ta stream.map stream.nth,
  rw h,
  admit,
  -- apply is_step_inst _ _,
  -- apply (abs_step _ _ _ _ R _ Hc i _).right,
  -- apply glued _ _ _ _ _ _ Hc,
  -- apply_instance,
end

open unitb

include R

theorem soundness [nonempty α] : data_ref ma f mc g :=
begin
  intros Tc Hc,
  existsi (Ta R Hc),
  split,
  apply program.ex.mk ,
  { apply (init_simmed _ Hc).right },
  { intro i,
    unfold action step has_safety.step stream.drop,
    simp [add_one],
    apply simmed _ Hc,
    apply_instance },
  { intros ea,
    let ec := (option.cast' ea (R.bij)),
    refine imp_mono _ _ (Hc.liveness ec),
    { apply iff.mp,
      apply exists_congr, intro i,
      apply forall_congr, intro j,
      unfold temporal.init stream.drop,
      let ec := (option.cast' ea (R.bij)),
      rw [R.coarse ec,option_cast_cast'],
      apply glued },
    refine imp_mono _ _,
    { refine iff.mp _,
      apply forall_congr, intro j,
      apply exists_congr, intro i,
      unfold temporal.init stream.drop,
      have HHH:= R.fine ec _ _ (glued R Hc $ 0 + i + j),
      repeat { rw [p_and_to_fun,init_to_fun,init_to_fun] },
      rw [HHH,option_cast_cast'] },
    { intro Hevt,
      admit } },
  { apply funext, intro i,
    unfold function.comp,
    symmetry,
    apply R.obs_cons,
    apply glued },
end

end thm

end hidden_state


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.fintype.powerset
import order.category.BoolAlg
import order.category.FinPartOrd
import order.hom.complete_lattice

/-!
# The category of finite boolean algebras

This file defines `FinBoolAlg`, the category of finite boolean algebras.

## TODO

Birkhoff's representation for finite Boolean algebras.

`Fintype_to_FinBoolAlg_op.left_op ⋙ FinBoolAlg.dual ≅ Fintype_to_FinBoolAlg_op.left_op`

`FinBoolAlg` is essentially small.
-/

universes u

open category_theory order_dual opposite

/-- The category of finite boolean algebras with bounded lattice morphisms. -/
structure FinBoolAlg :=
(to_BoolAlg : BoolAlg)
[is_fintype : fintype to_BoolAlg]

namespace FinBoolAlg

instance : has_coe_to_sort FinBoolAlg Type* := ⟨λ X, X.to_BoolAlg⟩
instance (X : FinBoolAlg) : boolean_algebra X := X.to_BoolAlg.str

attribute [instance]  FinBoolAlg.is_fintype

@[simp] lemma coe_to_BoolAlg (X : FinBoolAlg) : ↥X.to_BoolAlg = ↥X := rfl

/-- Construct a bundled `FinBoolAlg` from `boolean_algebra` + `fintype`. -/
def of (α : Type*) [boolean_algebra α] [fintype α] : FinBoolAlg := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [boolean_algebra α] [fintype α] : ↥(of α) = α := rfl

instance : inhabited FinBoolAlg := ⟨of punit⟩

instance large_category : large_category FinBoolAlg :=
induced_category.category FinBoolAlg.to_BoolAlg

instance concrete_category : concrete_category FinBoolAlg :=
induced_category.concrete_category FinBoolAlg.to_BoolAlg

instance has_forget_to_BoolAlg : has_forget₂ FinBoolAlg BoolAlg :=
induced_category.has_forget₂ FinBoolAlg.to_BoolAlg

instance forget_to_BoolAlg_full : full (forget₂ FinBoolAlg BoolAlg) := induced_category.full _
instance forget_to_BoolAlg_faithful : faithful (forget₂ FinBoolAlg BoolAlg) :=
induced_category.faithful _

@[simps] instance has_forget_to_FinPartOrd : has_forget₂ FinBoolAlg FinPartOrd :=
{ forget₂ := { obj := λ X, FinPartOrd.of X, map := λ X Y f,
    show order_hom X Y, from ↑(show bounded_lattice_hom X Y, from f) } }

instance forget_to_FinPartOrd_faithful : faithful (forget₂ FinBoolAlg FinPartOrd) :=
⟨λ X Y f g h, by { have := congr_arg (coe_fn : _ → X → Y) h, exact fun_like.coe_injective this }⟩

/-- Constructs an equivalence between finite Boolean algebras from an order isomorphism between
them. -/
@[simps] def iso.mk {α β : FinBoolAlg.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : FinBoolAlg ⥤ FinBoolAlg :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `FinBoolAlg` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : FinBoolAlg ≌ FinBoolAlg :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end FinBoolAlg

/-- The powerset functor. `set` as a functor. -/
@[simps] def Fintype_to_FinBoolAlg_op : Fintype ⥤ FinBoolAlgᵒᵖ :=
{ obj := λ X, op $ FinBoolAlg.of (set X),
  map := λ X Y f, quiver.hom.op $
    (complete_lattice_hom.set_preimage f : bounded_lattice_hom (set Y) (set X)) }