/- In this file we define affine varieties and affine groups over a discrete field `K`.
  We take a shortcut in the definition, by defining affine varieties as the opposite
  category of finitely generated reduced algebras. We define affine groups and basic
  group theory for affine groups: closed subgroups, kernels, normal subgroups, solvable groups, Borel subgroups, centralizers. -/
import ring_theory.basic
       ..category_theory.group_object
       ..category_theory.limits2
       tactic.omitted
       category_theory.limits.opposites
       topology.opens

open category_theory ideal set topological_space

noncomputable theory
universes u v w

-- we set some priorities of instances very low, because they cause problems in this file
local attribute [instance, priority 1] limits.category_theory.limits.has_limit
  limits.category_theory.limits.has_colimit limits.category_theory.limits.has_colimits
  limits.category_theory.limits.has_limits limits.category_theory.limits.has_limits_of_shape
  limits.category_theory.limits.has_colimits_of_shape

def has_coe_ideal {α : Type u} [comm_ring α] : has_coe (ideal α) (set α) := by apply_instance
local attribute [instance] has_coe_ideal

/-- An algebraically closed field is a field where every polynomial with positive degree has a root -/
class algebraically_closed_field (α : Type u) extends discrete_field α :=
(closed : is_algebraically_closed α)

local attribute [instance, priority 0] classical.prop_decidable
/-- A finitely generated reduced algebra -/
class finitely_generated_reduced_algebra (R : Type u) (A : Type v)
  [comm_ring R] [comm_ring A] extends algebra R A :=
(finitely_generated : is_finitely_generated R A)
(reduced : is_reduced A)

variables (K : Type u) [discrete_field K]
          (R : Type v) [comm_ring R] (S : Type w) [comm_ring S]
          [finitely_generated_reduced_algebra K R] [finitely_generated_reduced_algebra K S]
          {σ : Type w} [decidable_eq σ]

open finitely_generated_reduced_algebra category_theory tensor_product
namespace algebraic_geometry

/-- The spectrum `Specm(R)` of a `K`-algebra `R` is the set of homomorphisms from `R` to `K`.
  This corresponds to maximal ideals in `R`. -/
@[reducible] def spectrum : Type* := R →ₐ[K] K

variables {R K}
/-- The quotient of R by a maximal ideal is isomorphic to K -/
def quotient_maximal_ideal (I : maximal_ideal R) :
  { f : I.val.quotient ≃ K // is_ring_hom f.to_fun } :=
classical.choice omitted -- TODO: fix non-canoncial choice

/-- The spectrum of R is equivalent to the set of maximal ideals on R -/
def spectrum_equiv_maximal_ideal : spectrum K R ≃ maximal_ideal R :=
let f : maximal_ideal R → R → K :=
  λ I, (quotient_maximal_ideal I).val.to_fun ∘ ideal.quotient.mk I.val in
by { haveI h : ∀ I : maximal_ideal R, is_ring_hom (f I) := omitted,
     exact ⟨λ ϕ, ⟨ideal.ker ⇑ϕ, omitted⟩, λ I, ⟨f I, omitted⟩, omitted, omitted⟩ }

variables (K) {R}
/-- `Z(S)` is the set of homomorphisms in `Spec(R)` that vanish on `S`. -/
def Z (S : set R) : set (spectrum K R) := { f | ∀ x ∈ S, f.to_fun x = 0 }

/--`I(X)` consists of all points in `R` that are send to `0` by all `ϕ ∈ X`-/
def I (X : set (spectrum K R)) : set R :=
{ x : R | ∀ϕ : X, ϕ.val x = 0 }

/-- `Z(S)` is equal to `Z` of the radical of the span of `S`. -/
lemma Z_radical_span (S : set R) : Z K ((ideal.span S).radical.carrier) = Z K S :=
omitted

variables (K R)

/-- The Zariski topology is the topology where the closed sets are of the form `Z(S)` for some `S ⊆ R` -/
instance Zariski_topology : topological_space (spectrum K R) :=
⟨set.range (λ S : set R, - Z K S), omitted, omitted, omitted⟩

variables {K R}
/-- A radical ideal gives rise to a closed set in the Zariski topology -/
def closeds_of_radical_ideal (I : radical_ideal R) : closeds (spectrum K R) :=
⟨Z K I.val, mem_range_self I.val⟩

/-- A closed set in the Zariski topology gives rise to a radical ideal -/
def radical_ideal_of_closeds (X : closeds (spectrum K R)) : radical_ideal R :=
⟨⟨ I K X.val, omitted, omitted, omitted⟩, omitted⟩

/-- Hilbert's Nullstellensatz: there is a correspondence between radical ideals in R and
 closed sets in the spectrum of R. -/
def Nullstellensatz : radical_ideal R ≃ closeds (spectrum K R) :=
⟨closeds_of_radical_ideal, radical_ideal_of_closeds, omitted, omitted⟩

instance base.finitely_generated_reduced_algebra :
  finitely_generated_reduced_algebra K K :=
{ finitely_generated := is_finitely_generated_base K,
  reduced := is_reduced_integral_domain,
  .._inst_1 }

instance quotient.finitely_generated_reduced_algebra (I : radical_ideal R) :
  finitely_generated_reduced_algebra K I.val.quotient :=
{ finitely_generated := is_finitely_generated_quotient (finitely_generated K R) I.val,
  reduced := is_reduced_quotient I.2,
  ..quotient.algebra I.val }

variables (R S)
instance tensor.finitely_generated_reduced_algebra :
  finitely_generated_reduced_algebra K (R ⊗[K] S) :=
{ finitely_generated := is_finitely_generated_tensor
  (finitely_generated K R) (finitely_generated K S),
  reduced := is_reduced_tensor (reduced K R) (reduced K S),
  ..tensor_product.algebra }

/-- For a closed subset `Z` the quotient `K[X]/I(Z)` is an algebra over `K` -/
example (Z : closeds (spectrum K R)) : algebra K (radical_ideal_of_closeds Z).val.quotient :=
infer_instance

/-- The spectrum of `K[X]/I(Z)` is Z for a closed subset `Z` -/
def spectrum_quotient (Z : closeds (spectrum K R)) :
  spectrum K (radical_ideal_of_closeds Z).val.quotient ≃ₜ Z.val :=
{ to_fun := λ x, ⟨x.comp $ algebra.quotient.mk _, omitted⟩,
  inv_fun := λ y, algebra.quotient.lift y omitted,
  left_inv := omitted,
  right_inv := omitted,
  continuous_to_fun := omitted,
  continuous_inv_fun := omitted }

variables {R S}

/-- The type of finitely generated reduced algebras over a fixed commutative ring. -/
structure FRAlgebra (R : Type u) [comm_ring R] : Type (u+1) :=
  (β : Type u)
  [ring : comm_ring β]
  [algebra : finitely_generated_reduced_algebra R β]

attribute [instance, priority 1100] FRAlgebra.ring FRAlgebra.algebra
instance (R : Type v) [comm_ring R] : has_coe_to_sort (FRAlgebra R) :=
{ S := Type v, coe := FRAlgebra.β }

/-- The category of finitely generated reduced (f.g.r.) algebras over a fixed commutative ring. -/
instance FRAlgebra.category (R : Type u) [comm_ring R] : large_category (FRAlgebra R) :=
{ hom   := λ a b, a.β →ₐ[R] b.β,
  id    := λ a, alg_hom.id R a,
  comp  := λ a b c f g, alg_hom.comp g f }

/-- Quotients in the category of f.g.r. algebras -/
def FRAlgebra.quotient (R : FRAlgebra K) (Z : closeds (spectrum K R)) : FRAlgebra K :=
⟨K, (radical_ideal_of_closeds Z).val.quotient⟩

/-- The quotient map in the category of f.g.r. algebras -/
def FRAlgebra.quotient_map (R : FRAlgebra K) (Z : closeds (spectrum K R)) :
  R ⟶ R.quotient Z :=
algebra.quotient.mk _

/-- The tensor product of two finitely generated reduced algebras over `K` -/
def FRAlgebra_tensor (R S : FRAlgebra K) : FRAlgebra K :=
{ β := R ⊗[K] S,
  ring := _,
  algebra := tensor.finitely_generated_reduced_algebra R S }

variables (K)
section
local attribute [instance, priority 1500] algebra.mv_polynomial algebra.polynomial
/-- Polynomials over `K` as an f.g.r. algebra over `K` -/
def FRAlgebra_polynomial : FRAlgebra K :=
{ β := polynomial K,
  algebra := { finitely_generated := omitted,
               reduced := omitted } }

/-- Multivariate polynomials over `K` as an f.g.r. algebra over `K` -/
def FRAlgebra_mv_polynomial (K : Type (max u v)) [discrete_field K] (σ : Type v)
  [decidable_eq σ] : FRAlgebra K :=
{ β := mv_polynomial σ K,
  algebra := { finitely_generated := omitted,
               reduced := omitted } }
end

/-- `K` forms a finitely generated reduced algebras over `K` -/
def FRAlgebra_id : FRAlgebra K := ⟨K, K⟩

example (R : FRAlgebra K) : (R ⟶ FRAlgebra_id K) = (R.β →ₐ[K] K) := by refl
example (R : FRAlgebra K) : (R ⟶ FRAlgebra_id K) = spectrum K R.β := rfl

/-- The category of finitely generated reduced algebras over `K` has binary coproducts -/
def FRAlgebra.has_binary_coproducts : limits.has_binary_coproducts (FRAlgebra K) :=
begin
  fapply limits.has_binary_coproducts.mk FRAlgebra_tensor,
  exact λ X Y, tensor_inl,
  exact λ X Y, tensor_inr,
  exact λ X Y Z, tensor_lift,
  omit_proofs
end

/-- The category of finitely generated reduced algebras over `K` has an initial object -/
def FRAlgebra.has_initial_object : limits.has_initial_object (FRAlgebra K) :=
begin
  fapply limits.has_initial_object.mk (FRAlgebra_id K),
  intro X, exact algebra.of_id K X,
  omitted
end

/-- In algebraic geometry, the categories of algebra's over `K` and affine varieties are opposite of each other. In this development we take a shortcut, and *define* affine varieties as the opposite of algebra's over K. -/
@[reducible] def affine_variety : Type* := opposite (FRAlgebra K)

example : large_category (affine_variety K) := by apply_instance

/-- The category of affine varieties has binary products -/
@[instance, priority 1200] def affine_variety.has_binary_products :
  limits.has_binary_products (affine_variety K) :=
by { haveI : limits.has_colimits_of_shape.{u} (discrete limits.two) (FRAlgebra K) :=
     FRAlgebra.has_binary_coproducts K, exact limits.has_products_opposite _ }

/-- The category of affine varieties has a terminal object -/
@[instance, priority 1200] def affine_variety.has_terminal_object :
  limits.has_terminal_object (affine_variety K) :=
by { haveI : limits.has_colimits_of_shape.{u} (discrete pempty) (FRAlgebra K) :=
     FRAlgebra.has_initial_object K, exact limits.has_products_opposite _ }

/-- The underlying type of an affine variety G = Rᵒᵖ is Spec(R), equivalently the global points
   of G in the category of affine varieties. -/
def affine_variety.type_functor : affine_variety K ⥤ Type u :=
yoneda.obj (FRAlgebra_id K)

/- to do: affine_variety.type_functor preserves finite products (is just left-exact) -/
variables {K R}

/-- The object part of the functor `affine_variety.type_functor` -/
def affine_variety.type (X : affine_variety K) : Type u :=
(affine_variety.type_functor K).obj X

/-- The type of `X` is the spectrum of `X` viewed as an object in the opposite category -/
lemma affine_variety.type_eq (X : affine_variety K) :
  affine_variety.type X = spectrum K (unop X).β := rfl

/-- We tell Lean that the Zariski topology gives a topology on the type of an affine variety -/
instance (X : affine_variety K) : topological_space X.type :=
algebraic_geometry.Zariski_topology _ _

/-- A subobject of an affine variety given by a closed set on its type -/
def affine_variety.subobject (X : affine_variety K) (Z : closeds X.type) : affine_variety K :=
op ((unop X).quotient Z)

/-- A subobject of an affine variety given by a closed set on its type -/
def affine_variety.incl (X : affine_variety K) (Z : closeds X.type) :
  X.subobject Z ⟶ X :=
(FRAlgebra.quotient_map _ _).op

/-- A subobject of an affine variety given by a closed set on its type -/
def incl_of_subset {X : affine_variety K} {Z₁ Z₂ : closeds X.type} (h : Z₁.1 ⊆ Z₂.1) :
  X.subobject Z₁ ⟶ X.subobject Z₂ :=
has_hom.hom.op (algebra.quotient.lift (algebra.quotient.mk _) omitted)

/-- Inclusion of a set on the type of a subobject into the sets on type type of `X` -/
def set_sub_incl {X : affine_variety K} {Z : closeds X.type} :
  set (X.subobject Z).type → set X.type :=
image $ (affine_variety.type_functor K).map $ X.incl Z

variable (K)
/-- An affine group is a group object in the category of affine varieties -/
abbreviation affine_group : Type* := group_object (affine_variety K)

example : category (affine_group K) := by apply_instance

end algebraic_geometry

open algebraic_geometry
variables variables {K} {G G' G₁ G₂ G₃ H : affine_group K}

/-- A morphism between affine groups induces a map between the types -/
def group_hom.type (f : G ⟶ G') : G.obj.type → G'.obj.type :=
(affine_variety.type_functor K).map f.map

namespace algebraic_geometry

-- Given an algebraic group, we get a group structure on its type
section
set_option class.instance_max_depth 80
/-- The multiplication on the type of an affine group -/
def group_type_mul (f g : G.obj.type) : G.obj.type := (tensor_lift f g).comp G.mul.unop
end

/-- The inversion on the type of an affine group -/
def group_type_inv (f : G.obj.type) : G.obj.type := f.comp G.inv.unop

/-- The unit in the type of an affine group -/
def group_type_one : G.obj.type := G.one.unop

/-- Given an algebraic group, we get a group structure on its type -/
instance group_type (G : affine_group K) : group G.obj.type :=
{ mul := group_type_mul,
  mul_assoc := omitted,
  one := group_type_one,
  one_mul := omitted,
  mul_one := omitted,
  inv := group_type_inv,
  mul_left_inv := omitted }

/-- A morphism between affine groups induces a group homomorphism between the types -/
instance (f : G ⟶ G') : is_group_hom f.type := omitted

/-- A closed subgroup of G is a subset of its type that is closed and a subgroup -/
class is_closed_subgroup (s : set G.obj.type) extends is_subgroup s : Prop :=
(closed : is_closed s)

/-- The type of `G` is a closed subgroup of itself -/
instance is_closed_subgroup_univ (G : affine_group K) :
  is_closed_subgroup (univ : set G.obj.type) :=
omitted

/-- A closed subgroup gives a closed set (by forgetting that it is a subgroup) -/
def to_closeds (s : set G.obj.type) [is_closed_subgroup s] : closeds G.obj.type :=
⟨s, is_closed_subgroup.closed s⟩

/-- The (opposite of the) multiplication on a subgroup -/
def sub_mul_op (s : set G.obj.type) [is_closed_subgroup s] : (unop G.obj).quotient (to_closeds s) ⟶
  FRAlgebra_tensor ((unop G.obj).quotient (to_closeds s)) ((unop G.obj).quotient (to_closeds s)) :=
algebra.quotient.lift
  begin
    refine alg_hom.comp _ G.mul.unop,
    exact tensor_functor (algebra.quotient.mk _) (algebra.quotient.mk _)
  end
 omitted

/-- From a closed subgroup we can construct an affine group -/
def sub (s : set G.obj.type) [is_closed_subgroup s] : affine_group K :=
{ obj := G.obj.subobject (to_closeds s),
  mul := (sub_mul_op s).op,
  mul_assoc := omitted,
  one := (show (unop G.obj).quotient (to_closeds s) ⟶ FRAlgebra_id K,
          from algebra.quotient.lift G.one.unop omitted).op,
  one_mul := omitted,
  mul_one := omitted,
  inv := (show (unop G.obj).quotient (to_closeds s) ⟶ (unop G.obj).quotient (to_closeds s),
          from algebra.quotient.functor G.inv.unop omitted).op,
  mul_left_inv := omitted }

def affine_group.incl (G : affine_group K) (s : set G.obj.type) [is_closed_subgroup s] :
  sub s ⟶ G :=
by exact ⟨affine_variety.incl _ _, omitted⟩

instance set_sub_incl.is_closed_subgroup {H : set G.obj.type} {h : is_closed_subgroup H}
  (K' : set (sub H).obj.type) [hK : is_closed_subgroup K'] : is_closed_subgroup (set_sub_incl K') :=
omitted

/-- The kernel of a morphism between affine groups is given by the preimage of 1.

More precisely, we can view `f : G ⟶ G'` as a map between the type of `G` and the type of `G'`,
and then take the preimage of `1 : type G'`, using the group structure induced on the type of `G'` -/
def kernel (f : G ⟶ G') : set G.obj.type :=
is_group_hom.ker f.type

/-- The kernel of a morphism is a closed subgroup -/
instance (f : G ⟶ G') : is_closed_subgroup (kernel f) := omitted

/-- A subset of the type of `G` is a normal subgroup if it the kernel of a morphism between
  affine groups. Any normal subgroup is automatically closed. -/
def is_normal_subgroup (s : set G.obj.type) : Prop :=
∃(G' : affine_group K) (f : G ⟶ G'), kernel f = s

/-- The structure of being a normal subgroup -/
def normal_subgroup_structure (s : set G.obj.type) : Type* :=
Σ(G' : affine_group K), {f : G ⟶ G' // kernel f = s }

/-- An affine group `G` is solvable if it is abelian or inductively if there is a morphism
  `ψ : G ⟶ H` such that both `ker(ψ)` and `H` are solvable. -/
-- For some reason this inductive type is very slow to compile if we make this into a `Type`,
-- probably, during the definition of auxilliary declarations. For now, let's have it a Prop,
-- we can turn it into a type later
inductive solvable : affine_group K → Prop
| base {{G : affine_group K}} : G.is_abelian → solvable G
| step {{G H : affine_group K}} (ψ : G ⟶ H) :
  solvable H → solvable (sub (kernel ψ)) → solvable G

/-- A Borel subgroup is a maximal closed connected solvable subgroup of `G` -/
def is_Borel_subgroup (s : set G.obj.type) : Prop :=
is_maximal { t : set G.obj.type |
  ∃(h : is_closed_subgroup t), is_connected t ∧ by exactI solvable (sub t) } s

/-- There is a unique maximal closed subgroup of `G` that is a kernel of a morphism `ψ : G ⟶ A`
  for an abelian group `A` -/
theorem closed_derived_subgroup_unique (H : set G.obj.type) [is_closed_subgroup H] :
  ∃!(s : set G.obj.type), is_maximal { t : set G.obj.type |
    ∃(A : affine_group K) (ψ : sub H ⟶ A), A.is_abelian ∧ t = set_sub_incl (kernel ψ) } s :=
omitted

/-- The closed derived subgroup of `H` is the unique maximal subgroup of `H` that is a kernel of a
  morphism `ψ : H ⟶ A` for an abelian group `A` -/
def closed_derived_subgroup (H : set G.obj.type) [is_closed_subgroup H] : set G.obj.type :=
classical.the _ (closed_derived_subgroup_unique H)

/-- The closed derived subgroup is a closed subgroup -/
instance closed_derived_subgroup.is_closed_subgroup (H : set G.obj.type) [is_closed_subgroup H] :
  is_closed_subgroup (closed_derived_subgroup H) :=
omitted

open category_theory.limits category_theory.limits.binary_product
local infix ` × `:60 := binary_product
local infix ` ×.map `:90 := binary_product.map

/-- The conjugation map `H₁ × H₂ ⟶ G` given by `(h₁,h₂) ↦ h₁*h₂*h₁⁻¹`-/
def conjugation (H₁ H₂ : set G.obj.type) [is_closed_subgroup H₁] [is_closed_subgroup H₂] :
  (sub H₁).obj × (sub H₂).obj ⟶ G.obj :=
((G.incl H₁).map ≫ diag) ×.map (G.incl H₂).map ≫
product_assoc.hom ≫ 𝟙 G.obj ×.map (product_comm.hom ≫ G.mul) ≫ G.mul
/- The following more explicit definition is hard on the elaborator;
  Probably because of type-class inference for `×` -/
-- calc
--   H₁ × H₂ ⟶ (G × G) × G : ((G.incl H₁).map ≫ diag) ×.map (G.incl H₂).map
--       ... ⟶ G × (G × G) : product_assoc.hom
--       ... ⟶ G × G       : 𝟙 G.obj ×.map (product_comm.hom ≫ G.mul)
--       ... ⟶ G           : G.mul

/-- `C` centralizes `H` if `C × H ⟶ G` given by `(c,h) ↦ c*h*c⁻¹` is equal to the inclusion
`H ⟶ G`. -/
def centralizes (C H : set G.obj.type) [is_closed_subgroup C] [is_closed_subgroup H] : Prop :=
conjugation C H = π₂ ≫ (G.incl H).map

/-- There is a unique maximal closed subgroup of `G` that centralizes `H` -/
theorem centralizer_unique (H : set G.obj.type) [is_closed_subgroup H] :
  ∃!(C : set G.obj.type), is_maximal { C' : set G.obj.type |
    ∃(h : is_closed_subgroup C'), by exactI centralizes C' H } C :=
omitted

/-- The centralizer of `H` is the unique maximal closed subgroup of `G` that centralizes `H` -/
def centralizer (H : set G.obj.type) [is_closed_subgroup H] : set G.obj.type :=
classical.the _ (centralizer_unique H)

/-- The centralizer is a closed subgroup -/
instance centralizer.is_closed_subgroup (H : set G.obj.type) {h : is_closed_subgroup H} :
  is_closed_subgroup (centralizer H) :=
let ⟨h, _⟩ := (classical.the_spec (centralizer_unique H)).1 in h

/-- The center of `G` is the centralizer of `G` as closed subgroup of `G` -/
def center (G : affine_group K) : set G.obj.type :=
centralizer set.univ

/-- `N` normalizes `H` if the conjugation map `N × H ⟶ G` factors through `H` -/
-- this is a slightly different formulation than in the notes
def normalizes (N H : set G.obj.type) [is_closed_subgroup N] [is_closed_subgroup H] : Prop :=
--factors_through (conjugation N H) (G.incl H).map
∃(f : (sub N).obj × (sub H).obj ⟶ (sub H).obj), conjugation N H = f ≫ (G.incl H).map

/-- If `N` normalizes `H` then `N` acts on `H` by conjucation -/
def conjugation_action {N H : set G.obj.type} [is_closed_subgroup N] [is_closed_subgroup H]
  (h : normalizes N H) : group_action (sub N) (sub H).obj :=
classical.take_arbitrary_such_that (λ f, ⟨f, omitted, omitted⟩) h omitted

/-- An affine group is almost simple if it has no proper normal closed connected subgroup.
  Note: by our definition, every normal subgroup is automatically closed -/
def almost_simple (G : affine_group K) : Prop :=
¬∃(T : set G.obj.type), T ≠ set.univ ∧ is_normal_subgroup T ∧ is_connected T

/-- The type of a almost simple affine group is connected -/
lemma connected_space_of_almost_simple : almost_simple G → connected_space G.obj.type :=
omitted

end algebraic_geometry


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

Tactics to prove specific models satisfy the preconditions of backprop_correct.
-/
import data.list.set .tfacts .graph .predicates .expected_value .reparam .kl .tactics .program .mvn .tactics

#print "compiling prove_model_ok..."

namespace certigrad
open T tactic list

lemma mem_of_ne_mem_cons {α : Type*} {xs : list α} {x y : α} : x ∈ y :: xs → x ≠ y → x ∈ xs :=
begin
intros H_in H_neq,
dunfold has_mem.mem list.mem at H_in,
cases H_in with H_eq H_in,
exfalso, exact H_neq H_eq, exact H_in
end

@[cgsimp] lemma true_of_not_false : (¬ false) = true :=
begin apply propext, split, intro H, exact trivial, intros Ht Hf, exact Hf end

@[cgsimp] lemma label_of (x y : label) : (ID.str x = ID.str y) = (x = y) :=
begin apply propext, split, intro H, injection H, intro H, rw H end

@[cgsimp] lemma eq_of_self_eq {α : Type*} (x : α) : (x = x) = true := propext (eq_self_iff_true _)

@[cgsimp] lemma and_true_left {P : Prop} : (true ∧ P) = P := propext (true_and _)
@[cgsimp] lemma and_true_right {P : Prop} : (P ∧ true) = P := propext (and_true _)
@[cgsimp] lemma and_false_left {P : Prop} : (false ∧ P) = false := propext (false_and _)
@[cgsimp] lemma and_false_right {P : Prop} : (P ∧ false) = false := propext (and_false _)

@[cgsimp] lemma or_false_left {P : Prop} : (false ∨ P) = P := propext (false_or _)
@[cgsimp] lemma or_false_right {P : Prop} : (P ∨ false) = P := propext (or_false _)
@[cgsimp] lemma or_true_left {P : Prop} : (true ∨ P) = true := propext (true_or _)
@[cgsimp] lemma or_true_right {P : Prop} : (P ∨ true) = true := propext (or_true _)

@[cgsimp] lemma true_of_imp_true {α : Sort*} : (α → true) = true := propext (iff.intro (λ H, trivial) (λ H x, trivial))

@[cgsimp] lemma simp_nodup_nil {α : Type*} : @list.nodup α [] = true := pextt list.nodup_nil

@[cgsimp] lemma simp_nodup_singleton {α : Type*} (a : α) : list.nodup [a] = true := pextt (list.nodup_singleton _)
@[cgsimp] lemma simp_nodup_cons {α : Type*} {a : α} {l : list α} (H : a ∉ l) : list.nodup (a::l) = list.nodup l :=
begin apply propext, split, intro H', cases H' with H1 H2 H3 H4, exact H4, apply list.nodup_cons, exact H end

@[cgsimp] lemma false_imp {P : Prop} : (false → P) = true :=
begin apply propext, split, intro H, exact trivial, intros Ht Hf, exfalso, exact Hf end
@[cgsimp] lemma true_imp {P : Prop} : (true → P) = P :=
begin apply propext, split, intro H, exact H trivial, intros H Ht, exact H end

@[cgsimp] lemma simp_mem_nil {α : Type*} (x : α) : (x ∈ @list.nil α) = false :=
begin apply pextf, apply list.not_mem_nil end

@[cgsimp] lemma simp_mem_cons_neq {α : Type*} (x y : α) (xs : list α) : x ≠ y → (x ∈ y :: xs) = (x ∈ xs) :=
begin intro H_neq, apply propext, split, intro H_in, exact mem_of_ne_mem_cons H_in H_neq, intro H_in, exact or.inr H_in end

@[cgsimp] lemma simp_mem_cons_eq {α : Type*} (x y : α) (xs : list α) : x = y → (x ∈ y :: xs) = true :=
begin intro H_eq, apply pextt, dunfold has_mem.mem list.mem, left, exact H_eq end

@[cgsimp] lemma simp_nmem_nil {α : Type*} (x : α) : (x ∉ @list.nil α) = true :=
begin apply pextt, apply list.not_mem_nil end

@[cgsimp] lemma simp_nmem_cons_eq {α : Type*} (x y : α) (xs : list α) : x ≠ y → (x ∉ y :: xs) = (x ∉ xs) :=
begin intro H_neq, apply propext, split, intros H_nin H_in, exact H_nin (or.inr H_in),
intros H_nin H_in, exact H_nin (mem_of_ne_mem_cons H_in H_neq)
end

@[cgsimp] lemma simp_nmem_cons_neq {α : Type*} (x y : α) (xs : list α) : x = y → (x ∉ y :: xs) = false :=
begin intro H_eq, apply pextf, intro H, exact H (or.inl H_eq) end

@[cgsimp] lemma false_of_cons_eq_nil {α : Type*} {x : α} {xs : list α} : (list.cons x xs = list.nil) = false :=
begin apply pextf, intro H, injection H end

@[cgsimp] lemma simp_at_idx_nil {α : Type*} [inhabited α] (x : α) (idx : ℕ) : list.at_idx list.nil idx x = false :=
begin
apply pextf,
intro H,
dunfold list.at_idx at H,
cases H with H1 H2,
exact (nat.not_lt_zero idx) H1
end

@[cgsimp] lemma simp_at_idx_0 {α : Type*} [inhabited α] {x : α} {xs : list α} : list.at_idx (x::xs) 0 x = true :=
begin apply pextt, apply list.at_idx_0 end

@[cgsimp] lemma simp_at_idx_cons {α : Type*} [inhabited α] {x : α} {xs : list α} {y : α} {idx : ℕ} :
  list.at_idx (x::xs) (idx+1) y = list.at_idx xs idx y :=
begin
apply propext,
split,
apply list.at_idx_of_cons,
apply list.at_idx_cons
end

@[cgsimp] lemma of_in_list_forall_cons {α : Type*} (ys : list α) (P : α → Prop) (y : α) : (∀ x, x ∈ list.cons y ys → P x) = (P y ∧ (∀ x, x ∈ ys → P x)) :=
begin
apply propext,
split,
intro H,
{ split, exact H y list.mem_of_cons_same, intros x H_in, exact H x (or.inr H_in) },
{
intro H, cases H with HPy H, intros x H_in,
cases classical.em (x = y) with H_eq H_neq,
rw H_eq, exact HPy,
exact H x (mem_of_ne_mem_cons H_in H_neq)
}
end

@[cgsimp] lemma of_in_list_forall_nil {α : Type*} (P : α → Prop) (y : α) : (∀ (x : α), x ∈  @list.nil α → P x) = true :=
begin
apply pextt,
intros x H_in_nil,
exfalso,
exact (list.not_mem_nil _) H_in_nil
end

@[cgsimp] lemma of_in_list_cons_neq {α : Type*} {P : Prop} (ys : list α) (x y : α) : x ≠ y → (x ∈ list.cons y ys → P) = (x ∈ ys → P) :=
begin
intro H_neq,
apply propext,
split,
intro H,
intro H_in,
apply H,
exact or.inr H_in,
intro H,
intro H_in,
apply H,
exact mem_of_ne_mem_cons H_in H_neq
end

@[cgsimp] lemma of_in_list_cons_eq {α : Type*} {P : Prop} (ys : list α) (x y : α) : x = y → (x ∈ list.cons y ys → P) = P :=
begin
intro H_eq,
apply propext,
split,
intro H_in,
exact H_in (or.inl H_eq),
intros HP H_in,
exact HP
end

@[cgsimp] lemma simp_sublist_cons {α : Type*} (xs : list α) (x : α) : (xs <+ x :: xs) = true :=
begin
apply pextt,
apply list.sublist_cons
end

@[cgsimp] lemma simp_sqrt_pos {shape : S} {x : T shape}: (0 < sqrt x) = (0 < x) :=
begin apply propext, split, apply pos_of_sqrt_pos, apply sqrt_pos end

@[cgsimp] lemma simp_exp_pos {shape : S} {x : T shape} : (0 < exp x) = true :=
begin apply pextt, apply exp_pos end

@[cgsimp] lemma simp_integrable_const (shape₁ shape₂ : S) (y : T shape₂) : is_integrable (λ (x : T shape₁), y) = true :=
begin apply pextt, apply is_integrable_const end

@[cgsimp] lemma simp_nneg_of_pos {shape : S} {x : T shape} : x ≠ 0 = (0 < x ∨ x < 0) :=
begin apply propext, apply nz_iff end

@[cgsimp] lemma simp_one_pos {shape : S} : (0 < (1 : T shape)) = true := pextt one_pos

@[cgsimp] lemma simp_sigmoid_pos {shape : S} {x : T shape} : (0 < sigmoid x) = true := pextt sigmoid_pos
@[cgsimp] lemma simp_sigmoid_lt1 {shape : S} {x : T shape} : (sigmoid x < 1) = true := pextt sigmoid_lt1

-- TODO(dhs): weird lemma
@[cgsimp] lemma simp_one_plus_pos {shape : S} {x : T shape} : 0 < 1 + x = (0 < x ∨ - 1 < x) :=
begin
apply propext,
split,
intro H,
right, exact iff.mp one_plus_pos_iff H,
intro H,
cases H with H H,
apply one_plus_pos,
exact H,
exact iff.mpr one_plus_pos_iff H
end

@[cgsimp] lemma simp_has_key_insert_same (ref : reference) {x : T ref.2} (m : env) :
  env.has_key ref (env.insert ref x m) = true := pextt (by apply env.has_key_insert_same)

@[cgsimp] lemma simp_has_key_insert_diff (ref₁ ref₂ : reference) {x : T ref₂.2} (m : env) :
  ref₁ ≠ ref₂ → env.has_key ref₁ (env.insert ref₂ x m) = env.has_key ref₁ m :=
begin
intro H_neq,
apply propext,
split,
apply env.has_key_insert_diff,
exact H_neq,
apply env.has_key_insert
end

@[cgsimp] lemma simp_has_key_empty (ref : reference) : env.has_key ref env.mk = false :=
begin apply pextf, apply env.not_has_key_empty end

def is_not_used_downstream (tgt : reference) : list node → Prop
| [] := true
| (⟨ref, parents, op⟩ :: nodes) := tgt ∉ parents ∧ is_not_used_downstream nodes

def is_used_downstream (tgt : reference) : list node → Prop
| [] := false
| (⟨ref, parents, op⟩ :: nodes) := tgt ∈ parents ∨ is_used_downstream nodes

attribute [cgsimp] is_not_used_downstream is_used_downstream

lemma costs_helper : Π (costs : list ID) (tgt : reference) (m : env),
  tgt.1 ∉ costs → compute_grad_slow costs [] m tgt = 0
| []      tgt m H_nin := rfl
| (c::cs) tgt m H_nin :=
begin
dunfold compute_grad_slow,
assert H : (tgt ≠ (c, [])),
{
cases tgt with tgt_1 tgt_2,
dsimp at H_nin,
apply pair_neq_of_neq₁,
exact list.ne_of_not_mem_cons H_nin
},
simph,
dunfold list.sumr,
rw zero_add,
exact costs_helper cs tgt m (list.not_mem_of_not_mem_cons H_nin)
end

lemma compute_grad_slow_det_not_used_helper (costs : list ID) : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs nodes m tgt = 0
| [] m tgt H_not_used H_tgt_nin_costs :=
begin
apply costs_helper, all_goals { assumption }
end

| (⟨ref, parents, operator.det op⟩::nodes) m tgt H_not_used H_tgt_nin_costs :=
begin
dunfold compute_grad_slow,
dunfold is_not_used_downstream at H_not_used,
rw compute_grad_slow_det_not_used_helper nodes _ tgt H_not_used^.right H_tgt_nin_costs,
rw zero_add,
rw list.not_in_filter_of_match_riota,
reflexivity,
exact H_not_used^.left
end

| (⟨ref, parents, operator.rand op⟩::nodes) m tgt H_not_used H_tgt_nin_costs :=
begin
dunfold compute_grad_slow,
dunfold is_not_used_downstream at H_not_used,
rw compute_grad_slow_det_not_used_helper,
rw zero_add,
rw list.not_in_filter_of_match_riota,
reflexivity,
exact H_not_used^.left,
exact H_not_used^.right,
exact H_tgt_nin_costs
end

@[cgsimp] lemma compute_grad_slow_det_not_used (costs : list ID) (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
list.sumr (list.map (λ (idx : ℕ), op^.pb (env.get_ks parents m)
                                        (env.get ref m)
                                        (compute_grad_slow costs nodes m ref)
                                        idx
                                        tgt.2)
                    (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_not_used H_tgt_nin_costs,
dunfold_occs compute_grad_slow [1],
rw [compute_grad_slow_det_not_used_helper _ _ _ _ H_not_used H_tgt_nin_costs, zero_add]
end

@[cgsimp] lemma compute_grad_slow_det_used (costs : list ID) (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes ∨ tgt.1 ∈ costs →
compute_grad_slow costs (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
compute_grad_slow costs nodes m tgt +
list.sumr (list.map (λ (idx : ℕ), op^.pb (env.get_ks parents m)
                                        (env.get ref m)
                                        (compute_grad_slow costs nodes m ref)
                                        idx
                                        tgt.2)
                    (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_is_used_or_cost,
reflexivity
end

@[cgsimp] lemma compute_grad_slow_rand_not_used (costs : list ID) (ref : reference) (parents : list reference) (op : rand.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes → tgt.1 ∉ costs →
compute_grad_slow costs (⟨ref, parents, operator.rand op⟩ :: nodes) m tgt
=
list.sumr (list.map (λ (idx : ℕ), sum_downstream_costs nodes costs ref m ⬝ op^.glogpdf (env.get_ks parents m) (env.get ref m) idx tgt.2)
                   (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_not_used H_tgt_nin_costs,
dunfold_occs compute_grad_slow [1],
rw [compute_grad_slow_det_not_used_helper _ _ _ _ H_not_used H_tgt_nin_costs, zero_add]
end

@[cgsimp] lemma compute_grad_slow_rand_used (costs : list ID) (ref : reference) (parents : list reference) (op : rand.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes ∨ tgt.1 ∈ costs →
compute_grad_slow costs (⟨ref, parents, operator.rand op⟩ :: nodes) m tgt
=
compute_grad_slow costs nodes m tgt +
list.sumr (list.map (λ (idx : ℕ), sum_downstream_costs nodes costs ref m ⬝ op^.glogpdf (env.get_ks parents m) (env.get ref m) idx tgt.2)
                   (list.filter (λ idx, tgt = list.dnth parents idx) (list.riota $ list.length parents))) :=
begin
intros nodes m tgt H_used_or_cost,
reflexivity
end

attribute [cgsimp] compute_grad_slow.equations._eqn_1

lemma grads_exist_at_simp_helper : Π (nodes : list node) (m : env) (tgt : reference),
  is_not_used_downstream tgt nodes → grads_exist_at nodes m tgt
| [] m tgt H_not_used := trivial

| (⟨ref, parents, operator.det op⟩::nodes) m tgt H_not_used :=
begin
dunfold grads_exist_at,
dunfold is_not_used_downstream at H_not_used,
dsimp,
split,
apply grads_exist_at_simp_helper nodes _ tgt H_not_used^.right,
intro H_in_parents,
exfalso,
exact H_not_used^.left H_in_parents
end

| (⟨ref, parents, operator.rand op⟩::nodes) m tgt H_not_used :=
begin
dunfold grads_exist_at,
dunfold is_not_used_downstream at H_not_used,
dsimp,
split,
intro H_in_parents,
exfalso,
exact H_not_used^.left H_in_parents,
intro y,
apply grads_exist_at_simp_helper nodes _ tgt H_not_used^.right
end

@[cgsimp] lemma grads_exist_at_det_not_used (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_not_used_downstream tgt nodes →
grads_exist_at (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
let m' := env.insert ref (op^.f (env.get_ks parents m)) m in
(tgt ∈ parents → op^.pre (env.get_ks parents m) ∧ grads_exist_at nodes (env.insert ref (op^.f (env.get_ks parents m)) m) ref) :=
begin
intros nodes m tgt H_not_used,
dunfold grads_exist_at,
dsimp,
rw (pextt (grads_exist_at_simp_helper _ _ _ H_not_used)),
simp
end

@[cgsimp] lemma grads_exist_at_det_used (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref^.2)
  : Π (nodes : list node) (m : env) (tgt : reference),
is_used_downstream tgt nodes →
grads_exist_at (⟨ref, parents, operator.det op⟩ :: nodes) m tgt
=
let m' := env.insert ref (op^.f (env.get_ks parents m)) m in
grads_exist_at nodes m' tgt ∧
(tgt ∈ parents → op^.pre (env.get_ks parents m) ∧ grads_exist_at nodes (env.insert ref (op^.f (env.get_ks parents m)) m) ref) :=
begin
intros nodes m tgt H, reflexivity
end

attribute [cgsimp] grads_exist_at.equations._eqn_1 grads_exist_at.equations._eqn_3

attribute [cgsimp] all_pdfs_std can_diff_under_ints_pdfs_std

attribute [cgsimp] T.smul_zero T.one_smul

attribute [cgsimp] if_pos if_neg if_true if_false

attribute [cgsimp] dif_pos dif_neg dif_ctx_simp_congr

attribute [cgsimp] mvn_mvn_empirical_kl_int mvn_bernoulli_neglogpdf_int

attribute [cgsimp] force_ok

attribute [cgsimp] list.sumr list.map list.concat list.head list.tail list.riota list.filter list.length list.dnth
                   list.sublist.refl list.nil_subset list.sublist_cons list.cons_append list.append_nil list.nil_append
                   list.p1 list.p2

attribute [cgsimp] hash_map.find_insert_eq hash_map.find_insert_ne

attribute [cgsimp] zero_add add_zero

attribute [cgsimp] dvec.head dvec.head2 dvec.head3

attribute [cgsimp] integrate_kl integrate_mvn_kl integrate_kl_pre integrate_mvn_kl_pre reparameterize
attribute [cgsimp] reparam reparameterize reparameterize_pre

attribute [cgsimp] all_parents_in_env all_costs_scalars /- grads_exist_at -/ pdfs_exist_at uniq_ids
                   is_gintegrable is_nabla_gintegrable is_gdifferentiable /- can_differentiate_under_integrals -/

attribute [cgsimp] graph.to_dist operator.to_dist sum_costs /- compute_grad_slow -/

attribute [cgsimp] E.E_bind E.E_ret

attribute [cgsimp] ops.neg ops.exp ops.log ops.sqrt ops.add ops.sub ops.mul ops.div ops.sum
                   ops.gemm ops.sigmoid ops.softplus ops.scale ops.mul_add ops.mvn_kl ops.bernoulli_neglogpdf

attribute [cgsimp] det.op.f ops.neg.f ops.exp.f ops.log.f ops.sqrt.f ops.add.f ops.sub.f ops.mul.f ops.div.f ops.sum.f
                   ops.gemm.f ops.sigmoid.f ops.softplus.f ops.scale.f ops.mul_add.f ops.mvn_kl.f ops.bernoulli_neglogpdf.f

attribute [cgsimp] det.op.pre ops.neg.f_pre ops.exp.f_pre ops.log.f_pre ops.sqrt.f_pre ops.add.f_pre ops.sub.f_pre ops.mul.f_pre ops.div.f_pre ops.sum.f_pre
                   ops.gemm.f_pre ops.sigmoid.f_pre ops.softplus.f_pre ops.scale.f_pre ops.mul_add.f_pre ops.mvn_kl.f_pre ops.bernoulli_neglogpdf.f_pre

attribute [cgsimp] det.op.pb ops.neg.f_pb ops.exp.f_pb ops.log.f_pb ops.sqrt.f_pb ops.add.f_pb ops.sub.f_pb ops.mul.f_pb ops.div.f_pb ops.sum.f_pb
                   ops.gemm.f_pb ops.sigmoid.f_pb ops.softplus.f_pb ops.scale.f_pb ops.mul_add.f_pb ops.mvn_kl.f_pb ops.bernoulli_neglogpdf.f_pb

attribute [cgsimp] det.op.is_odiff det.op.pb_correct det.op.is_ocont

attribute [cgsimp] rand.op.pdf rand.pdf.mvn rand.pdf.mvn_std
                   rand.op.pre rand.op.mvn rand.op.mvn_std rand.pre.mvn rand.pre.mvn_std

attribute [cgsimp] env.get_ks env.insert_all env.get_insert_same env.get_insert_diff

attribute [cgsimp] list.insertion_sort list.ordered_insert

attribute [cgsimp] program_to_graph program.program_to_graph_core program.get_id
--                  program.unary_to_cwise1 program.binary_to_cwise2
                  program.process_term program.empty_state program.process_rterm
                  program_to_graph._match_1
                  program.program_to_graph_core._match_1
                  program.program_to_graph_core._match_2
                  program.process_rterm._match_1
                  program.process_term._match_6
                  program.process_term._match_10
                  program.process_term._match_13
--                  program.process_term._match_16
--                  program.process_term._match_17
                  program.exp program.log program.sqrt program.softplus program.sigmoid

@[cgsimp] lemma lift_t_label_to_term (x : label) : (lift_t x : program.term) = (program.term.id x) := rfl

namespace tactic
open tactic

run_cmd mk_simp_attr `pcgsimp

attribute [pcgsimp] to_dist_congr_insert

meta def dcgsimp : tactic unit := do
  s ← join_user_simp_lemmas tt [`cgsimp],
  dsimp_core s

meta def gsimpt_core : Π (tac : tactic unit) (s_pre s_post : simp_lemmas) (e : expr), tactic (expr × expr) := λ tac s_pre s_post e,
do (a, new_tgt, pf) ← ext_simplify_core () {} s_post

(λ u, failed)
--pre
--(λ a s r p e, failed)
(λ a s r p e, do ⟨u, new_e, pr⟩ ← conv.apply_lemmas_core reducible s_pre tac r e,
                 return ((), new_e, pr, tt))

--post
(λ a s r p e, do ⟨u, new_e, pr⟩ ← conv.apply_lemmas_core reducible s tac r e,
                 return ((), new_e, pr, tt))
`eq e,

  return (new_tgt, pf)

meta def gsimpt (tac : tactic unit) : tactic unit := do
  s_pre ← join_user_simp_lemmas tt [`pcgsimp],
  s_post ← join_user_simp_lemmas tt [`cgsimp],
  tgt ← target,
  (new_tgt, pf) ← gsimpt_core tac s_pre s_post tgt,
  replace_target new_tgt pf

---------------

run_cmd mk_simp_attr `idne

attribute [idne] id_str_ne_nat id_nat_ne_str id_str_ne_str id_nat_ne_nat label.neq_of_to_nat label.to_nat

meta def prove_ids_neq : tactic unit :=
do s ← join_user_simp_lemmas tt [`idne, `natne],
   tgt ← target,
   (new_tgt, pf) ← simplify s tgt,
   replace_target new_tgt pf

meta def prove_refs_neq : tactic unit :=
do applyc `pair_neq_of_neq₁, prove_ids_neq

meta def cgsimpt (tac : tactic unit) : tactic unit := do
  repeat $ first [gsimpt tac, prove_refs_neq, prove_ids_neq, triv]

meta def cgsimpn : ℕ → tactic unit
| 0 := cgsimpt skip
| (n+1) := cgsimpt (cgsimpn n)

meta def cgsimp : tactic unit := cgsimpn 100

meta def forall_idxs (tac_base tac_step : tactic unit) : expr → tactic unit
| idx :=
tac_base <|>
(do cases idx [`_idx],
    solve1 tac_step,
    get_local `_idx >>= forall_idxs)

meta def prove_model_base : tactic unit :=
do exfalso,
   H_at_idx ← get_local `H_at_idx,
to_expr ```(list.at_idx_over %%H_at_idx dec_trivial) >>= exact

meta def prove_model_step : tactic unit :=
do H_at_idx ← get_local `H_at_idx,
   mk_app `and.right [H_at_idx] >>= note `H_tgt_eq,
   H_tgt_eq_type ← get_local `H_tgt_eq >>= infer_type,
   s ← join_user_simp_lemmas true [`cgsimp],
   (H_tgt_eq_new_type, pr) ← simplify s H_tgt_eq_type {},
   get_local `H_tgt_eq >>= λ H_tgt_eq, replace_hyp H_tgt_eq H_tgt_eq_new_type pr,
   get_local `H_tgt_eq >>= subst,
   applyc `certigrad.backprop_correct,
   trace "nodup tgts nodes",
     solve1 cgsimp,
   trace "at_idx...",
     solve1 cgsimp,
   trace "well_formed_at...",
     solve1 (constructor >> all_goals cgsimp),
   trace "grads_exist_at...",
     solve1 (cgsimp),
   trace "pdfs_exist_at...",
     solve1 (cgsimp),
   trace "is_gintegrable...",
     solve1 (cgsimp >> prove_is_mvn_integrable),
   trace "can_diff_under_ints...",
     solve1 (applyc `certigrad.can_diff_under_ints_of_all_pdfs_std >> cgsimp >> prove_is_mvn_uintegrable),
   trace "prove_for_tgt done"

meta def prove_model_ok : tactic unit :=
do -- unfold lets
   whnf_target,
   -- introduce hypotheses
   [tgt, idx, H_at_idx] ← intros | fail "can't intro hyps",
   -- repeated case-analysis on idx
   -- TODO(dhs): async would be great but I run out of memory
   forall_idxs prove_model_base prove_model_step idx

end tactic
end certigrad


inductive KrivineInstruction
  | Access (n: Nat)
  | Grab (next: KrivineInstruction)
  | Push (next: KrivineInstruction) (continuation: KrivineInstruction)

inductive KrivineClosure
  | pair (i: KrivineInstruction) (e: List KrivineClosure)

namespace Ex1

def KrivineEnv := List KrivineClosure

-- We need to define a `SizeOf` instance for `KrivineEnv`. Otherwise, we cannot use the auto-generated well-founded relation in
-- recursive definitions.
noncomputable instance : SizeOf KrivineEnv := inferInstanceAs (SizeOf (List KrivineClosure))
-- We also need a `simp` theorem
@[simp] theorem KrivineEnv.sizeOf_spec (env : KrivineEnv) : sizeOf env = sizeOf (α := List KrivineClosure) env := rfl

-- It would be great to have a `deriving SizeOf` for definitions such as `KrivineEnv` above.

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | [] => 0
  | KrivineClosure.pair u e :: closures => Nat.max (1 + depth e) (depth closures)

end Ex1

namespace Ex2
-- Same example, but we use `abbrev` to define `KrivineEnv`. Thus, we inherit the `SizeOf` instance for `List`s.

abbrev KrivineEnv := List KrivineClosure

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | [] => 0
  | KrivineClosure.pair u e :: closures => Nat.max (1 + depth e) (depth closures)

end Ex2

namespace Ex3
-- Same example, but using `structure` instead of `def`

structure KrivineEnv where
  env : List KrivineClosure

def KrivineEnv.depth (env : KrivineEnv) : Nat :=
  match env with
  | { env := [] } => 0
  | { env := KrivineClosure.pair u e :: closures } => Nat.max (1 + depth { env := e }) (depth { env := closures })

end Ex3


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Quotient types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.sigma.basic
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.data.setoid

universes u v u_a u_b u_c

namespace Mathlib

/- We import propext here, otherwise we would need a quot.lift for propositions. -/

-- iff can now be used to do substitutions in a calculation

theorem iff_subst {a : Prop} {b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  propext h₁ ▸ h₂

namespace quot

axiom sound {α : Sort u} {r : α → α → Prop} {a : α} {b : α} : r a b → Quot.mk r a = Quot.mk r b

protected theorem lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β)
    (c : ∀ (a b : α), r a b → f a = f b) (a : α) : Quot.lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem ind_beta {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop}
    (p : ∀ (a : α), β (Quot.mk r a)) (a : α) : Quot.ind p (Quot.mk r a) = p a :=
  rfl

protected def lift_on {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β)
    (c : ∀ (a b : α), r a b → f a = f b) : β :=
  Quot.lift f c q

protected theorem induction_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (q : Quot r)
    (h : ∀ (a : α), β (Quot.mk r a)) : β q :=
  Quot.ind h q

theorem exists_rep {α : Sort u} {r : α → α → Prop} (q : Quot r) : ∃ (a : α), Quot.mk r a = q :=
  quot.induction_on q fun (a : α) => Exists.intro a rfl

protected def indep {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (a : α) : psigma β :=
  psigma.mk (Quot.mk r a) (f a)

protected theorem indep_coherent {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (a : α) (b : α) : r a b → quot.indep f a = quot.indep f b :=
  fun (e : r a b) => psigma.eq (sound e) (h a b e)

protected theorem lift_indep_pr1 {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (q : Quot r) : psigma.fst (Quot.lift (quot.indep f) (quot.indep_coherent f h) q) = q :=
  Quot.ind (fun (a : α) => Eq.refl (psigma.fst (quot.indep f a))) q

protected def rec {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b)
    (q : Quot r) : β q :=
  eq.rec_on (quot.lift_indep_pr1 f h q)
    (psigma.snd (Quot.lift (quot.indep f) (quot.indep_coherent f h) q))

protected def rec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r)
    (f : (a : α) → β (Quot.mk r a))
    (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec f h q

protected def rec_on_subsingleton {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v}
    [h : ∀ (a : α), subsingleton (β (Quot.mk r a))] (q : Quot r) (f : (a : α) → β (Quot.mk r a)) :
    β q :=
  quot.rec f sorry q

protected def hrec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r)
    (f : (a : α) → β (Quot.mk r a)) (c : ∀ (a b : α), r a b → f a == f b) : β q :=
  quot.rec_on q f sorry

end quot

def quotient {α : Sort u} (s : setoid α) := Quot setoid.r

namespace quotient

protected def mk {α : Sort u} [s : setoid α] (a : α) : quotient s := Quot.mk setoid.r a

def sound {α : Sort u} [s : setoid α] {a : α} {b : α} : a ≈ b → quotient.mk a = quotient.mk b :=
  quot.sound

protected def lift {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) :
    (∀ (a b : α), a ≈ b → f a = f b) → quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : setoid α] {β : quotient s → Prop} :
    (∀ (a : α), β (quotient.mk a)) → ∀ (q : quotient s), β q :=
  Quot.ind

protected def lift_on {α : Sort u} {β : Sort v} [s : setoid α] (q : quotient s) (f : α → β)
    (c : ∀ (a b : α), a ≈ b → f a = f b) : β :=
  quot.lift_on q f c

protected theorem induction_on {α : Sort u} [s : setoid α] {β : quotient s → Prop} (q : quotient s)
    (h : ∀ (a : α), β (quotient.mk a)) : β q :=
  quot.induction_on q h

theorem exists_rep {α : Sort u} [s : setoid α] (q : quotient s) : ∃ (a : α), quotient.mk a = q :=
  quot.exists_rep q

protected def rec {α : Sort u} [s : setoid α] {β : quotient s → Sort v}
    (f : (a : α) → β (quotient.mk a))
    (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) (q : quotient s) : β q :=
  quot.rec f h q

protected def rec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s)
    (f : (a : α) → β (quotient.mk a))
    (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec_on q f h

protected def rec_on_subsingleton {α : Sort u} [s : setoid α] {β : quotient s → Sort v}
    [h : ∀ (a : α), subsingleton (β (quotient.mk a))] (q : quotient s)
    (f : (a : α) → β (quotient.mk a)) : β q :=
  quot.rec_on_subsingleton q f

protected def hrec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s)
    (f : (a : α) → β (quotient.mk a)) (c : ∀ (a b : α), a ≈ b → f a == f b) : β q :=
  quot.hrec_on q f c

protected def lift₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β]
    (f : α → β → φ)
    (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
    (q₁ : quotient s₁) (q₂ : quotient s₂) : φ :=
  quotient.lift (fun (a₁ : α) => quotient.lift (f a₁) sorry q₂) sorry q₁

protected def lift_on₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β]
    (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → φ)
    (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ :=
  quotient.lift₂ f c q₁ q₂

protected theorem ind₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Prop}
    (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) (q₁ : quotient s₁)
    (q₂ : quotient s₂) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂)
    (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α]
    [s₂ : setoid β] [s₃ : setoid φ] {δ : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
    (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
    (h : ∀ (a : α) (b : β) (c : φ), δ (quotient.mk a) (quotient.mk b) (quotient.mk c)) :
    δ q₁ q₂ q₃ :=
  quotient.ind
    (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => quotient.ind (fun (a₃ : φ) => h a₁ a₂ a₃) q₃) q₂)
    q₁

theorem exact {α : Sort u} [s : setoid α] {a : α} {b : α} : quotient.mk a = quotient.mk b → a ≈ b :=
  fun (h : quotient.mk a = quotient.mk b) => eq_imp_rel h

protected def rec_on_subsingleton₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β]
    {φ : quotient s₁ → quotient s₂ → Sort u_c}
    [h : ∀ (a : α) (b : β), subsingleton (φ (quotient.mk a) (quotient.mk b))] (q₁ : quotient s₁)
    (q₂ : quotient s₂) (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.rec_on_subsingleton q₁
    fun (a : α) => quotient.rec_on_subsingleton q₂ fun (b : β) => f a b

end quotient

inductive eqv_gen {α : Type u} (r : α → α → Prop) : α → α → Prop where
| rel : ∀ (x y : α), r x y → eqv_gen r x y
| refl : ∀ (x : α), eqv_gen r x x
| symm : ∀ (x y : α), eqv_gen r x y → eqv_gen r y x
| trans : ∀ (x y z : α), eqv_gen r x y → eqv_gen r y z → eqv_gen r x z

theorem eqv_gen.is_equivalence {α : Type u} (r : α → α → Prop) : equivalence (eqv_gen r) :=
  mk_equivalence (eqv_gen r) eqv_gen.refl eqv_gen.symm eqv_gen.trans

def eqv_gen.setoid {α : Type u} (r : α → α → Prop) : setoid α :=
  setoid.mk (eqv_gen r) (eqv_gen.is_equivalence r)

theorem quot.exact {α : Type u} (r : α → α → Prop) {a : α} {b : α} (H : Quot.mk r a = Quot.mk r b) :
    eqv_gen r a b :=
  quotient.exact
    (congr_arg (Quot.lift quotient.mk fun (x y : α) (h : r x y) => quot.sound (eqv_gen.rel x y h))
      H)

theorem quot.eqv_gen_sound {α : Type u} {r : α → α → Prop} {a : α} {b : α} (H : eqv_gen r a b) :
    Quot.mk r a = Quot.mk r b :=
  sorry

protected instance quotient.decidable_eq {α : Sort u} {s : setoid α}
    [d : (a b : α) → Decidable (a ≈ b)] : DecidableEq (quotient s) :=
  fun (q₁ q₂ : quotient s) => quotient.rec_on_subsingleton₂ q₁ q₂ fun (a₁ a₂ : α) => sorry

end Mathlib


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import tactic.ring
import data.num.lemmas
import data.tree

/-!
# ring2

An experimental variant on the `ring` tactic that uses computational
reflection instead of proof generation. Useful for kernel benchmarking.
-/

namespace tree

/-- `(reflect' t u α)` quasiquotes a tree `(t: tree expr)` of quoted
values of type `α` at level `u` into an `expr` which reifies to a `tree α`
containing the reifications of the `expr`s from the original `t`. -/
protected meta def reflect' (u : level) (α : expr) : tree expr → expr
| tree.nil := (expr.const ``tree.nil [u] : expr) α
| (tree.node a t₁ t₂) :=
  (expr.const ``tree.node [u] : expr) α a t₁.reflect' t₂.reflect'

/-- Returns an element indexed by `n`, or zero if `n` isn't a valid index.
See `tree.get`. -/
protected def get_or_zero {α} [has_zero α] (t : tree α) (n : pos_num) : α :=
  t.get_or_else n 0

end tree

namespace tactic.ring2

/-- A reflected/meta representation of an expression in a commutative
semiring. This representation is a direct translation of such
expressions - see `horner_expr` for a normal form. -/
@[derive has_reflect]
inductive csring_expr
/- (atom n) is an opaque element of the csring. For example,
a local variable in the context. n indexes into a storage
of such atoms - a `tree α`. -/
| atom : pos_num → csring_expr
/- (const n) is technically the csring's one, added n times.
Or the zero if n is 0. -/
| const : num → csring_expr
| add : csring_expr → csring_expr → csring_expr
| mul : csring_expr → csring_expr → csring_expr
| pow : csring_expr → num → csring_expr

namespace csring_expr

instance : inhabited csring_expr := ⟨const 0⟩

/-- Evaluates a reflected `csring_expr` into an element of the
original `comm_semiring` type `α`, retrieving opaque elements
(atoms) from the tree `t`. -/
def eval {α} [comm_semiring α] (t : tree α) : csring_expr → α
| (atom n)  := t.get_or_zero n
| (const n) := n
| (add x y) := eval x + eval y
| (mul x y) := eval x * eval y
| (pow x n) := eval x ^ (n : ℕ)

end csring_expr

/-- An efficient representation of expressions in a commutative
semiring using the sparse Horner normal form. This type admits
non-optimal instantiations (e.g. `P` can be represented as `P+0+0`),
so to get good performance out of it, care must be taken to maintain
an optimal, *canonical* form. -/
@[derive decidable_eq]
inductive horner_expr
/- (const n) is a constant n in the csring, similarly to the same
constructor in `csring_expr`. This one, however, can be negative. -/
| const : znum → horner_expr
/- (horner a x n b) is a*xⁿ + b, where x is the x-th atom
in the atom tree. -/
| horner : horner_expr → pos_num → num → horner_expr → horner_expr

namespace horner_expr

/-- True iff the `horner_expr` argument is a valid `csring_expr`.
For that to be the case, all its constants must be non-negative. -/
def is_cs : horner_expr → Prop
| (const n) := ∃ m:num, n = m.to_znum
| (horner a x n b) := is_cs a ∧ is_cs b

instance : has_zero horner_expr := ⟨const 0⟩
instance : has_one horner_expr := ⟨const 1⟩
instance : inhabited horner_expr := ⟨0⟩

/-- Represent a `csring_expr.atom` in Horner form. -/
def atom (n : pos_num) : horner_expr := horner 1 n 1 0

def to_string : horner_expr → string
| (const n) := _root_.repr n
| (horner a x n b) :=
    "(" ++ to_string a ++ ") * x" ++ _root_.repr x ++ "^"
        ++ _root_.repr n ++ " + " ++ to_string b
instance : has_to_string horner_expr := ⟨to_string⟩

/-- Alternative constructor for (horner a x n b) which maintains canonical
form by simplifying special cases of `a`. -/
def horner' (a : horner_expr)
  (x : pos_num) (n : num) (b : horner_expr) : horner_expr :=
match a with
| const q := if q = 0 then b else horner a x n b
| horner a₁ x₁ n₁ b₁ :=
  if x₁ = x ∧ b₁ = 0 then horner a₁ x (n₁ + n) b
  else horner a x n b
end

def add_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then e else begin
  induction e with n a x n b A B,
  { exact const (k + n) },
  { exact horner a x n B }
end

def add_aux (a₁ : horner_expr) (A₁ : horner_expr → horner_expr) (x₁ : pos_num) :
  horner_expr → num → horner_expr → (horner_expr → horner_expr) → horner_expr
| (const n₂)           n₁ b₁ B₁ := add_const n₂ (horner a₁ x₁ n₁ b₁)
| (horner a₂ x₂ n₂ b₂) n₁ b₁ B₁ :=
  let e₂ := horner a₂ x₂ n₂ b₂ in
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
  | ordering.gt := horner a₂ x₂ n₂ (add_aux b₂ n₁ b₁ B₁)
  | ordering.eq :=
    match num.sub' n₁ n₂ with
    | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
    | (znum.pos k) := horner (add_aux a₂ k 0 id) x₁ n₂ (B₁ b₂)
    | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
    end
  end

def add : horner_expr → horner_expr → horner_expr
| (const n₁)           e₂ := add_const n₁ e₂
| (horner a₁ x₁ n₁ b₁) e₂ := add_aux a₁ (add a₁) x₁ e₂ n₁ b₁ (add b₁)
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact add_const n₁ e₂ },
  exact match e₂ with e₂ := begin
    induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁;
    let e₁ := horner a₁ x₁ n₁ b₁,
    { exact add_const n₂ e₁ },
    let e₂ := horner a₂ x₂ n₂ b₂,
    exact match pos_num.cmp x₁ x₂ with
    | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
    | ordering.gt := horner a₂ x₂ n₂ (B₂ n₁ b₁)
    | ordering.eq :=
      match num.sub' n₁ n₂ with
      | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | (znum.pos k) := horner (A₂ k 0) x₁ n₂ (B₁ b₂)
      | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
      end
    end
  end end
end-/

def neg (e : horner_expr) : horner_expr :=
begin
  induction e with n a x n b A B,
  { exact const (-n) },
  { exact horner A x n B }
end

def mul_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then 0 else if k = 1 then e else begin
  induction e with n a x n b A B,
  { exact const (n * k) },
  { exact horner A x n B }
end

def mul_aux (a₁ x₁ n₁ b₁) (A₁ B₁ : horner_expr → horner_expr) :
  horner_expr → horner_expr
| (const n₂) := mul_const n₂ (horner a₁ x₁ n₁ b₁)
| e₂@(horner a₂ x₂ n₂ b₂) :=
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner (A₁ e₂) x₁ n₁ (B₁ e₂)
  | ordering.gt := horner (mul_aux a₂) x₂ n₂ (mul_aux b₂)
  | ordering.eq := let haa := horner' (mul_aux a₂) x₁ n₂ 0 in
    if b₂ = 0 then haa else haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂))
  end

def mul : horner_expr → horner_expr → horner_expr
| (const n₁)           := mul_const n₁
| (horner a₁ x₁ n₁ b₁) := mul_aux a₁ x₁ n₁ b₁ (mul a₁) (mul b₁).
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact mul_const n₁ e₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂;
  let e₁ := horner a₁ x₁ n₁ b₁,
  { exact mul_const n₂ e₁ },
  let e₂ := horner a₂ x₂ n₂ b₂,
  cases pos_num.cmp x₁ x₂,
  { exact horner (A₁ e₂) x₁ n₁ (B₁ e₂) },
  { let haa := horner' A₂ x₁ n₂ 0,
    exact if b₂ = 0 then haa else
      haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂)) },
  { exact horner A₂ x₂ n₂ B₂ }
end-/

instance : has_add horner_expr := ⟨add⟩
instance : has_neg horner_expr := ⟨neg⟩
instance : has_mul horner_expr := ⟨mul⟩

def pow (e : horner_expr) : num → horner_expr
| 0 := 1
| (num.pos p) := begin
  induction p with p ep p ep,
  { exact e },
  { exact (ep.mul ep).mul e },
  { exact ep.mul ep }
end

def inv (e : horner_expr) : horner_expr := 0

/-- Brings expressions into Horner normal form. -/
def of_csexpr : csring_expr → horner_expr
| (csring_expr.atom n)  := atom n
| (csring_expr.const n) := const n.to_znum
| (csring_expr.add x y) := (of_csexpr x).add (of_csexpr y)
| (csring_expr.mul x y) := (of_csexpr x).mul (of_csexpr y)
| (csring_expr.pow x n) := (of_csexpr x).pow n

/-- Evaluates a reflected `horner_expr` - see `csring_expr.eval`. -/
def cseval {α} [comm_semiring α] (t : tree α) : horner_expr → α
| (const n)        := n.abs
| (horner a x n b) := tactic.ring.horner (cseval a) (t.get_or_zero x) n (cseval b)

theorem cseval_atom {α} [comm_semiring α] (t : tree α)
  (n : pos_num) : (atom n).is_cs ∧ cseval t (atom n) = t.get_or_zero n :=
⟨⟨⟨1, rfl⟩, ⟨0, rfl⟩⟩, (tactic.ring.horner_atom _).symm⟩

theorem cseval_add_const {α} [comm_semiring α] (t : tree α)
  (k : num) {e : horner_expr} (cs : e.is_cs) :
  (add_const k.to_znum e).is_cs ∧
    cseval t (add_const k.to_znum e) = k + cseval t e :=
begin
  simp [add_const],
  cases k; simp! *,
  simp [show znum.pos k ≠ 0, from dec_trivial],
  induction e with n a x n b A B; simp *,
  { rcases cs with ⟨n, rfl⟩,
    refine ⟨⟨n + num.pos k, by simp [add_comm]; refl⟩, _⟩,
    cases n; simp! },
  { rcases B cs.2 with ⟨csb, h⟩, simp! [*, cs.1],
    rw [← tactic.ring.horner_add_const, add_comm], rw add_comm }
end

theorem cseval_horner' {α} [comm_semiring α] (t : tree α)
  (a x n b) (h₁ : is_cs a) (h₂ : is_cs b) :
  (horner' a x n b).is_cs ∧ cseval t (horner' a x n b) =
    tactic.ring.horner (cseval t a) (t.get_or_zero x) n (cseval t b) :=
begin
  cases a with n₁ a₁ x₁ n₁ b₁; simp [horner']; split_ifs,
  { simp! [*, tactic.ring.horner] },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ },
  { refine ⟨⟨h₁.1, h₂⟩, eq.symm _⟩, simp! *,
    apply tactic.ring.horner_horner, simp },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ }
end

theorem cseval_add {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (add e₁ e₂).is_cs ∧
  cseval t (add e₁ e₂) = cseval t e₁ + cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa using cseval_add_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simp! [cseval_add_const t n₂ cs₁, add_comm] },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { rcases B₁ csb₁ cs₂ with ⟨csh, h⟩,
    refine ⟨⟨csa₁, csh⟩, eq.symm _⟩,
    apply tactic.ring.horner_add_const,
    exact h.symm },
  { cases C,
    have B0 : is_cs 0 → ∀ {e₂ : horner_expr}, is_cs e₂ →
      is_cs (add 0 e₂) ∧ cseval t (add 0 e₂) = cseval t 0 + cseval t e₂ :=
      λ _ e₂ c, ⟨c, (zero_add _).symm⟩,
     cases e : num.sub' n₁ n₂ with k k; simp!,
    { have : n₁ = n₂,
      { have := congr_arg (coe : znum → ℤ) e,
        simp at this,
        have := sub_eq_zero.1 this,
        rw [← num.to_nat_to_int, ← num.to_nat_to_int] at this,
        exact num.to_nat_inj.1 (int.coe_nat_inj this) },
      subst n₂,
      rcases cseval_horner' _ _ _ _ _ _ _ with ⟨csh, h⟩,
      { refine ⟨csh, h.trans (eq.symm _)⟩,
        simp *,
        apply tactic.ring.horner_add_horner_eq; try {refl} },
      all_goals {simp! *} },
    { simp [B₁ csb₁ csb₂, add_comm],
      rcases A₂ csa₂ _ _ B0 ⟨csa₁, 0, rfl⟩ with ⟨csh, h⟩,
      refine ⟨csh, eq.symm _⟩,
      rw [show id = add 0, from rfl, h],
      apply tactic.ring.horner_add_horner_gt,
      { change (_ + k : ℕ) = _,
        rw [← int.coe_nat_inj', int.coe_nat_add,
          eq_comm, ← sub_eq_iff_eq_add'],
        simpa using congr_arg (coe : znum → ℤ) e },
      { refl },
      { apply add_comm } },
    { have : (horner a₂ x₁ (num.pos k) 0).is_cs := ⟨csa₂, 0, rfl⟩,
      simp [B₁ csb₁ csb₂, A₁ csa₁ this],
      symmetry, apply tactic.ring.horner_add_horner_lt,
      { change (_ + k : ℕ) = _,
          rw [← int.coe_nat_inj', int.coe_nat_add,
            eq_comm, ← sub_eq_iff_eq_add', ← neg_inj, neg_sub],
        simpa using congr_arg (coe : znum → ℤ) e },
      all_goals { refl } } },
  { rcases B₂ csb₂ _ _ B₁ ⟨csa₁, csb₁⟩ with ⟨csh, h⟩,
    refine ⟨⟨csa₂, csh⟩, eq.symm _⟩,
    apply tactic.ring.const_add_horner,
    simp [h] }
end

theorem cseval_mul {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (mul e₁ e₂).is_cs ∧
  cseval t (mul e₁ e₂) = cseval t e₁ * cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa [mul_comm] using cseval_mul_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simpa! using cseval_mul_const t n₂ cs₁ },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases A₂ csa₂ with csA₂ hA₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { simp [A₁ csa₁ cs₂, B₁ csb₁ cs₂],
    symmetry, apply tactic.ring.horner_mul_const; refl },
  { cases cseval_horner' t _ x₁ n₂ 0 csA₂ ⟨0, rfl⟩ with csh₁ h₁,
    cases C, split_ifs,
    { subst b₂,
      refine ⟨csh₁, h₁.trans (eq.symm _)⟩,
      apply tactic.ring.horner_mul_horner_zero; try {refl},
      simp! [hA₂] },
    { cases A₁ csa₁ csb₂ with csA₁ hA₁,
      cases cseval_add t csh₁ _ with csh₂ h₂,
      { refine ⟨csh₂, h₂.trans (eq.symm _)⟩,
        apply tactic.ring.horner_mul_horner; try {refl},
        simp! * },
      exact ⟨csA₁, (B₁ csb₁ csb₂).1⟩ } },
  { simp [A₂ csa₂, B₂ csb₂], rw [mul_comm, eq_comm],
    apply tactic.ring.horner_const_mul,
    {apply mul_comm}, {refl} },
end

theorem cseval_pow {α} [comm_semiring α] (t : tree α)
  {x : horner_expr} (cs : x.is_cs) :
  ∀ (n : num), (pow x n).is_cs ∧
    cseval t (pow x n) = cseval t x ^ (n : ℕ)
| 0 := ⟨⟨1, rfl⟩, (pow_zero _).symm⟩
| (num.pos p) := begin
  simp [pow], induction p with p ep p ep,
  { simp * },
  { simp [pow_bit1],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    cases cseval_mul t cs₀ cs with cs₁ h₁,
    simp * },
  { simp [pow_bit0],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    simp * }
end

/-- For any given tree `t` of atoms and any reflected expression `r`,
the Horner form of `r` is a valid csring expression, and under `t`,
the Horner form evaluates to the same thing as `r`. -/
theorem cseval_of_csexpr {α} [comm_semiring α] (t : tree α) :
  ∀ (r : csring_expr), (of_csexpr r).is_cs ∧ cseval t (of_csexpr r) = r.eval t
| (csring_expr.atom n)  := cseval_atom _ _
| (csring_expr.const n) := ⟨⟨n, rfl⟩, by cases n; refl⟩
| (csring_expr.add x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_add t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.mul x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_mul t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.pow x n) :=
  let ⟨cs, h⟩ := cseval_of_csexpr x,
      ⟨cs, h⟩ := cseval_pow t cs n in ⟨cs, by simp! [h, *]⟩

end horner_expr

/-- The main proof-by-reflection theorem. Given reflected csring expressions
`r₁` and `r₂` plus a storage `t` of atoms, if both expressions go to the
same Horner normal form, then the original non-reflected expressions are
equal. `H` follows from kernel reduction and is therefore `rfl`. -/
theorem correctness {α} [comm_semiring α] (t : tree α) (r₁ r₂ : csring_expr)
  (H : horner_expr.of_csexpr r₁ = horner_expr.of_csexpr r₂) :
  r₁.eval t = r₂.eval t :=
by repeat {rw ← (horner_expr.cseval_of_csexpr t _).2}; rw H

/-- Reflects a csring expression into a `csring_expr`, together
with a dlist of atoms, i.e. opaque variables over which the
expression is a polynomial. -/
meta def reflect_expr : expr → csring_expr × dlist expr
| `(%%e₁ + %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂, l₁ ++ l₂)
/-| `(%%e₁ - %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂.neg, l₁ ++ l₂)
| `(- %%e) := let (r, l) := reflect_expr e in (r.neg, l)-/
| `(%%e₁ * %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂, l₁ ++ l₂)
/-| `(has_inv.inv %%e) := let (r, l) := reflect_expr e in (r.neg, l)
| `(%%e₁ / %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂.inv, l₁ ++ l₂)-/
| e@`(%%e₁ ^ %%e₂) :=
  match reflect_expr e₁, expr.to_nat e₂ with
  | (r₁, l₁), some n₂ := (r₁.pow (num.of_nat' n₂), l₁)
  | (r₁, l₁), none := (csring_expr.atom 1, dlist.singleton e)
  end
| e := match expr.to_nat e with
  | some n := (csring_expr.const (num.of_nat' n), dlist.empty)
  | none := (csring_expr.atom 1, dlist.singleton e)
  end

/-- In the output of `reflect_expr`, `atom`s are initialized with incorrect indices.
The indices cannot be computed until the whole tree is built, so another pass over
the expressions is needed - this is what `replace` does. The computation (expressed
in the state monad) fixes up `atom`s to match their positions in the atom tree.
The initial state is a list of all atom occurrences in the goal, left-to-right. -/
meta def csring_expr.replace (t : tree expr) : csring_expr → state_t (list expr) option csring_expr
| (csring_expr.atom _)  := do e ← get,
  p ← monad_lift (t.index_of (<) e.head),
  put e.tail, pure (csring_expr.atom p)
| (csring_expr.const n) := pure (csring_expr.const n)
| (csring_expr.add x y) := csring_expr.add <$> x.replace <*> y.replace
| (csring_expr.mul x y) := csring_expr.mul <$> x.replace <*> y.replace
| (csring_expr.pow x n) := (λ x, csring_expr.pow x n) <$> x.replace
--| (csring_expr.neg x)   := csring_expr.neg <$> x.replace
--| (csring_expr.inv x)   := csring_expr.inv <$> x.replace

end tactic.ring2

namespace tactic
namespace interactive
open interactive interactive.types lean.parser
open tactic.ring2

local postfix (name := parser.optional) `?`:9001 := optional

/-- `ring2` solves equations in the language of rings.

It supports only the commutative semiring operations, i.e. it does not normalize subtraction or
division.

  This variant on the `ring` tactic uses kernel computation instead
  of proof generation. In general, you should use `ring` instead of `ring2`. -/
meta def ring2 : tactic unit :=
do `[repeat {rw ← nat.pow_eq_pow}],
  `(%%e₁ = %%e₂) ← target
  | fail "ring2 tactic failed: the goal is not an equality",
  α ← infer_type e₁,
  expr.sort (level.succ u) ← infer_type α,
  let (r₁, l₁) := reflect_expr e₁,
  let (r₂, l₂) := reflect_expr e₂,
  let L := (l₁ ++ l₂).to_list,
  let s := tree.of_rbnode (rbtree_of L).1,
  (r₁, L) ← (state_t.run (r₁.replace s) L : option _),
  (r₂, _) ← (state_t.run (r₂.replace s) L : option _),
  let se : expr := s.reflect' u α,
  let er₁ : expr := reflect r₁,
  let er₂ : expr := reflect r₂,
  cs ← mk_app ``comm_semiring [α] >>= mk_instance,
  e ← to_expr ``(correctness %%se %%er₁ %%er₂ rfl)
    <|> fail ("ring2 tactic failed, cannot show equality:\n"
      ++ to_string (horner_expr.of_csexpr r₁) ++
      "\n  =?=\n" ++ to_string (horner_expr.of_csexpr r₂)),
  tactic.exact e

add_tactic_doc
{ name        := "ring2",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.ring2],
  tags        := ["arithmetic", "simplification", "decision procedure"] }

end interactive
end tactic

namespace conv.interactive
open conv

meta def ring2 : conv unit := discharge_eq_lhs tactic.interactive.ring2

end conv.interactive


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 :=density_irrational_orbit (α : ℚ) : (α.is_irrational) → ∀ ε > 0, ∃! n ∈ ℤ, ε > n * α - n,
begin
  assume (h1 : α.is_irrational) (ε),
  have h2 : ∃! n : ℤ, (0 < n * α - n) ∧ ((n+1) * α - (n+1) < ε), from by auto using [floor_le_int, floor_lt_int, is_irrational, exists_unique.exists],
  show ∃! n : ℤ, ε > n * α - n, from by auto [h2, exists_unique.unique, exists_unique.exists, floor_le_int, floor_lt_int, is_irrational],
end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℚ) (h1 : α ≠ 0) : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ [0, 1], |y - (n * α) % 1| < ε :=
begin
  assume h2 : α ≠ 0,
  have h3 : ∀ i j : ℤ, i ≠ j → ⟨i*α⟩ ≠ ⟨j*α⟩, from
  begin
    assume (i j : ℤ) (h4 : i ≠ j),
    have h5 : i * α - ⌊i * α⌋ ≠ j * α - ⌊j * α⌋, from
      begin
        assume h6,
        show false, from
          begin
            have h7 : α = ⌊i * α⌋ - ⌊j * α⌋ / (i - j), from
              begin
                calc α = i * α - ⌊i * α⌋ : by linarith
                ... = j * α - ⌊j * α⌋ : by linarith
                ... = (j - i) * α + ⌊j * α⌋ - ⌊i * α⌋ : by linarith
                ... = ⌊j * α⌋ - ⌊i * α⌋ : by linarith
                ... = ⌊j * α⌋ - ⌊i * α⌋ / (i - j) : by linarith
              end,
            have h8 : α ∈ ℤ, from
              begin
                have h9 : ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                  begin
                    have h10 : i ≠ j, from by linarith,
                    show ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                      begin
                        have h11 : ⌊j * α⌋ - ⌊i * α⌋ ∈ ℤ, from by linarith,
                        have h12 : (i - j) ∈ ℤ, from by linarith,
                        show ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                          begin
                            have h13 : (i - j) ≠ 0, from by linarith,
                            show (⌊j * α⌋ - ⌊i * α⌋) / (i - j) ∈ ℤ, from by linarith [h11, h13],
                          end
                      end
                  end,
                have h11 : α ∈ ℚ, from
                  begin
                    show α ∈ ℚ, from by linarith using [old_nat_cast.injective]
                  end,
                show α ∈ ℤ, from by linarith [h9],
              end,
            show false, from by linarith [h7, h8]
          end
      end,
      show ⟨i*α⟩ ≠ ⟨j*α⟩, from
        begin
          show ⟨i*α⟩ ≠ ⟨j*α⟩, from
            begin
              show ⟨i*α⟩ ≠ ⟨j*α⟩, from by linarith [h5]
            end
        end
  end,

  have h6 : ∀ (i j : ℤ), i ≠ j → ⟨i * α⟩ ≠ ⟨j * α⟩, from h3,

  have h7 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ x : ℤ, ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
    begin
      have h8 : ∀ i j : ℤ, i ≠ j → ⟨i * α⟩ ≠ ⟨j * α⟩, from h6,
      have h9 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
        begin
          have h10 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
            begin
              have h11 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                begin
                  have h12 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                    begin
                      have h13 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                        begin
                          have h14 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                            begin
                              have h15 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                begin
                                  have h16 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                    begin
                                      have h17 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                        begin
                                          have h18 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                            begin
                                              have h19 : set.range (λ (i : ℤ), ⟨i * α⟩) ⊆ set.Ico 0 1, from
                                                begin
                                                  assume (x : ℝ),
                                                  assume (h20 : x ∈ set.range (λ (i : ℤ), ⟨i * α⟩)),
                                                  cases h20 with i h21,
                                                  assume h22 : ⟨i * α
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) (hα : ¬ is_rat α) :  dense_of_dense_range (λ j : ℤ, (floor j α : ℝ)) :=
begin
  let s : set ℝ := λ (i : ℤ), ((floor i α) : ℝ),
  let ƒ : ℤ → ℤ → ℝ := λ (i j : ℤ), floor i α - floor j α,
  let h1 : s.finite.nonempty := by norm_num,
  let h2 : ∀ (i j : ℤ), (i : ℝ) ≠ j → s i ≠ s j := by auto [hα, floor_divides_iff_rat],
  let h3 : s.infinite := by auto [hα, floor_divides_iff_rat],
  let h4 : ∃ (y : ℝ), is_limit_point s y, from exists_limit_point_of_infinite s h3,
  let h5 : ∃ (y : ℝ), is_limit_point s y := by auto [h4],

  let h6 : ∃ (y : ℝ), is_limit_point s y, from exists_limit_point_of_infinite s h3,
  let h7 : ∃ (y : ℝ), is_limit_point s y := by auto [h6],

  have h8 : ∃! x ∈ s, ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε, from exists_unique_limit_point_of_infinite s h3 h5,

  let h9 : ∃! x ∈ s, ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε, from exists_unique_limit_point_of_infinite s h3 h7,
  let h10 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h9],
  let h11 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h8],
  let h12 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h11],
  let h13 : ∃ (x : ℤ), ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h12],
  let h14 : ∃ (x : ℤ), ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h13],

  let x := classical.some (h12).some,
  let h15 : ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h12],
  let h16 : ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h15],
  let h17 : ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h15],

  let h18 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h16],
  let h19 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h18],
  let h20 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h19],

  let N := classical.some (h20).some,
  let y : ℝ := (floor N α - floor x α) * (floor N α : ℝ),
  let h21 : y ∈ s N := by auto [floor_divides_iff_rat, hα],
  let h22 : N > x := by auto [h20],
  let h23 : s N ∈ 𝓝[s x] 0.5 := by auto [h20],

  have h24 : {N • s N - s x} < √2,
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h25 : {N • s N - s x} < √2,
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  let h26 : {N • s N - s x} < √2 := by auto [h25],
  let h27 : {N • s N - s x} < √2 := by auto [h24],
  let h28 : {N • s N - s x} < √2 := by auto [h27],

  have h29 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [div_self, floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h30 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [div_self, floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h31 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [h29],

  have h32 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [h30],
  let h33 : 2 • {N • s N - s x} < 2 * √2 := by auto [h32],

  have h34 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h25],

  have h35 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h24],
  let h36 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h35],

  have h37 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h34],
  let h38 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h37],

  have h39 : y < 2 • {N • s N - s x},
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  let h40 : y < 2 • {N • s N - s x} := by auto [h39],
  let h41 : ((y / 2) + s x : ℝ) < (N • s N : ℝ) := by auto [h40],
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h1 : ¬ is_rat α) : ∀ ε > 0, ∃ n, n ∈ ℤ ∧ abs(n * α - ⌊n * α⌋) < ε :=
begin
  assume ε,
  assume h2 : ε > 0,

  have h3 : α ≠ 0, from by auto [irrat],

  let S : set ℝ := {(⌊i * α⌋ - i * α) | i : ℤ},
  have h4 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ≠ (⌊j * α⌋ - j * α), from by auto [floor_eq_iff_rat, irrat],

  have h5 : ∀ (i j : ℤ), i ≠ j → i * α ≠ j * α, from by auto [irrat, mul_eq_zero, eq_zero_of_mul_eq_zero, h3],

  have h6 : ∀ (i j : ℤ), i ≠ j → i * α ∉ {j * α}, from by auto [h5],

  have h7 : ∀ (i j : ℤ), i ≠ j → i * α - ⌊i * α⌋ ∉ {j * α - ⌊j * α⌋}, from by auto [eq_iff_sub_eq_zero, h6],

  have h8 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ∉ {(⌊j * α⌋ - j * α)}, from by auto [h7],

  have h9 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ∉ S := by auto [S, h8],

  have h10 : ∀ a ∈ S, ∃ b ∈ S, abs(a - b) < ε, from by auto [sub_le_sub_left, h2],

  have h11 : ∃ b ∈ S, abs(0 - b) < ε, from by auto [irrat, h10, h4, h9, S],

  cases h11 with b h12,

  have h13 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ S, from by auto [n_floor_eq_sub, S, exists.intro 0, mem_image, exists.intro 0, mem_range],
  have h14 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ {(⌊i * α⌋ - i * α) | i : ℤ}, from by auto [S, h13],

  have h15 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ {i * α - ⌊i * α⌋ | i : ℤ}, from by auto [S, h14],

  have h16 : ∃ n, n ∈ ℤ ∧ abs (n * α - ⌊n * α⌋) < ε,
  from by auto [h12, h15, exists.intro 1, exists.intro 0, exists.intro b, exists.intro 0, exists.intro 0],
  show ∃ n, n ∈ ℤ ∧ abs (n * α - ⌊n * α⌋) < ε, from by auto [h16],
end

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit (α : ℝ) : ∀ ε > 0, ∃ x : ℝ, x ∈ set.range (λ i, ↑i*α) ∧ x ∈ Icc (0 : ℝ) (1 : ℝ) ∧ ∃ n : ℕ, |x - n * α| < ε :=
begin
  assume ε,
  assume hε : ε > 0,

  have h3 : ∀ i j : ℕ, ((i : ℝ) * α - ↑i) ≠ ((j : ℝ) * α - ↑j), from by auto,

  -- choose a sequence of all the fractional parts from 0 to infinity, or all the A such that (∃ B : ℝ, A = B - ⌊B⌋)
  -- in other words, choose (A is an element of the powerset of ℝ, and there exists a B such that A = B - ⌊B⌋)
  have h4 : ∀ A ∈ 𝒫 ℝ, ∃ B : ℝ, A = B - ⌊B⌋, from by auto,

  have h6 : ∀ n : ℕ, ((n : ℚ) * α - ⌊(n : ℚ) * α⌋) ∈ set.range (λ B, B - ⌊B⌋), from by auto,

  have h7 : (∀ x, x ∈ set.range (λ B, B - ⌊B⌋) →  x ∈ Icc (0 : ℝ) (1 : ℝ)), from by auto [set.mem_range],

  have h8 : ∀ n : ℕ, ((n : ℝ) * α - ⌊(n : ℝ) * α⌋)  ∈ Icc (0 : ℝ) (1 : ℝ), from by auto [h6, h7],

  have h9 : ∀ B ∈ Icc (0 : ℝ) (1 : ℝ), ∃ n : ℕ, |((n : ℝ) * α - ⌊(n : ℝ) * α⌋) - B| < ε, from by auto,

  show (∃ (x : ℝ), x ∈ set.range (λ B, B - ⌊B⌋) ∧ x ∈ Icc (0 : ℝ) (1 : ℝ) ∧ ∃ (n : ℕ), |x - n * α| < ε) := by auto [h6, h8, h9],
end

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) : irrational α → ∀ e : ℝ, ∃ δ:ℝ, 0 < δ ∧ δ < e :=
begin
intros h,
assume e,
let x : ℝ := (1 + e/2) * (1/2),
have hx : 0 < x, from by auto [lt_mul_iff],
use x,

 show (0 < x) ∧ x < e, from by auto [add_one_le_iff, le_add_iff, sub_neg_iff, le_of_lt, lt_mul_iff] using [lt_add_iff, add_lt_add_right, one_lt_two, mul_self_lt_mul_self_iff, hx],
end

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=rational_orbit (α : ℝ) : irrational α → ∀ y ⊆ set.range (λ n : ℤ, n * α % 1), dense y :=
begin
  assume h1,
  assume y ⊆ set.range (λ n : ℤ, n * α % 1),
  have h2 : ∀ n m : ℤ, n ≠ m → (n*α % 1) ≠ (m*α % 1), from by auto [ring, mul_comm],
  have h3 : ∀ n m : ℤ, (n*α % 1) ≠ (m*α % 1), from by auto [h2] using [irrational_of_int_eq_zero, irrational_of_int_neq_zero, h1],
  let S : set ℝ := {m * α % 1 | m : ℤ},
  have h4 : y ⊆ S, from by auto [set.subset_def],
  have h5 : S ⊆ set.range (λ n : ℤ, n * α % 1), from by auto [set.subset_def],
  have h6 : finite y → y ≠ ∅ → nonempty y → nonempty y, from by auto [finite.ne_empty_iff_exists_mem, set.not_empty_iff_exists_mem, finite_subset, finite.coe_to_finset],
  have h8 : y ⊆ y, from by auto [set.subset.refl],
  have h9 : y.nonempty, from by auto [h4, h6, h5, set.nonempty_range],
  have h10 : dense S, from by auto [dense_iff_countable_open_dense_union, countable_iff_countably_infinite, range_is_countably_infinite, countable_iff_seq_range, set.seq_range_iff_forall_range, set.dense_Icc_iff_Ico_union_Ioc],
  have h11 : dense y, from by auto [h10, h4, set.dense_subset],
  show ∃ n : ℝ, n ∈ y ∧ ∀ ε > 0, ∃ m : ℝ, m ∈ y ∧ m ≠ n ∧ m ∈ Icc (n - ε) (n + ε), from by auto [h11, set.dense_iff_exists_between]
end

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h : ¬ is_rational α) : ∀ y ∈ set.Icc 0 1, ∃ x ∈ set.Icc 0 1, |y - x| ≤ 1 :=
begin
    assume (y : ℝ) (hy : y ∈ set.Icc 0 1),

    set S : set ℝ := {x : ℝ | ∃ i : ℤ, x = (x - floor x) ∧ x ∈ set.Icc 0 1},

    have h_empty : ∀ x : ℝ, x ∉ S, from by auto [not_lt_of_ge, lt_irrefl, (show 0 ≤ x - floor x, by linarith)],
    have h_not_empty : S ≠ ∅, from by auto [exists.intro (x - floor x) (and.intro (eq.refl x) (and.intro (by auto [floor_nonneg]) (by auto [not_lt_of_ge])))],
    have h_infinite : S.infinite, from by auto [h_not_empty, h_empty, infinite_Icc_iff, forall_exists_not],
    have h_bounded : S.bounded, from by auto [h_not_empty, bounded_Icc_iff, set.Icc_subset_Icc_left],
    have h_closed : S.closed, from by auto [set.Icc_closed],

    have h_Icc_0_1 : ∀ x : ℝ, x ∈ S ↔ x ∈ set.Icc 0 1, from by auto [set.Icc_subset_Icc_left],

    have h_dense : ∀ y : ℝ, y ∈ set.Icc 0 1 → ∃ x : ℝ, x ∈ S ∧ |y - x| ≤ 1, from by auto [dense_iff_inter_open, h_Icc_0_1, h_infinite, h_bounded, h_closed, h_not_empty],

    cases h_dense y hy with x hx,
    cases hx with hx_mem hx_pf,
    use x,
    from and.intro hx_mem hx_pf,
end

--OUTPUT 9
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit {α : Type*} [s : dense_linear_order α] (a : α) : a ∉ (𝕀) → ∀ x, ∃ n ∈ ℤ, x - (1 : α) < (n : α) * a ∧ (n + 1) * a ≤ x :=
begin
  assume h1 : a ∉ (𝕀),
  assume x : α,

  have h2 : ∀ n m : ℤ, n ≠ m → n * a ≠ m * a,
  from by {intros n m h3, assume h4, have h5 := h3, rw h4 at h5, contradiction},

  have h6 : ∀ n m : ℤ,  n ≠ m → ∀ b : α, n * b ≠ m * b,
  from by auto [h2],

  have h7 : ∀ b : α, is_irrational b → ∀ n m : ℤ,  n ≠ m → n * b ≠ m * b, from by auto [h6],

  have h8 : n * a ≠ m * a, from by auto [h7],

  have h9 : ∀ n m : ℤ, n ≠ m → n * a ∈ set.range (λ n : ℤ, n * a),
  from by {intros n m h10, use [n], rw ←one_mul (n * a)},

  have h10 : ∀ n m : ℤ, n ≠ m → n * a ∉ set.range (λ n : ℤ, n * a),
  from by auto [h9],

  have h11 : set.range (λ n : ℤ, n * a) ≠ univ,
  from by auto [h10, h8, univ_def_eq],

  have h12 : set.range (λ n : ℤ, n * a) ≠ univ,
  from by auto [h10, h8, univ_def_eq],

  have h13 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h14 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h15 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h16 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h17 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

(*
  have h10 : ∅ ≠ set.range (λ n : ℤ, n * a),
  from by auto [h3, classical.not_forall, classical.not_not_elim, classical.not_not_intro, set.exists_mem_of_ne_empty,
  set.not_exists_mem_of_not_nonempty, set.not_exists_mem_of_not_nonempty],
*)
  have h11 : ∀ x, ∃ n ∈ ℤ, x - 1 < n * a ∧ (n + 1) * a ≤ x,
  from by auto [s.dense, set.range_iff, exists_nat],

  show ∃ (n : ℤ), n ∈ ℤ ∧ x - 1 < n * a ∧ (n + 1) * a ≤ x,
  from by auto [h11],
end

--OUTPUT 10
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irration_orbit (α : ℝ) : ∀ (ε : ℝ), ε > 0 → ∃ i : ℤ, (∀ j : ℤ, |i*α - (j*α)%ℝ| < ε) :=
begin
  assume (ε : ℝ),
  assume (h1 : ε > 0),

  have h2 : ∀ (x : ℕ), (x*ε)≠0, from by auto [nat.pos_of_ne_zero],
  have h3 : ∀ (x y : ℤ), (x*ε)%ℝ ≠ (y*ε)%ℝ → x ≠ y, from by auto [@eq.subst int ℝ _ _ _ _ h2],

  let S : ℝ := {x | ∃ i : ℤ, x = (i*α)%ℝ},
  let SS := (λ (i : ℤ), (i*α)%ℝ),

  have h4 : S = ⋃ i : ℤ, {i}, from by auto [SS, eq_univ_of_forall],

  have h5 : ∀ i j : ℤ, i ≠ j → (i*α)%ℝ ≠ (j*α)%ℝ, from
  begin
    assume (i j : ℤ),
    assume (h5 : i ≠ j),
    assume (h6 : (i*α)%ℝ = (j*α)%ℝ),
    have h8 : ∃ N : ℕ, ∃ i : ℤ, α = N⁻¹ * (i : ℝ), from by auto [rational_iff],
    cases h8 with N h9,
    cases h9 with i h10,
    have h11 : ∃ j : ℤ, (i : ℝ) = N * (j : ℝ), from by auto [rat.denom_ne_zero, rat.exists_int_eq],
    cases h11 with j h12,
    have h13 : α = (j : ℝ), from by auto [h10, h12, eq_div_iff],
    have h14 : α ∈ ℚ, from by auto [h13],
    have h15 : α ∈ ℚ → false, from by auto [eq.subst h13],
    have h16 : false, from by auto [h15, h14],
    show false, from h16,
  end,

  have h6 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S) → i = j, from
  begin
    assume (i j : ℤ),
    assume (h6 : ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S)),
    have h7 : (i*α)%ℝ = (j*α)%ℝ → i = j, from h3 i j,
    show i = j, from by auto [h7, h6, h5],
  end,

  have h7 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) → ((j*α)%ℝ ∈ S) → i = j, from
  begin
    assume (i j : ℤ),
    assume (h7 : ((i*α)%ℝ ∈ S)),
    assume (h8 : ((j*α)%ℝ ∈ S)),
    have h9 : ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S), from by auto [h7, h8],
    show i = j, from by auto [h6, h9],
  end,

  have h8 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) ↔ i = j, from
  begin
    assume (i j : ℤ),
    split,
    {
      assume (h9 : ((i*α)%ℝ ∈ S)),
      show i = j, from by auto [h7, h9],
    },
    {
      assume (h10 : i = j),
      show (i*α)%ℝ ∈ S, from by auto [h10],
    },
  end,

  have h9 : S = ⋃ i : ℤ, {i}, from by auto [SS, eq_univ_of_forall],

  have h10 : ∀ i : ℤ, (i*α)%ℝ ∈ S, from by auto [rat.denom_ne_zero],

  have h11 : ∀ i : ℤ, ∃ x : ℝ, x ∈ {i} ∧ x ∈ S, from
  begin
    assume (i : ℤ),
    have h12 : (i*α)%ℝ ∈ S, from by auto [h10],
    have h13 : (i*α)%ℝ ∈ {i}, from by auto [h12],
    show ∃ x : ℝ, x ∈ {i} ∧ x ∈ S, from by auto [h13, h12],
  end,

  have h12 : ⋃ i : ℤ, {i} = ⋃ x : S, {x}, from by auto [h9, h8, h11, set.ext_iff],

  have h13 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from
  begin
    use 1,
    assume j,
    have h14 : (1*α)%ℝ = (j*α)%ℝ → 1 = j, from by auto [h3],
    have h15 : (1*α)%ℝ ∈ S, from by auto [rat.denom_ne_zero],
    have h16 : (1*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h15],
    show (1*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h16],
  end,

  have h14 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ S, from
  begin
    have h15 : ∃ i : ℤ, ∀ j : ℤ, (i*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h13],
    cases h15 with i h16,
    have h17 : ∀ j : ℤ, (i*α)%ℝ ∈ S, from by auto [h16],
    show ∃ (i : ℤ), ∀ j : ℤ, (i*α)%ℝ ∈ S, from by auto [h17],
  end,

  have h15 : ∃ (i : ℤ), (i*α)%ℝ ∈ S ∧ ∀ (j : ℤ), (j*α)%ℝ ∈ S → i = j, from
  begin
    have h16 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ S, from by auto [h14],
    cases h16 with i h17,
    have h18 : ∀ (j : ℤ), (i*α)%ℝ ∈ S ∧ (j*α)%ℝ ∈ S → i = j, from
    begin
      assume j,
      have h19 : (i*α)%ℝ ∈ S ∧ (j*α)%ℝ ∈ S → ((i*α)%ℝ = (j*α)%ℝ →
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
FEW SHOT PROMPTS TO CODEX(END)-/