import data.equiv.basic
import data.fintype
import data.equiv.encodable
import data.equiv.denumerable
-- import util.control.monad
-- import util.control.applicative
-- import util.meta.tactic

universes u

class generic (α : Type u) :=
  (rep : Type u)
  (to_rep : α → rep)
  (of_rep : rep → α)
  (correspondence : α ≃ rep)

export generic (rep correspondence)

attribute [reducible] generic.rep

meta def tactic.mk_sigma (v t : expr) : tactic expr :=
do t' ← tactic.infer_type v,
   tactic.to_expr ``(@sigma %%t' %%(expr.lambdas [v] t))

namespace tactic.interactive

open tactic

meta def mk_prod_rep' (α : expr) (c : name)
: list expr → expr → list expr → tactic (expr × expr × expr)
 | [] _ _ :=
   do c' ← mk_const c,
      let to_rep : expr := `(()),
      return (`(unit),to_rep,expr.lam `_ binder_info.default `(unit) c')
 | [x] e es := do c' ← mk_const c,
             t ← infer_type x,
             let of_rep := c'.mk_app (e :: es : list _).reverse,
             return (t,x,expr.lambdas [e] of_rep)
 | (x :: xs) e es :=
    do xs' ← mmap infer_type xs,
       if (xs'.any (x.occurs)) then do
         t₀ ← infer_type x,
         v ← mk_mvar,
         y ← mk_local_def `x v,
         (t₁,to_rep,of_rep) ← mk_prod_rep' xs y (x :: es) <|> fail "mk_prod_rep'",
         unify v (t₁),
         of_rep ← instantiate_mvars of_rep,
         t ← mk_sigma x t₁,
         to_rep ← to_expr ``(sigma.mk %%x %%to_rep),
         of_rep ← to_expr ``(@sigma.cases_on %%t₀ %%((expr.lambdas [x] t₁)) (λ x, %%α) %%e (%%(expr.lambdas [x] of_rep)) : %%α),
         return (t,to_rep,expr.lambdas [e] of_rep)
       else do
         t₀ ← infer_type x,
         v ← mk_mvar,
         y ← mk_local_def `x v,
         (t₁,to_rep,of_rep) ← mk_prod_rep' xs y (x :: es),
         unify v t₁,
         t ← to_expr ``(%%t₀ × %%t₁),
         to_rep ← to_expr ``((%%x, %%to_rep)),
         of_rep ← to_expr ``(@prod.cases_on %%t₀ %%t₁ (λ _, %%α) %%e (%%(expr.lambdas [x] of_rep)) : %%α),
         return (t,to_rep,expr.lambdas [e] of_rep)

meta def mk_inr (α β : expr) (p : pexpr) : pexpr :=
``(@sum.inr %%α %%β %%p)

meta def mk_inl (α β : expr) (p : pexpr) : pexpr :=
``(@sum.inl %%α %%β %%p)

meta def mk_prod_rep (α : expr) (c : name) (f : list (name × expr × expr)) : tactic (expr × expr × expr) :=
do t ← resolve_name c >>= to_expr >>= infer_type,
   (cmp,_) ← mk_local_pis t,
   x ← mk_mvar >>= mk_local_def `x,
   (t,to_rep,of_rep) ← mk_prod_rep' α c cmp x [],
   to_rep' ← mfoldl ((λ e ⟨c,α,β⟩,
       do c' ← mk_const c,
          return (expr.mk_app c' [α,β,e])) : _ → _ × _ × _ → tactic expr) to_rep f,
   to_rep ← instantiate_mvars (expr.lambdas cmp to_rep'),
   return (t,to_rep,of_rep)

/-- `mk_sum_rep cs` returns
  - the representation type for constructors cs
  - a list of functions `to_rep` for the cases `cs`
  - a function of_rep (for the constructed rep type) to α -/
meta def mk_sum_rep (α : expr) : list (name × expr × expr) → list name → tactic (expr × list expr × expr)
 | f [] :=
 do of_rep ← to_expr ``(empty.rec_on (λ _, %%α) : empty → %%α),
    return (`(empty),[],of_rep)
 | f [x] := prod.map id (prod.map singleton id) <$> mk_prod_rep α x f
 | f (x::xs) :=
 do α' ← mk_mvar,
    β' ← mk_mvar,
    y  ← mk_prod_rep α x ((`sum.inl, α', β') :: f),
    ys ← mk_sum_rep ((`sum.inr, α', β') :: f) xs,
    rep ← to_expr ``(%%y.1 ⊕ %%ys.1),
    of_rep ← to_expr ``((λ x, @sum.cases_on %%α' %%β' (λ _, %%α) x %%y.2.2 %%ys.2.2) : %%rep → %%α),
    return (rep,y.2.1 :: ys.2.1,of_rep)

meta def prove_inverse : name → tactic unit | n :=
(`[simp ; try { congr }] ; reflexivity) <|>
do c ← resolve_name n >>= to_expr,
   t ← infer_type c,
   match t with
    | `(_ × _) := tactic.cases c [`x,`y] >> prove_inverse `y
    | `(Σ _, _) := tactic.cases c [`x,`y] >> prove_inverse `y
    | `(_ ⊕ _) := (() <$ tactic.cases c [`x,`x]) ; solve1 (prove_inverse `x)
    | `(unit) :=  tactic.cases c >> reflexivity
    | _ := fail "cannot prove inverse"
   end

meta def mk_generic_instance : tactic unit :=
do `(generic %%t) ← target,
   e ← get_env,
   let n := t.const_name,
   let ns := n <.> "generic",
   set_env $ e.add_namespace ns,
   (rep,to_rep,of_rep) ← mk_sum_rep t [] (e.constructors_of t.const_name),
   cases_on ← resolve_name (t.const_name <.> "cases_on") >>= to_expr,
   x ← mk_local_def `x t,
   let to_rep' := expr.lambdas [x] $ cases_on.mk_app (x::to_rep),
   bij_t ← to_expr ``(equiv %%t %%rep),
   bij ← assert `bij bij_t,
   swap,
   d ← to_expr ``( { generic . rep := %%rep
                   , to_rep := %%to_rep'
                   , of_rep := %%of_rep
                   , correspondence := %%bij } : generic %%t ),
   instantiate_mvars d >>= tactic.apply,
   `[apply @equiv.mk %%t %%rep %%to_rep' %%of_rep],
   solve1 `[intro x, induction x ; refl ],
   solve1 (intro `x >> prove_inverse `x)

end tactic.interactive
-- ↪
def encoding {α : Type u} [generic α] : rep α ↪ α :=
equiv.to_embedding $ (correspondence _).symm

lemma multiset.map_equiv_to_embedding {α β} (f : α ≃ β) (s : multiset α) (x : β) :
  x ∈ s.map f ↔ f.symm x ∈ s :=
by { split; simp; introv h,
     { intro, subst x, simp * },
     { split, existsi h, simp } }

lemma finset.map_equiv_to_embedding {α β} (f : α ≃ β) (s : finset α) (x : β) :
  x ∈ s.map (equiv.to_embedding f) ↔ f.symm x ∈ s :=
by { split; simp; intros,
     { subst x, simp * },
     { split, existsi a, simp } }

instance finite_generic (α : Type u) [generic α] [fintype (rep α)] : fintype α :=
{ elems := (fintype.elems (rep α)).map encoding,
  complete :=
  by { intros, dsimp [encoding],
       simp [multiset.map_equiv_to_embedding],
       apply fintype.complete } }

instance inhabited_generic (α : Type u) [generic α] [inhabited (rep α)] : inhabited α :=
⟨ (correspondence α).symm (default _) ⟩

instance encodable_generic (α : Type u) [generic α] [encodable (rep α)] : encodable α :=
encodable.of_equiv _ (correspondence _)

instance denumerable_generic (α : Type u) [generic α] [denumerable (rep α)] : denumerable α :=
denumerable.of_equiv _ (correspondence _)

instance : generic bool :=
by { mk_generic_instance, }

namespace examples

inductive generic_ex1 : Type
 | case1 : generic_ex1
 | case2 : generic_ex1
 | case3 : ℕ → generic_ex1
 | case4 : bool → ℕ → generic_ex1

open generic_ex1

instance : generic generic_ex1 :=
by mk_generic_instance

inductive generic_ex2 : Type
 | case1 : generic_ex2
 | case2 : ℕ → ℕ → bool → generic_ex2
 | case3 (n : ℕ) : fin n → generic_ex2
 | case4 : bool → generic_ex2

instance generic_generic_ex2 : generic generic_ex2 :=
begin mk_generic_instance end

end examples


import order.filter.basic

import for_mathlib.data.set.basic

local infixr ` ×ᶠ `:51 := filter.prod

section
open filter set function

lemma filter.comap_pure {α : Type*} {β : Type*} {f : α → β} (h : injective f) (a : α) :
  pure a = comap f (pure $ f a) :=
by rw [← filter.map_pure, comap_map h]

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-
    f
  α → β
g ↓   ↓ h
  γ → δ
    i
-/
variables {f : α → β} {g : α → γ} {h : β → δ} {i : γ → δ} (H : h ∘ f = i ∘ g)
include H

lemma filter.map_comm (F : filter α) : map h (map f F) = map i (map g F) :=
by rw [filter.map_map, H, ← filter.map_map]

lemma filter.comap_comm (G : filter δ) : comap f (comap h G) = comap g (comap i G) :=
by rw [filter.comap_comap_comp, H, ← filter.comap_comap_comp]
omit H

open lattice
variables {G : filter β} {s : set α} {t : set β} {φ : α → β}

lemma mem_comap_sets_of_inj (h : ∀ a a', φ a = φ a' → a = a') :
  s ∈ comap φ G ↔ ∃ t ∈ G, s = φ ⁻¹' t :=
begin
  rw mem_comap_sets,
  split ; rintros ⟨t, ht, hts⟩,
  { use t ∪ φ '' s,
    split,
    { simp [mem_sets_of_superset ht] },
    { rw [preimage_union, preimage_image_eq _ h],
      exact (union_eq_self_of_subset_left hts).symm } },
  { use [t, ht],
    rwa hts }
end

lemma filter.inf_eq_bot_iff {α : Type*} (f g : filter α) : f ⊓ g = ⊥ ↔ ∃ (U ∈ f) (V ∈ g), U ∩ V = ∅ :=
by { rw [← empty_in_sets_eq_bot, mem_inf_sets], simp [subset_empty_iff] }

lemma filter.ne_bot_of_map {α : Type*} {β : Type*} {f : α → β} {F : filter α} (h : map f F ≠ ⊥) : F ≠ ⊥ :=
λ H, (H ▸ h : map f ⊥ ≠ ⊥) map_bot

lemma filter.map_prod_prod {α₁ : Type*} {α₂ : Type*} {β₁ : Type*} {β₂ : Type*}
  (f : α₁ → α₂) (g : β₁ → β₂) (F : filter α₁) (G : filter β₁) :
  map (f ⨯ g) (F ×ᶠ G) = (map f F) ×ᶠ (map g G) :=
by { rw filter.prod_map_map_eq, refl }

lemma filter.map_prod_mk {α : Type*} {β : Type*} {γ : Type*} (f : γ → α) (g : γ → β) (F : filter γ) :
  map (λ x, prod.mk (f x) $ g x) F ≤ (map f F).prod (map g F) :=
begin
  intros U U_in,
  rcases mem_prod_iff.1 U_in with ⟨s, s_in, t, t_in, stU⟩,
  rw mem_map at *,
  have st_in := filter.inter_sets F s_in t_in,
  apply mem_sets_of_superset st_in,
  rintro x ⟨xs, xt⟩,
  apply stU,
  exact ⟨xs, xt⟩
end
end

class filter_basis (α : Type*) :=
(sets : set $ set α)
(ne_empty : sets.nonempty) -- avoid the degenerate case of an empty filter basis
(directed : ∀ {s t}, s ∈ sets → t ∈ sets → ∃ u ∈ sets, u ⊆ s ∩ t)

namespace filter_basis
open filter set function

variables {α : Type*} {ι : Type*} (B : filter_basis α)

--instance : has_coe (filter_basis α) (set $ set α) := ⟨filter_basis.sets α⟩
instance : has_mem (set α) (filter_basis α) := ⟨λ s B, s ∈ B.sets⟩

lemma mem_iff {B : filter_basis α} {s : set α} : s ∈ B ↔ s ∈ B.sets := iff.rfl

def default (B : filter_basis α) : set α :=
B.ne_empty.some

def default_in (B : filter_basis α) : B.default ∈ B :=
B.ne_empty.some_mem

def filter : filter α := generate B.sets

lemma mem_filter {U : set α} : U ∈ B.filter ↔ ∃ V ∈ B, V ⊆ U :=
begin
  split ; intro h,
  { induction h with U U_in U V U_gen UV U_union U V U_gen V_gen U_union V_union,
    { exact ⟨U, U_in, le_refl U⟩ },
    { exact ⟨B.default, B.default_in, subset_univ _⟩ },
    { rcases U_union with ⟨W, W_in, WU⟩,
      refine ⟨W, W_in, subset.trans WU UV⟩ },
    { rcases U_union with ⟨S, S_in, SU⟩,
      rcases V_union with ⟨T, T_in, TU⟩,
      rcases filter_basis.directed S_in T_in with ⟨W, W_in, hW⟩,
      cases subset_inter_iff.1 hW with WS WT,
      exact ⟨W, W_in, subset_inter_iff.2 ⟨subset.trans WS SU, subset.trans WT TU⟩⟩ } },
  { rcases h with ⟨V, V_in, VU⟩,
    exact generate_sets.superset (generate_sets.basic $ V_in) VU },
end

lemma mem_filter_of_mem {B : filter_basis α} {U : set α} (h : U ∈ B) : U ∈ B.filter :=
generate_sets.basic h

lemma le_filter (F : _root_.filter α) : F ≤ B.filter ↔ ∀ U ∈ B, U ∈ F :=
begin
  split ; intros h U U_in,
  { exact h (mem_filter_of_mem U_in) },
  { rcases B.mem_filter.1 U_in with ⟨V, V_in, VU⟩,
    filter_upwards [h V V_in],
    exact VU },
end

lemma filter_le (F : _root_.filter α) : B.filter ≤ F ↔ ∀ {V}, V ∈ F → ∃ U ∈ B, U ⊆ V :=
begin
  simp only [B.mem_filter],
  split ; intros h V V_in,
  { exact B.mem_filter.1 (h V_in) },
  { exact B.mem_filter.2 (h V_in) },
end

def map {β : Type*} (f : α → β) (B : filter_basis α) : filter_basis β :=
{ sets := (image f) '' B.sets,
  ne_empty := image_nonempty _ _ B.ne_empty,
  directed := begin
    rintros _ _ ⟨U, U_in, rfl⟩ ⟨V, V_in, rfl⟩,
    rcases filter_basis.directed U_in V_in with ⟨W, W_in, UVW⟩,
    use [f '' W, mem_image_of_mem _ W_in],
    exact subset.trans (image_subset f UVW) (image_inter_subset f U V)
  end }

lemma mem_map {β : Type*} (f : α → β) (B : filter_basis α) {V : set β} :
  V ∈ map f B ↔ ∃ U ∈ B, f '' U = V :=
begin
  change V ∈ image f '' B.sets ↔ ∃ (U : set α) (H : U ∈ B), f '' U = V,
  simp [mem_image],
  exact iff.rfl,
end

def map_filter {β : Type*} (f : α → β) (B : filter_basis α) :
  filter.map f B.filter = (map f B).filter :=
begin
  ext V,
  simp [filter.mem_map, mem_filter, mem_filter, mem_map],
  split,
  { rintros ⟨U, UB, H⟩,
    use [f '' U, U, UB],
    exact image_subset_iff.2 H },
  { rintros ⟨W, ⟨U, UB, rfl⟩, H⟩,
    use [U, UB],
    exact image_subset_iff.1 H },
end

lemma tendsto_from {β : Type*} (f : α → β) (F : _root_.filter β) :
  tendsto f B.filter F ↔ ∀ {V}, V ∈ F → ∃ U ∈ B, U ⊆ f ⁻¹' V :=
begin
  apply forall_congr,
  intros V,
  apply imp_congr iff.rfl,
  rw [filter.mem_map, mem_filter],
  exact iff.rfl
end

lemma tendsto_into {β : Type*} (f : β → α) (F : _root_.filter β) :
  tendsto f F B.filter ↔ ∀ {V}, V ∈ B → f ⁻¹' V ∈ F :=
begin
  split ; intros h U U_in,
  { exact h (mem_filter_of_mem U_in) },
  { rcases B.mem_filter.1 U_in with ⟨V, V_in, H⟩,
    filter_upwards [h V_in],
    exact preimage_mono H },
end

lemma tendsto_both {β : Type*} (f : α → β) (B' : filter_basis β) :
  tendsto f B.filter B'.filter ↔ ∀ {V}, V ∈ B' → ∃ U ∈ B, U ⊆ f ⁻¹' V :=
begin
  rw tendsto_into,
  apply forall_congr,
  intros V,
  exact imp_congr iff.rfl (mem_filter _)
end

universes u v

protected def prod {α : Type u} {β : Type v} (B : filter_basis α) (B' : filter_basis β) :
  filter_basis (α × β) :=
{ sets :=  (uncurry' set.prod) '' (B.sets.prod B'.sets),
  ne_empty := image_nonempty _ _ (set.prod_nonempty_iff.2 ⟨B.ne_empty, B'.ne_empty⟩),
  directed := begin
    rintros _ _ ⟨⟨P, P'⟩, ⟨P_in, P_in'⟩, rfl⟩ ⟨⟨Q, Q'⟩, ⟨Q_in, Q_in'⟩, rfl⟩,
    rcases filter_basis.directed P_in Q_in with ⟨U, U_in, hU⟩,
    rcases filter_basis.directed P_in' Q_in' with ⟨U', U_in', hU'⟩,
    use set.prod U U',
    simp only [uncurry', exists_prop],
    use [(U, U'), ⟨U_in, U_in'⟩],
    rintros ⟨x, y⟩ ⟨x_in, y_in⟩,
    cases hU x_in,
    cases hU' y_in,
    finish
  end }

lemma mem_prod_of_mem {α : Type u} {β : Type v} {B : filter_basis α} {B' : filter_basis β}
  {S} (hS : S ∈ B) {T} (hT : T ∈ B') : set.prod S T ∈ B.prod B' :=
⟨(S, T), mem_prod.2 ⟨hS, hT⟩, rfl⟩

lemma mem_prod_filter_of_mem {α : Type u} {β : Type v} {B : filter_basis α} {B' : filter_basis β}
  {S} (hS : S ∈ B) {T} (hT : T ∈ B') : set.prod S T ∈ (B.prod B').filter :=
mem_filter_of_mem (mem_prod_of_mem hS hT)

lemma mem_prod_filter {α : Type u} {β : Type v} (B : filter_basis α) (B' : filter_basis β)
  {U : set (α × β)} : U ∈ (B.prod B').filter ↔ ∃ S ∈ B, ∃ T ∈ B', set.prod S T ⊆ U :=
begin
  rw mem_filter,
  split,
  { rintros ⟨_, ⟨⟨S, T⟩, h, rfl⟩, H⟩,
    exact ⟨S, h.1, T, h.2, H⟩ },
  { rintros ⟨S, S_in, T, T_in, H⟩,
    exact ⟨set.prod S T, mem_prod_of_mem S_in T_in, H⟩ }
end

lemma prod_filter {α : Type u} {β : Type v} (B : filter_basis α) (B' : filter_basis β) :
(B.prod B').filter = B.filter ×ᶠ B'.filter :=
begin
  ext U,
  rw [mem_prod_filter, filter.mem_prod_iff],
  split ; rintros ⟨S, ⟨Sin, T, Tin, H⟩⟩,
  { exact ⟨S, mem_filter_of_mem Sin, T, mem_filter_of_mem Tin, H⟩ },
  { rcases B.mem_filter.1 Sin with ⟨V, Vin, VS⟩,
    rcases B'.mem_filter.1 Tin with ⟨W, Win, WT⟩,
    use [V, Vin, W, Win],
    exact subset.trans (set.prod_mono VS WT) H }
end
end filter_basis


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.types
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.terminal
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Special shapes for limits in `Type`.

The general shape (co)limits defined in `category_theory.limits.types`
are intended for use through the limits API,
and the actual implementation should mostly be considered "sealed".

In this file, we provide definitions of the "standard" special shapes of limits in `Type`,
giving the expected definitional implementation:
* the terminal object is `punit`
* the binary product of `X` and `Y` is `X × Y`
* the product of a family `f : J → Type` is `Π j, f j`.

Because these are not intended for use with the `has_limit` API,
we instead construct terms of `limit_data`.

As an example, when setting up the monoidal category structure on `Type`
we use the `types_has_terminal` and `types_has_binary_products` instances.
-/

namespace category_theory.limits.types

/-- A restatement of `types.lift_π_apply` that uses `pi.π` and `pi.lift`. -/
@[simp] theorem pi_lift_π_apply {β : Type u} (f : β → Type u) {P : Type u} (s : (b : β) → P ⟶ f b) (b : β) (x : P) : pi.π f b (pi.lift s x) = s b x :=
  congr_fun (limit.lift_π (fan.mk P s) b) x

/-- A restatement of `types.map_π_apply` that uses `pi.π` and `pi.map`. -/
@[simp] theorem pi_map_π_apply {β : Type u} {f : β → Type u} {g : β → Type u} (α : (j : β) → f j ⟶ g j) (b : β) (x : ∏ fun (j : β) => f j) : pi.π g b (pi.map α x) = α b (pi.π f b x) :=
  limit.map_π_apply (discrete.nat_trans α) b x

/-- The category of types has `punit` as a terminal object. -/
def terminal_limit_cone : limit_cone (functor.empty (Type u)) :=
  limit_cone.mk (cone.mk PUnit (nat_trans.mk sorry)) (id (is_limit.mk sorry))

/-- The category of types has `pempty` as an initial object. -/
def initial_limit_cone : colimit_cocone (functor.empty (Type u)) :=
  colimit_cocone.mk (cocone.mk pempty (nat_trans.mk sorry)) (id (is_colimit.mk sorry))

/-- The product type `X × Y` forms a cone for the binary product of `X` and `Y`. -/
-- We manually generate the other projection lemmas since the simp-normal form for the legs is

-- otherwise not created correctly.

@[simp] theorem binary_product_cone_X (X : Type u) (Y : Type u) : cone.X (binary_product_cone X Y) = (X × Y) :=
  Eq.refl (X × Y)

@[simp] theorem binary_product_cone_fst (X : Type u) (Y : Type u) : binary_fan.fst (binary_product_cone X Y) = prod.fst :=
  rfl

@[simp] theorem binary_product_cone_snd (X : Type u) (Y : Type u) : binary_fan.snd (binary_product_cone X Y) = prod.snd :=
  rfl

/-- The product type `X × Y` is a binary product for `X` and `Y`. -/
@[simp] theorem binary_product_limit_lift (X : Type u) (Y : Type u) (s : binary_fan X Y) (x : cone.X s) : is_limit.lift (binary_product_limit X Y) s x = (binary_fan.fst s x, binary_fan.snd s x) :=
  Eq.refl (is_limit.lift (binary_product_limit X Y) s x)

/--
The category of types has `X × Y`, the usual cartesian product,
as the binary product of `X` and `Y`.
-/
@[simp] theorem binary_product_limit_cone_is_limit (X : Type u) (Y : Type u) : limit_cone.is_limit (binary_product_limit_cone X Y) = binary_product_limit X Y :=
  Eq.refl (limit_cone.is_limit (binary_product_limit_cone X Y))

/-- The functor which sends `X, Y` to the product type `X × Y`. -/
-- We add the option `type_md` to tell `@[simps]` to not treat homomorphisms `X ⟶ Y` in `Type*` as

-- a function type

@[simp] theorem binary_product_functor_obj_map (X : Type u) (Y₁ : Type u) (Y₂ : Type u) (f : Y₁ ⟶ Y₂) : functor.map (functor.obj binary_product_functor X) f =
  is_limit.lift (binary_product_limit X Y₂) (binary_fan.mk prod.fst (prod.snd ≫ f)) :=
  Eq.refl (functor.map (functor.obj binary_product_functor X) f)

/--
The product functor given by the instance `has_binary_products (Type u)` is isomorphic to the
explicit binary product functor given by the product type.
-/
def binary_product_iso_prod : binary_product_functor ≅ prod.functor :=
  nat_iso.of_components
    (fun (X : Type u) =>
      nat_iso.of_components
        (fun (Y : Type u) =>
          iso.symm (is_limit.cone_point_unique_up_to_iso (limit.is_limit (pair X Y)) (binary_product_limit X Y)))
        sorry)
    sorry

/-- The sum type `X ⊕ Y` forms a cocone for the binary coproduct of `X` and `Y`. -/
@[simp] theorem binary_coproduct_cocone_ι_app (X : Type u) (Y : Type u) (j : discrete walking_pair) : ∀ (ᾰ : functor.obj (pair X Y) j),
  nat_trans.app (cocone.ι (binary_coproduct_cocone X Y)) j ᾰ = walking_pair.rec sum.inl sum.inr j ᾰ :=
  fun (ᾰ : functor.obj (pair X Y) j) => Eq.refl (walking_pair.rec sum.inl sum.inr j ᾰ)

/-- The sum type `X ⊕ Y` is a binary coproduct for `X` and `Y`. -/
def binary_coproduct_colimit (X : Type u) (Y : Type u) : is_colimit (binary_coproduct_cocone X Y) :=
  is_colimit.mk fun (s : binary_cofan X Y) => sum.elim (binary_cofan.inl s) (binary_cofan.inr s)

/--
The category of types has `X ⊕ Y`,
as the binary coproduct of `X` and `Y`.
-/
def binary_coproduct_colimit_cocone (X : Type u) (Y : Type u) : colimit_cocone (pair X Y) :=
  colimit_cocone.mk (binary_coproduct_cocone X Y) (binary_coproduct_colimit X Y)

/--
The category of types has `Π j, f j` as the product of a type family `f : J → Type`.
-/
def product_limit_cone {J : Type u} (F : J → Type u) : limit_cone (discrete.functor F) :=
  limit_cone.mk
    (cone.mk ((j : J) → F j)
      (nat_trans.mk
        fun (j : discrete J) (f : functor.obj (functor.obj (functor.const (discrete J)) ((j : J) → F j)) j) => f j))
    (is_limit.mk fun (s : cone (discrete.functor F)) (x : cone.X s) (j : J) => nat_trans.app (cone.π s) j x)

/--
The category of types has `Σ j, f j` as the coproduct of a type family `f : J → Type`.
-/
def coproduct_colimit_cocone {J : Type u} (F : J → Type u) : colimit_cocone (discrete.functor F) :=
  colimit_cocone.mk
    (cocone.mk (sigma fun (j : J) => F j)
      (nat_trans.mk fun (j : discrete J) (x : functor.obj (discrete.functor F) j) => sigma.mk j x))
    (is_colimit.mk
      fun (s : cocone (discrete.functor F))
        (x :
        cocone.X
          (cocone.mk (sigma fun (j : J) => F j)
            (nat_trans.mk fun (j : discrete J) (x : functor.obj (discrete.functor F) j) => sigma.mk j x))) =>
        nat_trans.app (cocone.ι s) (sigma.fst x) (sigma.snd x))

/--
Show the given fork in `Type u` is an equalizer given that any element in the "difference kernel"
comes from `X`.
The converse of `unique_of_type_equalizer`.
-/
def type_equalizer_of_unique {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z} {h : Y ⟶ Z} (w : f ≫ g = f ≫ h) (t : ∀ (y : Y), g y = h y → exists_unique fun (x : X) => f x = y) : is_limit (fork.of_ι f w) :=
  fork.is_limit.mk' (fork.of_ι f w)
    fun (s : fork g h) =>
      { val :=
          fun
            (i : functor.obj (functor.obj (functor.const walking_parallel_pair) (cone.X s)) walking_parallel_pair.zero) =>
            classical.some sorry,
        property := sorry }

/-- The converse of `type_equalizer_of_unique`. -/
theorem unique_of_type_equalizer {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z} {h : Y ⟶ Z} (w : f ≫ g = f ≫ h) (t : is_limit (fork.of_ι f w)) (y : Y) (hy : g y = h y) : exists_unique fun (x : X) => f x = y := sorry

theorem type_equalizer_iff_unique {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z} {h : Y ⟶ Z} (w : f ≫ g = f ≫ h) : Nonempty (is_limit (fork.of_ι f w)) ↔ ∀ (y : Y), g y = h y → exists_unique fun (x : X) => f x = y := sorry

/-- Show that the subtype `{x : Y // g x = h x}` is an equalizer for the pair `(g,h)`. -/
def equalizer_limit {Y : Type u} {Z : Type u} {g : Y ⟶ Z} {h : Y ⟶ Z} : limit_cone (parallel_pair g h) :=
  limit_cone.mk (fork.of_ι subtype.val sorry)
    (fork.is_limit.mk' (fork.of_ι subtype.val sorry)
      fun (s : fork g h) =>
        { val :=
            fun
              (i :
              functor.obj (functor.obj (functor.const walking_parallel_pair) (cone.X s)) walking_parallel_pair.zero) =>
              { val := fork.ι s i, property := sorry },
          property := sorry })


import for_mathlib.exact_seq3
import for_mathlib.bicartesian2
.

open category_theory category_theory.limits

universe u
local notation `𝓐` := Ab.{u}

-- Consider the following diagram
variables {     Kv₁   Kv₂        : 𝓐}
variables {Kh₁  A₁₁   A₁₂  Qh₁   : 𝓐}
variables {Kh₂  A₂₁   A₂₂  Qh₂   : 𝓐}
variables {     Qv₁   Qv₂        : 𝓐}
-- with morphisms
variables                         (fKv : Kv₁ ⟶ Kv₂)
variables                 {ιv₁ : Kv₁ ⟶ A₁₁} {ιv₂ : Kv₂ ⟶ A₁₂}
variables         {ιh₁ : Kh₁ ⟶ A₁₁} {f₁ : A₁₁ ⟶ A₁₂} {πh₁ : A₁₂ ⟶ Qh₁}
variables (gKh : Kh₁ ⟶ Kh₂) {g₁ : A₁₁ ⟶ A₂₁} {g₂ : A₁₂ ⟶ A₂₂} (gQh : Qh₁ ⟶ Qh₂)
variables         {ιh₂ : Kh₂ ⟶ A₂₁} {f₂ : A₂₁ ⟶ A₂₂} {πh₂ : A₂₂ ⟶ Qh₂}
variables                 {πv₁ : A₂₁ ⟶ Qv₁}  {πv₂ : A₂₂ ⟶ Qv₂}
variables                         (fQv : Qv₁ ⟶ Qv₂)
-- with exact rows and columns
variables (H₁ : exact_seq 𝓐 [ιh₁, f₁, πh₁])
variables (H₂ : exact_seq 𝓐 [ιh₂, f₂, πh₂])
variables (V₁ : exact_seq 𝓐 [ιv₁, g₁, πv₁])
variables (V₂ : exact_seq 𝓐 [ιv₂, g₂, πv₂])
-- and such that all the extremal maps are appropriately monos or epis
variables [mono ιv₁] [mono ιv₂] [mono ιh₁] [mono ιh₂]
variables [epi πv₁] [epi πv₂] [epi πh₁] [epi πh₂]
-- of course the diagram should commute
variables (sqᵤ : commsq fKv ιv₁ ιv₂ f₁)
variables (sqₗ : commsq ιh₁ gKh g₁ ιh₂) (sqm : commsq f₁ g₁ g₂ f₂)
variables (sqᵣ : commsq πh₁ g₂ gQh πh₂)
variables (sqₛ : commsq f₂ πv₁ πv₂ fQv)

open_locale zero_object
open category_theory.abelian

def is_limit_of_is_limit_comp {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z}
  {c : kernel_fork (f ≫ g)} (hc : is_limit c) (h : c.ι ≫ f = 0) :
  is_limit (kernel_fork.of_ι c.ι h) :=
kernel_fork.is_limit.of_ι _ _
  (λ T l hl, hc.lift (kernel_fork.of_ι l (by rw [reassoc_of hl, zero_comp])))
  (λ T l hl, hc.fac _ _)
  (λ T l hl m hm, fork.is_limit.hom_ext hc (by { erw [hm, hc.fac], refl }))

def is_colimit_of_is_colimit_comp {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z}
  {c : cokernel_cofork (f ≫ g)} (hc : is_colimit c) (h : g ≫ c.π = 0) :
  is_colimit (cokernel_cofork.of_π c.π h) :=
cokernel_cofork.is_colimit.of_π _ _
  (λ T l hl, hc.desc (cokernel_cofork.of_π l (by rw [category.assoc, hl, comp_zero])))
  (λ T l hl, hc.fac _ _)
  (λ T l hl m hm, cofork.is_colimit.hom_ext hc (by { erw [hm, hc.fac], refl }))

section
include sqₗ sqm

lemma is_iso_of_is_limit (H₁ : exact ιh₁ f₁) (H₂ : exact ιh₂ f₂)
  (h : is_limit (pullback_cone.mk f₁ g₁ sqm.w)) : is_iso gKh :=
begin
  haveI : mono gKh,
  { refine preadditive.mono_of_cancel_zero _ (λ P g hg, _),
    apply zero_of_comp_mono ιh₁,
    apply pullback_cone.is_limit.hom_ext h,
    { rw [pullback_cone.mk_fst, category.assoc, zero_comp, H₁.w, comp_zero] },
    { rw [pullback_cone.mk_snd, category.assoc, sqₗ.w, ← category.assoc, hg, zero_comp,
        zero_comp] } },
  obtain ⟨l, hl₁, hl₂ : l ≫ g₁ = _⟩ :=
    pullback_cone.is_limit.lift' h 0 ιh₂ (by simp [H₂.w]),
  let ker := is_limit_of_exact_of_mono _ _ H₁,
  obtain ⟨inv, hinv : inv ≫ ιh₁ = l⟩ := kernel_fork.is_limit.lift' ker l hl₁,
  have hinv' : inv ≫ gKh = 𝟙 _,
   { rw [← cancel_mono ιh₂, category.assoc, ← sqₗ.w, reassoc_of hinv, hl₂, category.id_comp] },
  refine ⟨⟨inv, _, hinv'⟩⟩,
  rw [← cancel_mono gKh, category.assoc, hinv', category.comp_id, category.id_comp]
end

end

section
include sqm sqᵣ

lemma is_iso_of_is_colimit (H₁ : exact f₁ πh₁) (H₂ : exact f₂ πh₂)
  (h : is_colimit (pushout_cocone.mk _ _ sqm.w)) : is_iso gQh :=
begin
  haveI : epi gQh,
  { refine preadditive.epi_of_cancel_zero _ (λ P g hg, _),
    apply zero_of_epi_comp πh₂,
    apply pushout_cocone.is_colimit.hom_ext h,
    { rw [pushout_cocone.mk_inl, ← category.assoc, ← sqᵣ.w, category.assoc, hg, comp_zero,
        comp_zero] },
    { rw [pushout_cocone.mk_inr, ← category.assoc, H₂.w, comp_zero, zero_comp] } },
  obtain ⟨l, hl₁ : g₂ ≫ l = _, hl₂⟩ :=
    pushout_cocone.is_colimit.desc' h πh₁ 0 (by simp [H₁.w]),
  let coker := is_colimit_of_exact_of_epi _ _ H₂,
  obtain ⟨inv, hinv : πh₂ ≫ inv = l⟩ := cokernel_cofork.is_colimit.desc' coker l hl₂,
  have hinv' : gQh ≫ inv = 𝟙 _,
  { rw [← cancel_epi πh₁, ← category.assoc, sqᵣ.w, category.assoc, hinv, hl₁, category.comp_id] },
  refine ⟨⟨inv, hinv', _⟩⟩,
  rw [← cancel_epi gQh, reassoc_of hinv', category.comp_id]
end

end

include H₁ H₂ sqₗ sqm sqᵣ

lemma commsq.bicartesian_iff_isos : sqm.bicartesian ↔ (is_iso gKh ∧ is_iso gQh) :=
begin
  split,
  { intro h, split,
    { exact is_iso_of_is_limit gKh sqₗ sqm ((exact_iff_exact_seq _ _).2 (H₁.extract 0 2))
      ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) h.is_limit },
    { exact is_iso_of_is_colimit gQh sqm sqᵣ ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2))
      ((exact_iff_exact_seq _ _).2 (H₂.extract 1 2)) h.is_colimit } },
  { rintros ⟨gKh_iso, gQh_iso⟩,
    resetI,
    apply commsq.bicartesian.of_is_limit_of_is_colimt,
    { apply is_limit.of_point_iso (limit.is_limit _),
      { apply_instance },
      { let r := pullback.lift _ _ sqm.w,
        let x : Kh₁ ⟶ kernel (pullback.fst : pullback g₂ f₂ ⟶ A₁₂),
        { refine kernel.lift _ (ιh₁ ≫ r) _,
          simp only [(H₁.extract 0 2).w, category.assoc, pullback.lift_fst] },
        haveI : is_iso x,
        { let psq := commsq.of_eq (@pullback.condition _ _ _ _ _ g₂ f₂ _),
          let hker := abelian.is_limit_of_exact_of_mono _ _
            ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)),
          obtain ⟨u : _ ⟶ Kh₂, hu⟩ := kernel_fork.is_limit.lift' hker
            (kernel.ι (pullback.fst : pullback g₂ f₂ ⟶ A₁₂) ≫ pullback.snd) _,
          { rw fork.ι_of_ι at hu,
            let lsq := commsq.of_eq hu.symm,
            haveI : is_iso u := is_iso_of_is_limit u lsq psq _ _ _,
            { have hxu : x ≫ u = gKh,
              { simp only [← cancel_mono ιh₂, category.assoc, hu, x, kernel.lift_ι_assoc, r,
                pullback.lift_snd, sqₗ.w] },
              have hx : x = gKh ≫ inv u,
              { rw [← is_iso.comp_inv_eq, is_iso.inv_inv, hxu] },
              rw hx,
              apply_instance },
            { exact exact_kernel_ι },
            { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) },
            { exact pullback_is_pullback _ _ } },
          { rw [category.assoc, ← pullback.condition, kernel.condition_assoc, zero_comp] } },
        refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso _ _ _ 0 _ _ _ 0 _ _ _
         0 ιh₁ f₁ 0 (kernel.ι (pullback.fst : pullback g₂ f₂ ⟶ A₁₂)) pullback.fst 0 x r (𝟙 _)
         _ _ _ _ _ πh₁ πh₁ (𝟙 _) _ _ _ _ _ _ _ _ _ _ _,
        { simp only [eq_iff_true_of_subsingleton] },
        { simp only [kernel.lift_ι] },
        { simp only [pullback.lift_fst, category.comp_id] },
        { simp only [category.id_comp, category.comp_id] },
        { exact exact_zero_mono ιh₁ },
        { exact (exact_iff_exact_seq _ _).2 (H₁.extract 0 2) },
        { exact (exact_iff_exact_seq _ _).2 (H₁.extract 1 2) },
        { exact exact_zero_mono (kernel.ι pullback.fst) },
        { exact exact_kernel_ι },
        { have : (pullback.fst : pullback g₂ f₂ ⟶ A₁₂) ≫ πh₁ = 0,
          { apply zero_of_comp_mono gQh,
            rw [category.assoc, sqᵣ.w, pullback.condition_assoc, (H₂.extract 1 2).w, comp_zero] },
          apply abelian.exact_of_is_cokernel _ _ this,
          have hex := (exact_iff_exact_seq _ _).2 (H₁.extract 1 2),
          rw ← pullback.lift_fst _ _ sqm.w at hex,
          exact is_colimit_of_is_colimit_comp (abelian.is_colimit_of_exact_of_epi _ _ hex) _ } } },
    { apply is_colimit.of_point_iso (colimit.is_colimit _),
      { apply_instance },
      { let r := pushout.desc _ _ sqm.w,
        let x : cokernel (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) ⟶ Qh₂,
        { refine cokernel.desc _ (r ≫ πh₂) _,
          simp only [(H₂.extract 1 2).w, ← category.assoc, pushout.inr_desc] },
        haveI : is_iso x,
        { let psq := commsq.of_eq (@pushout.condition _ _ _ _ _ f₁ g₁ _),
          let hcoker := abelian.is_colimit_of_exact_of_epi _ _
            ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2)),
          obtain ⟨u : Qh₁ ⟶ _, hu⟩ := cokernel_cofork.is_colimit.desc' hcoker
            (pushout.inl ≫ (cokernel.π (pushout.inr : A₂₁ ⟶ pushout f₁ g₁))) _,
          { rw cofork.π_of_π at hu,
            let lsq := commsq.of_eq hu,
            haveI : is_iso u := is_iso_of_is_colimit u psq lsq _ _ _,
            { have hxu : u ≫ x = gQh,
              { simp only [← cancel_epi πh₁, hu, x, cokernel.π_desc, reassoc_of hu, r,
                  pushout.inl_desc_assoc, sqᵣ.w] },
              have hx : x = inv u ≫ gQh,
              { rw [← is_iso.inv_comp_eq, is_iso.inv_inv, hxu] },
              rw hx,
              apply_instance },
            { exact ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2)) },
            { exact exact_cokernel pushout.inr },
            { exact pushout_is_pushout _ _ } },
          { rw [← category.assoc, pushout.condition, category.assoc, cokernel.condition,
              comp_zero] } },
        refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso _ _ _ _ _ _ _ _ _ _ _
          ιh₂ (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) (cokernel.π (pushout.inr : A₂₁ ⟶ pushout f₁ g₁))
          ιh₂ f₂ πh₂ (𝟙 _) (𝟙 _) r x _ _ _ 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _,
        { simp only [category.id_comp, category.comp_id] },
        { simp only [category.id_comp, pushout.inr_desc] },
        { simp only [cokernel.π_desc] },
        { simp only [eq_iff_true_of_subsingleton] },
        { have : ιh₂ ≫ (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) = 0,
          { apply zero_of_epi_comp gKh,
            rw [← sqₗ.w_assoc, ← pushout.condition, reassoc_of (H₁.extract 0 2).w, zero_comp] },
          apply abelian.exact_of_is_kernel _ _ this,
          have hex := (exact_iff_exact_seq _ _).2 (H₂.extract 0 2),
          rw ← pushout.inr_desc _ _ sqm.w at hex,
          exact is_limit_of_is_limit_comp (abelian.is_limit_of_exact_of_mono _ _ hex) _ },
        { exact exact_cokernel pushout.inr },
        { exact exact_epi_zero (cokernel.π pushout.inr) },
        { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) },
        { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 1 2)) },
        { exact exact_epi_zero πh₂ } } } }
end


import tactic
import ring_theory.ideal.quotient
import ring_theory.power_series.basic
import ring_theory.polynomial.basic

noncomputable theory
open_locale classical
open_locale big_operators

variables (σ τ ω R : Type*) [comm_ring R]

namespace mv_power_series

#check finsupp.map_domain

variables {σ τ}

--set_option trace.simplify.rewrite true

@[simp]
lemma incl_monomial_aux (ι : σ ↪ τ) (m : σ →₀ ℕ) (t : σ) :
  m.map_domain ι (ι t) = m t :=
begin
  dsimp [finsupp.map_domain],
  rw finsupp.sum_apply,
  have : m.sum (λ a n, ite (a = t) n 0) = m t,
  { simp only [finsupp.sum_ite_self_eq'] },
  convert this,
  ext a b,
  rw finsupp.single_apply,
  rw (ι.injective.eq_iff : ι a = ι t ↔ a = t)
end

def incl_monomial (ι : σ ↪ τ) : (σ →₀ ℕ) ↪ (τ →₀ ℕ) :=
{ to_fun := λ m, finsupp.map_domain ι m,
  inj' := begin
    intros m1 m2 h,
    dsimp at h,
    ext t,
    apply_fun (λ e, e (ι t)) at h,
    simpa only [incl_monomial_aux] using h,
  end }

lemma incl_mon_add (ι : σ ↪ τ) (m : σ →₀ ℕ) (n : σ →₀ ℕ) :
  incl_monomial ι (m + n) = incl_monomial ι m + incl_monomial ι n :=
  begin
    dsimp [incl_monomial],
    exact finsupp.map_domain_add,
  end

--R is being recognized as a variable here?
--Or variables {σ τ} changes them to be implicit instead of explicit variables, but R is not changed?
--That would not explain ω
def incl_fun (ι : σ ↪ τ) : mv_power_series σ R → mv_power_series τ R :=
λ f m, if h : ∃ m' : σ →₀ ℕ, incl_monomial ι m' = m then f h.some else 0

lemma incl_fun_spec (ι : σ ↪ τ) (m : σ →₀ ℕ) (n : τ →₀ ℕ) (hm : incl_monomial ι m = n) (f) :
  coeff R n (incl_fun R ι f) = coeff R m f :=
begin
  dsimp [incl_fun, coeff],
  split_ifs,
  { congr' 1,
    apply (incl_monomial ι).injective,
    rw [h.some_spec, hm] },
  { push_neg at h,
    exfalso,
    apply h,
    exact hm }
end

@[simp]
lemma constant_coeff_incl (ι : σ ↪ τ) (f : mv_power_series σ R) :
  constant_coeff τ R (incl_fun R ι f) = constant_coeff σ R f :=
begin
  apply incl_fun_spec,
  refl,
end

#check @Exists.some
#check @Exists.some_spec

lemma incl_one (ι : σ ↪ τ) :
  incl_fun R ι 1 = 1 :=
begin
  ext m,
  simp only [mv_power_series.coeff_one],
  split_ifs,
  { simp [h] },
  { dsimp [incl_fun, coeff], split_ifs with hh hh,
    { let m' := hh.some,
      have hm' : incl_monomial ι m' = m := hh.some_spec,
      have h' : m' ≠ 0, {
        contrapose! h,
        rw ← hm',
        rw h,
        refl,
      },
      change (coeff R m') 1 = 0,
      rw mv_power_series.coeff_one,
      rw if_neg h' },
    { refl } }
end

lemma incl_zero (ι : σ ↪ τ) :
  incl_fun R ι 0 = 0 :=
  begin
    ext m,
    simp only [mv_power_series.coeff_zero],
    dsimp [incl_fun, coeff],
    split_ifs;
    try {refl,},
  end

lemma incl_add (ι : σ ↪ τ) (F : mv_power_series σ R) (G : mv_power_series σ R) :
  incl_fun R ι (F + G) = incl_fun R ι F + incl_fun R ι G :=
  begin
    ext m,
    dsimp [incl_fun, coeff],
    split_ifs;
    simp,
  end

/-
lemma helper (ι : σ ↪ τ) (n : τ →₀ ℕ) (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = n)
  (p : (τ →₀ ℕ) × (τ →₀ ℕ)) (hh : p ∈ n.antidiagonal) :
  (¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst) ∨ (¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd) :=
  begin
    -- messy proof should try and clean up
    rw finsupp.mem_antidiagonal at hh,
    by_contra,
    rw ← and_iff_not_or_not at h,
    cases h with hl hr,
    let ml := hl.some,
    have hml := hl.some_spec,
    let mr := hr.some,
    have hmr := hr.some_spec,
    -- rw ← [hml, hmr] at hh, this does not work, how to fix?
    rw ← hml at hh,
    rw ← hmr at hh,
    rw ← incl_mon_add at hh,
    apply h,
    use (ml + mr),
    apply hh,
  end
-/

lemma incl_mul_h (ι : σ ↪ τ) (n : τ →₀ ℕ) (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = n) --need better name
  (F : mv_power_series σ R) (G : mv_power_series σ R) (p : (τ →₀ ℕ) × (τ →₀ ℕ)) (hh : p ∈ n.antidiagonal) :
  dite (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst)
  (λ (h : ∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst), F h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst), 0) *
  dite (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd)
  (λ (h : ∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd), G h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd), 0) = 0  :=
  begin
    split_ifs, {
      exfalso,
      apply h,
      use h_1.some + h_2.some,
      rw incl_mon_add,
      rw [h_1.some_spec, h_2.some_spec],
      rw finsupp.mem_antidiagonal at hh,
      exact hh,
    }, {
      ring,
    }, {
      ring,
    }, {
      ring,
    }
  end

def S (ι : σ ↪ τ) (n : τ →₀ ℕ) : finset ((τ →₀ ℕ) × (τ →₀ ℕ)) :=
  set.to_finset {p : (τ →₀ ℕ) × (τ →₀ ℕ) | p ∈ n.antidiagonal ∧
  (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst) ∧ (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd)}

lemma helper (ι : σ ↪ τ) (n : τ →₀ ℕ) (h : ∃ (m' : σ →₀ ℕ), incl_monomial ι m' = n)
  (F : mv_power_series σ R) (G : mv_power_series σ R) :
  (∀ p : (τ →₀ ℕ) × (τ →₀ ℕ), p ∈ (n.antidiagonal \ S ι n) →
  dite (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst)
  (λ (h : ∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst), F h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.fst), 0) *
  dite (∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd)
  (λ (h : ∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd), G h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), incl_monomial ι m' = p.snd), 0) = 0) :=
  begin
    intros p hh,
    split_ifs, {
      sorry,
    }, {
      ring,
    }, {
      ring,
    }, {
      ring,
    }

  end
  /-dite (∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.fst)
  (λ (h : ∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.fst), F h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.fst), 0) *
  dite (∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.snd)
  (λ (h : ∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.snd), G h.some)
  (λ (h : ¬∃ (m' : σ →₀ ℕ), ⇑(incl_monomial ι) m' = p.snd), 0))-/

lemma incl_mul (ι : σ ↪ τ) (F : mv_power_series σ R) (G : mv_power_series σ R) :
  incl_fun R ι (F * G) = incl_fun R ι F * incl_fun R ι G :=
  begin
    ext n,
    rw [coeff_mul],
    dsimp [coeff, incl_fun],
    split_ifs, {
      dsimp [mv_power_series.has_mul],
      have hh : (S ι n ⊆ n.antidiagonal), {
        rw finset.subset_iff,
        intros x hh,
        sorry,
      },
      rw ← finset.sum_subset_zero_on_sdiff hh (helper R ι n h F G),
    }, {
      symmetry,
      apply finset.sum_eq_zero,
      intros p hh,
      exact incl_mul_h R ι n h F G p hh,
    }

  end

def incl (ι : σ ↪ τ) : mv_power_series σ R →+* mv_power_series τ R :=
{ to_fun := incl_fun _ ι,
  map_one' := incl_one _ _,
  map_mul' := incl_mul _ _,
  map_zero' := incl_zero _ _,
  map_add' := incl_add _ _, }

variable (σ)
def variable_ideal : ideal (mv_power_series σ R) :=
ideal.span (set.range mv_power_series.X)

noncomputable def degree_geq : ℕ → ideal (mv_power_series σ R)
| 0 := ⊤
| (n+1) := degree_geq n * variable_ideal σ R

variables {σ τ ω R}
def congruent_mod (n : ℕ) (F G : mv_power_series σ R) : Prop :=
F - G ∈ degree_geq σ R n

open finset

variables {σ τ ω R}
def nth_pow (n : ℕ) (F : mv_power_series σ R) : mv_power_series σ R := (∏ i in range n, F)

/-

def incl_fun : mv_power_series σ R → mv_power_series (σ ⊕ τ) R :=
  show ((σ →₀ ℕ) → R) → ((σ ⊕ τ →₀ ℕ) → R), from λ f m,
  let n := finsupp.sum_finsupp_equiv_prod_finsupp m in
  if n.2 = 0 then f n.1 else 0

#check mv_polynomial.eval₂_hom
-- mv_polynomial.C or.inl
/--begin
  ext m,
  unfold incl_fun,
  rw coeff_one,
  split_ifs,
  end,-/
def incl : mv_power_series σ R →+* mv_power_series (σ ⊕ τ) R :=
{ to_fun := incl_fun,
  map_one' :=  begin
  ext n,
  unfold incl_fun,
  rw coeff_one,
  simp,
  split_ifs,
  end,
  map_mul' := begin
  intros F G,
  ext,
  unfold incl_fun,
  simp,
  rw coeff_mul,
  end,
  map_zero' := begin
  ext,
  unfold incl_fun,
  simp,
  refl,
  end,
  map_add' := sorry }

def incr_fun : mv_power_series τ R → mv_power_series (σ ⊕ τ) R :=
  show ((τ →₀ ℕ) → R) → ((σ ⊕ τ →₀ ℕ) → R), from λ f m,
  let n := finsupp.sum_finsupp_equiv_prod_finsupp m in
  if n.1 = 0 then f n.2 else 0

def incr : mv_power_series τ R →+* mv_power_series (σ ⊕ τ) R :=
{ to_fun := incr_fun,
  map_one' := sorry,
  map_mul' := sorry,
  map_zero' := sorry,
  map_add' := sorry }

def change_var (e : σ ≃ τ) : mv_power_series σ R ≃+* mv_power_series τ R :=
sorry

def compose
  (F : mv_power_series σ R) -- F(X_1,X_2,...,X_n)
  (G : σ → mv_power_series τ R) -- G_1(X_1,...,X_m), ..., G_n(X_1,...,X_m)
  (hG : ∀ i, congruent_mod 1 (G i) 0) :
  mv_power_series τ R := λ (n : τ →₀ ℕ ), --(n : (τ →₀ ℕ) => ) -- F(G_1(X_1,...,X_m),...,G_n(X_1,...,X_m))

def compose_fst
  (F : mv_power_series (σ ⊕ τ) R) -- F(X_1,...,X_n;Y_1,...,Y_m)
  (G : σ → mv_power_series ω R) -- G_1(Z_1,...,Z_k), ..., G_n(Z_1,...,Z_k)
  (hG : ∀ i, congruent_mod 1 (G i) 0) :
  mv_power_series (ω ⊕ τ) R := -- F(G_1(Z_1,...,Z_k),...,G_n(Z_1,...,Z_k);Y_1,...,Y_m)
sorry

def compose_snd
  (F : mv_power_series (σ ⊕ τ) R) -- F(X_1,...,X_n;Y_1,...,Y_m)
  (G : τ → mv_power_series ω R) -- G_1(Z_1,...,Z_k), ..., G_m(Z_1,...,Z_k)
  (hG : ∀ i, congruent_mod 1 (G i) 0) :
  mv_power_series (σ ⊕ ω) R := -- F(X_1,...,X_n;G_1(Z_1,...,Z_k),...,G_m(Z_1,...,Z_k))
sorry

-/

end mv_power_series

/-
structure mv_formal_group_law :=
(F : σ → mv_power_series (σ ⊕ σ) R)
(F_mod_2 : ∀ i, mv_power_series.congruent_mod 2 (F i)
  (mv_power_series.X (sum.inl i) + mv_power_series.X (sum.inr i)))
(F_assoc : ∀ i,
  mv_power_series.compose_snd (F i) F sorry  -- should follow from F_mod_2
  =
  mv_power_series.change_var (equiv.sum_assoc _ _ _)
  (mv_power_series.compose_fst (F i) F sorry))
-/


import model_theory.substructures
import model_theory.bundled

--OUTPUT 1
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, A n = ∃' (x 1) (∃' (x 2) (∃' (x 3) (∃' (x 4) (∃' (x 5) (∃' (x 6) (∃' (x 7) (∃' (x 8) (∃' (x 9) (∃' (x 10) (∃' (x 11) (∃' (x 12) (∃' (x 13) (∃' (x 14) (∃' (x 15) (∃' (x 16) (∃' (x 17) (∃' (x 18) (∃' (x 19) (∃' (x 20) (∃' (x 21) (∃' (x 22) (∃' (x 23) (∃' (x 24) (∃' (x 25) (∃' (x 26) (∃' (x 27) (∃' (x 28) (∃' (x 29) (∃' (x 30) (∃' (x 31) (∃' (x 32) (∃' (x 33) (∃' (x 34) (∃' (x 35) (∃' (x 36) (∃' (x 37) (∃' (x 38) (∃' (x 39) (∃' (x 40) (∃' (x 41) (∃' (x 42) (∃' (x 43) (∃' (x 44) (∃' (x 45) (∃' (x 46) (∃' (x 47) (∃' (x 48) (∃' (x 49) (∃' (x 50) (∃' (x 51) (∃' (x 52) (∃' (x 53) (∃' (x 54) (∃' (x 55) (∃' (x 56) (∃' (x 57) (∃' (x 58) (∃' (x 59) (∃' (x 60) (∃' (x 61) (∃' (x 62) (∃' (x 63) (∃' (x 64) (∃' (x 65) (∃' (x 66) (∃' (x 67) (∃' (x 68) (∃' (x 69) (∃' (x 70) (∃' (x 71) (∃' (x 72) (∃' (x 73) (∃' (x 74) (∃' (x 75) (∃' (x 76) (∃' (x 77) (∃' (x 78) (∃' (x 79) (∃' (x 80) (∃' (x 81) (∃' (x 82) (∃' (x 83) (∃' (x 84) (∃' (x 85) (∃' (x 86) (∃' (x 87) (∃' (x 88) (∃' (x 89) (∃' (x 90) (∃' (x 91) (∃' (x 92) (∃' (x 93) (∃' (x 94) (∃' (x 95) (∃' (x 96) (∃' (x 97) (∃' (x 98) (∃' (x 99) (∃' (x 100) (∃' (x 101) (∃' (x 102) (∃' (x 103) (∃' (x 104) (∃' (x 105) (∃' (x 106) (∃' (x 107) (∃' (x 108) (∃' (x 109) (∃' (x 110) (∃' (x 111) (∃' (x 112) (∃' (x 113) (∃' (x 114) (∃' (x 115) (∃' (x 116) (∃' (x 117) (∃' (x 118) (∃' (x 119) (∃' (x 120) (∃' (x 121) (∃' (x 122) (∃' (x 123) (∃' (x 124) (∃' (x 125) (∃' (x 126) (∃' (x 127) (∃' (x 128) (∃' (x 129) (∃' (x 130) (∃' (x 131) (∃' (x 132) (∃' (x 133) (∃' (x 134) (∃' (x 135) (∃' (x 136) (∃' (x 137) (∃' (x 138) (∃' (x 139) (∃' (x 140) (∃' (x 141) (∃' (x 142) (∃' (x 143) (∃' (x 144) (∃' (x 145) (∃' (x 146) (∃' (x 147) (∃' (x 148) (∃' (x 149) (∃' (x 150) (∃' (x 151) (∃' (x 152) (∃' (x 153) (∃' (x 154) (∃' (x 155) (∃' (x 156) (∃' (x 157) (∃' (x 158) (∃' (x 159) (∃' (x 160) (∃' (x 161) (∃' (x 162) (∃' (x 163) (∃' (x 164) (∃' (x 165) (∃' (x 166) (∃' (x 167) (∃' (x 168) (∃' (x 169) (∃' (x 170) (∃' (x 171) (∃' (x 172) (∃' (x 173) (∃' (x 174) (∃' (x 175) (∃' (x 176) (∃' (x 177) (∃' (x 178) (∃' (x 179) (∃' (x 180) (∃' (x 181) (∃' (x 182) (∃' (x 183) (∃' (x 184) (∃' (x 185) (∃' (x 186) (∃' (x 187) (∃' (x 188) (∃' (x 189) (∃' (x 190) (∃' (x 191) (∃' (x 192) (∃' (x 193) (∃' (x 194) (∃' (x 195) (∃' (x 196) (∃' (x 197) (∃' (x 198) (∃' (x 199) (∃' (x 200) (∃' (x 201) (∃' (x 202) (∃' (x 203) (∃' (x 204) (∃' (x 205) (∃' (x 206) (∃' (x 207) (∃' (x 208) (∃' (x 209) (∃' (x 210) (∃' (x 211) (∃' (x 212) (∃' (x 213) (∃' (x 214) (∃' (x 215) (∃' (x 216) (∃' (x 217) (∃' (x 218) (∃' (x 219) (∃' (x 220) (∃' (x 221) (∃' (x 222) (∃' (x 223) (∃' (x 224) (∃' (x 225) (∃' (x 226) (∃' (x 227) (∃' (x 228) (∃' (x 229) (∃' (x 230) (∃' (x 231) (∃' (x 232) (∃' (x 233) (∃' (x 234) (∃' (x 235) (
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.Formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, A n = ∃' (x : fin n), ∀ (i j : fin n), i ≠ j → x i ≠ x j, from
    assume n : ℕ,
    begin
      -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
      let x : fin n → L.Term,
      have h2 : ∀ (i j : fin n), i ≠ j → x i ≠ x j, from
        assume (i j : fin n) (hij : i ≠ j),
        begin
          -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
          let y : fin n → L.Term,
          have h3 : ∀ (i j : fin n), i ≠ j → y i ≠ y j, from
            assume (i j : fin n) (hij : i ≠ j),
            begin
              -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
              let z : fin n → L.Term,
              have h4 : ∀ (i j : fin n), i ≠ j → z i ≠ z j, from
                assume (i j : fin n) (hij : i ≠ j),
                begin
                  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                  let w : fin n → L.Term,
                  have h5 : ∀ (i j : fin n), i ≠ j → w i ≠ w j, from
                    assume (i j : fin n) (hij : i ≠ j),
                    begin
                      -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                      let v : fin n → L.Term,
                      have h6 : ∀ (i j : fin n), i ≠ j → v i ≠ v j, from
                        assume (i j : fin n) (hij : i ≠ j),
                        begin
                          -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                          let u : fin n → L.Term,
                          have h7 : ∀ (i j : fin n), i ≠ j → u i ≠ u j, from
                            assume (i j : fin n) (hij : i ≠ j),
                            begin
                              -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                              let t : fin n → L.Term,
                              have h8 : ∀ (i j : fin n), i ≠ j → t i ≠ t j, from
                                assume (i j : fin n) (hij : i ≠ j),
                                begin
                                  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                  let s : fin n → L.Term,
                                  have h9 : ∀ (i j : fin n), i ≠ j → s i ≠ s j, from
                                    assume (i j : fin n) (hij : i ≠ j),
                                    begin
                                      -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                      let r : fin n → L.Term,
                                      have h10 : ∀ (i j : fin n), i ≠ j → r i ≠ r j, from
                                        assume (i j : fin n) (hij : i ≠ j),
                                        begin
                                          -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                          let q : fin n → L.Term,
                                          have h11 : ∀ (i j : fin n), i ≠ j → q i ≠ q j, from
                                            assume (i j : fin n) (hij : i ≠ j),
                                            begin
                                              -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                              let p : fin n → L.Term,
                                              have h12 : ∀ (i j : fin n), i ≠ j → p i ≠ p j, from
                                                assume (i j : fin n) (hij : i ≠ j),
                                                begin
                                                  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                                  let o : fin n → L.Term,
                                                  have h13 : ∀ (i j : fin n), i ≠ j → o i ≠ o j, from
                                                    assume (i j : fin n) (hij : i ≠ j),
                                                    begin
                                                      -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                                      let n : fin n → L.Term,
                                                      have h14 : ∀ (i j : fin n), i ≠ j → n i ≠ n j, from
                                                        assume (i j : fin n) (hij : i ≠ j),
                                                        begin
                                                          -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
                                                          let m : fin n → L.Term,
                                                          have h15 : ∀ (i j : fin n), i ≠ j → m i ≠ m j,
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
begin
  -- For each $n$, let $\mathbf A_n$ be the formula:
  let A : ℕ → L.formula,
  -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
  have h1 : ∀ n : ℕ, A n = ∃ (x : fin n → L.term), ∀ (i j : fin n), i ≠ j → L.formula.rel L.rel_syms.ne (x i) (x j), from
    assume n : ℕ, by {
      -- $\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$
      have h2 : ∃ (x : fin n → L.term), ∀ (i j : fin n), i ≠ j → L.formula.rel L.rel_syms.ne (x i) (x j), from
        by {
          use (λ i : fin n, L.term.var i),
          assume (i j : fin n) (hne : i ≠ j),
          have h3 : L.term.var i ≠ L.term.var j, from by {
            assume h4 : L.term.var i = L.term.var j,
            have h5 : i = j, from by {
              rw ← h4,
              apply term.var_inj,
            },
            show false, from by {
              apply hne,
              exact h5,
            },
          },
          show L.formula.rel L.rel_syms.ne (L.term.var i) (L.term.var j), from by {
            apply L.formula.rel.mk,
            exact L.rel_syms.ne,
            exact L.term.var i,
            exact L.term.var j,
            exact h3,
          },
        },
      show A n = ∃ (x : fin n → L.term), ∀ (i j : fin n), i ≠ j → L.formula.rel L.rel_syms.ne (x i) (x j), from by {
        apply exists_congr,
        assume x : fin n → L.term,
        apply forall_congr,
        assume i : fin n,
        apply forall_congr,
        assume j : fin n,
        apply imp_congr,
        assume hne : i ≠ j,
        apply eq_of_heq,
        apply heq_of_eq,
        apply eq_of_heq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply heq_of_eq,
        apply
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
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
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
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, 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
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Overflow theorem
Let $F$ be a set of first-order formulas which has finite models of arbitrarily large size. Then $F$ has an infinite model.
`proof`
For each $n$, let $\mathbf A_n$ be the formula:

$\exists x_1 \exists x_2 \ldots \exists x_n: \{x_1 \ne x_2 \land x_1 \ne x_3 \land \ldots \land x_{n - 1} \ne x_n\}$

Then $\mathbf A_i$ is true in a structure $\AA$ iff $\AA$ has at least $n$ elements.

Take:
$$ \Gamma := F \cup \bigcup_{i \mathop = 1}^\infty A_i $$

Since $F$ has models of arbitrarily large size, every finite subset of $\Gamma$ is satisfiable.

From the Compactness Theorem, $\Gamma$ is satisfiable in some model $\mathbf{M}$.

But since $\mathbf{M} \models A_i$ for each $i$, $\mathbf{M}$ must be infinite.

So $F$ has an infinite model.

QED
-/
theorem  overflow {L : first_order.language} {F : L.Theory} (h : ∀ n : ℕ, ∃ (m : F.Model) [mfin : fintype m], n ≤ @fintype.card m mfin) : ∃ (M : F.Model), infinite M :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Luke Kershaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luke Kershaw
-/
import category_theory.preadditive.additive_functor
import category_theory.shift
import category_theory.triangulated.rotate

/-!
# Pretriangulated Categories

This file contains the definition of pretriangulated categories and triangulated functors
between them.

## Implementation Notes

We work under the assumption that pretriangulated categories are preadditive categories,
but not necessarily additive categories, as is assumed in some sources.

TODO: generalise this to n-angulated categories as in https://arxiv.org/abs/1006.4592
-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v v₀ v₁ v₂ u u₀ u₁ u₂

namespace category_theory.triangulated
open category_theory.category

/-
We work in a preadditive category `C` equipped with an additive shift.
-/
variables (C : Type u) [category.{v} C] [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ n : ℤ, functor.additive (shift_functor C n)]

/--
A preadditive category `C` with an additive shift, and a class of "distinguished triangles"
relative to that shift is called pretriangulated if the following hold:
* Any triangle that is isomorphic to a distinguished triangle is also distinguished.
* Any triangle of the form `(X,X,0,id,0,0)` is distinguished.
* For any morphism `f : X ⟶ Y` there exists a distinguished triangle of the form `(X,Y,Z,f,g,h)`.
* The triangle `(X,Y,Z,f,g,h)` is distinguished if and only if `(Y,Z,X⟦1⟧,g,h,-f⟦1⟧)` is.
* Given a diagram:
  ```
        f       g       h
    X  ───> Y  ───> Z  ───> X⟦1⟧
    │       │                │
    │a      │b               │a⟦1⟧'
    V       V                V
    X' ───> Y' ───> Z' ───> X'⟦1⟧
        f'      g'      h'
  ```
  where the left square commutes, and whose rows are distinguished triangles,
  there exists a morphism `c : Z ⟶ Z'` such that `(a,b,c)` is a triangle morphism.

See <https://stacks.math.columbia.edu/tag/0145>
-/
class pretriangulated :=
(distinguished_triangles [] : set (triangle C))
(isomorphic_distinguished : Π (T₁ ∈ distinguished_triangles) (T₂ ≅ T₁),
  T₂ ∈ distinguished_triangles)
(contractible_distinguished : Π (X : C), (contractible_triangle C X) ∈ distinguished_triangles)
(distinguished_cocone_triangle : Π (X Y : C) (f : X ⟶ Y), (∃ (Z : C) (g : Y ⟶ Z)
  (h : Z ⟶ X⟦(1:ℤ)⟧),
  triangle.mk _ f g h ∈ distinguished_triangles))
(rotate_distinguished_triangle : Π (T : triangle C),
  T ∈ distinguished_triangles ↔ T.rotate ∈ distinguished_triangles)
(complete_distinguished_triangle_morphism : Π (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ distinguished_triangles) (h₂ : T₂ ∈ distinguished_triangles) (a : T₁.obj₁ ⟶ T₂.obj₁)
  (b : T₁.obj₂ ⟶ T₂.obj₂) (comm₁ : T₁.mor₁ ≫ b = a ≫ T₂.mor₁),
  (∃ (c : T₁.obj₃ ⟶ T₂.obj₃), (T₁.mor₂ ≫ c = b ≫ T₂.mor₂) ∧ (T₁.mor₃ ≫ a⟦1⟧' = c ≫ T₂.mor₃) ))

namespace pretriangulated
variables [pretriangulated C]

notation `dist_triang `:20 C := distinguished_triangles C
/--
Given any distinguished triangle `T`, then we know `T.rotate` is also distinguished.
-/
lemma rot_of_dist_triangle (T ∈ dist_triang C) : (T.rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle T).mp H

/--
Given any distinguished triangle `T`, then we know `T.inv_rotate` is also distinguished.
-/
lemma inv_rot_of_dist_triangle (T ∈ dist_triang C) : (T.inv_rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle (T.inv_rotate)).mpr
  (isomorphic_distinguished T H T.inv_rotate.rotate (inv_rot_comp_rot.app T))

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `f ≫ g = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₁₂ (T ∈ dist_triang C) : T.mor₁ ≫ T.mor₂ = 0 :=
begin
  have h := contractible_distinguished T.obj₁,
  have f := complete_distinguished_triangle_morphism,
  specialize f (contractible_triangle C T.obj₁) T h H (𝟙 T.obj₁) T.mor₁,
  have t : (contractible_triangle C T.obj₁).mor₁ ≫ T.mor₁ = 𝟙 T.obj₁ ≫ T.mor₁,
    by refl,
  specialize f t,
  cases f with c f,
  rw ← f.left,
  simp only [limits.zero_comp, contractible_triangle_mor₂],
end -- TODO : tidy this proof up

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `g ≫ h = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₂₃  (T ∈ dist_triang C) : T.mor₂ ≫ T.mor₃ = 0 :=
comp_dist_triangle_mor_zero₁₂ C T.rotate (rot_of_dist_triangle C T H)

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `h ≫ f⟦1⟧ = 0`.
See <https://stacks.math.columbia.edu/tag/0146>
-/
lemma comp_dist_triangle_mor_zero₃₁ (T ∈ dist_triang C) :
  T.mor₃ ≫ ((shift_equiv C 1).functor.map T.mor₁) = 0 :=
have H₂ : _ := rot_of_dist_triangle C T.rotate (rot_of_dist_triangle C T H),
by simpa using comp_dist_triangle_mor_zero₁₂ C (T.rotate.rotate) H₂

/-
TODO: If `C` is pretriangulated with respect to a shift,
then `Cᵒᵖ` is pretriangulated with respect to the inverse shift.
-/
end pretriangulated
end category_theory.triangulated

namespace category_theory.triangulated
namespace pretriangulated

variables (C : Type u₁) [category.{v₁} C] [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ n : ℤ, functor.additive (shift_functor C n)]
variables (D : Type u₂) [category.{v₂} D] [has_zero_object D] [has_shift D ℤ] [preadditive D]
  [∀ n : ℤ, functor.additive (shift_functor D n)]

/--
The underlying structure of a triangulated functor between pretriangulated categories `C` and `D`
is a functor `F : C ⥤ D` together with given functorial isomorphisms `ξ X : F(X⟦1⟧) ⟶ F(X)⟦1⟧`.
-/
structure triangulated_functor_struct extends (C ⥤ D) :=
(comm_shift : shift_functor C (1 : ℤ) ⋙ to_functor ≅ to_functor ⋙ shift_functor D (1 : ℤ))

namespace triangulated_functor_struct

/-- The identity `triangulated_functor_struct`. -/
def id : triangulated_functor_struct C C :=
{ obj := λ X, X,
  map := λ _ _ f, f,
  comm_shift := by refl }

instance : inhabited (triangulated_functor_struct C C) := ⟨id C⟩

variables {C D}
/--
Given a `triangulated_functor_struct` we can define a functor from triangles of `C` to
triangles of `D`.
-/
@[simps]
def map_triangle (F : triangulated_functor_struct C D) : triangle C ⥤ triangle D :=
{ obj := λ T, triangle.mk _ (F.map T.mor₁) (F.map T.mor₂)
    (F.map T.mor₃ ≫ F.comm_shift.hom.app T.obj₁),
  map := λ S T f,
  { hom₁ := F.map f.hom₁,
    hom₂ := F.map f.hom₂,
    hom₃ := F.map f.hom₃,
    comm₁' := by { dsimp, simp only [←F.to_functor.map_comp, f.comm₁], },
    comm₂' := by { dsimp, simp only [←F.to_functor.map_comp, f.comm₂], },
    comm₃' := begin
      dsimp,
      erw [category.assoc, ←F.comm_shift.hom.naturality],
      simp only [functor.comp_map, ←F.to_functor.map_comp_assoc, f.comm₃],
    end, }, }

end triangulated_functor_struct

variables (C D)
/--
A triangulated functor between pretriangulated categories `C` and `D` is a functor `F : C ⥤ D`
together with given functorial isomorphisms `ξ X : F(X⟦1⟧) ⟶ F(X)⟦1⟧` such that for every
distinguished triangle `(X,Y,Z,f,g,h)` of `C`, the triangle
`(F(X), F(Y), F(Z), F(f), F(g), F(h) ≫ (ξ X))` is a distinguished triangle of `D`.
See <https://stacks.math.columbia.edu/tag/014V>
-/
structure triangulated_functor [pretriangulated C] [pretriangulated D] extends
  triangulated_functor_struct C D :=
(map_distinguished' : Π (T : triangle C), (T ∈ dist_triang C) →
  (to_triangulated_functor_struct.map_triangle.obj T ∈ dist_triang D) )

instance [pretriangulated C] : inhabited (triangulated_functor C C) :=
⟨{obj := λ X, X,
  map := λ _ _ f, f,
  comm_shift := by refl ,
  map_distinguished' := begin
    rintros ⟨_,_,_,_⟩ Tdt,
    dsimp at *,
    rwa category.comp_id,
  end }⟩

variables {C D} [pretriangulated C] [pretriangulated D]
/--
Given a `triangulated_functor` we can define a functor from triangles of `C` to triangles of `D`.
-/
@[simps]
def triangulated_functor.map_triangle (F : triangulated_functor C D) :
  triangle C ⥤ triangle D :=
F.to_triangulated_functor_struct.map_triangle

/--
Given a `triangulated_functor` and a distinguished triangle `T` of `C`, then the triangle it
maps onto in `D` is also distinguished.
-/
lemma triangulated_functor.map_distinguished (F : triangulated_functor C D) (T : triangle C)
  (h : T ∈ dist_triang C) : (F.map_triangle.obj T) ∈ dist_triang D := F.map_distinguished' T h

end pretriangulated
end category_theory.triangulated


open Lean

syntax (name := myintro) "intros" sepBy(ident, ",") : tactic

macro_rules (kind := myintro)
| `(tactic| intros $x,*) => pure $ Syntax.node `Lean.Parser.Tactic.intros #[mkAtom "intros", mkNullNode x]

theorem tst1 {p q : Prop} : p → q → p :=
by {
  intros h1, h2;
  assumption
}

theorem tst2 {p q : Prop} : p → q → p :=
by {
  intros h1; -- the builtin and myintro overlap here.
  intros h2; -- the builtin and myintro overlap here.
  assumption
}

theorem tst3 {p q : Prop} : p → q → p :=
by {
  intros h1 h2;
  assumption
}


import tactic
import tactic.induction
import data.int.basic
import data.set.basic
import logic.function.iterate
import data.list

import .base .game

noncomputable theory
open_locale classical

def A_played_move_at {pw : ℕ} (s : State) (s₀' : State)
  (ma : Valid_A_move pw s₀'.board) : Prop :=
∃ (s₀ : State) (md : Valid_D_move s₀.board) (a : A pw) (d : D) (n : ℕ),
(∃ hs, d.f s₀ hs = md) ∧
s₀' = apply_D_move s₀ md.m ∧
(∃ hs h, a.f s₀' hs h = ma) ∧
n ≠ 0 ∧
s = ((init_game a d s₀).play n).s

-----

lemma A_played_move_at_apply_move {pw : ℕ} {s s' : State}
  {md : Valid_D_move s.board} {ma : Valid_A_move pw s'.board}
  (hs : s.act) (h : s' = apply_D_move s md.m) :
  A_played_move_at (apply_A_move s' ma.m) s' ma :=
begin
  let a := (default : A pw).set_move s' ma,
  let d := (default : D).set_move s md,
  use [s, md, a, d, 1, ⟨hs, D_set_move_eq_pos⟩, h],
  have hs₁ : s'.act := by rwa h,
  have hvm_s' : A_has_valid_move pw s'.board := ⟨_, ma.h⟩,
  refine ⟨_, _, _⟩, { exact ⟨hs₁, hvm_s', A_set_move_eq_pos⟩ },
  { dec_trivial }, rw [play_1, play_move_at_act], swap, { exact hs },
  rw play_A_move_at, rw dif_pos, swap,
  { use hs, convert hvm_s', convert h.symm,
    change apply_D_move s (d.f s hs).m = _, congr,
    exact D_set_move_eq_pos },
  symmetry, change apply_A_move _ _ = _,
  have h₁ : (play_D_move_at (init_game a d s) hs).s = s',
  { convert h.symm, change apply_D_move s (d.f s hs).m = _,
    congr, exact D_set_move_eq_pos },
  congr' 1, change (a.f _ _ _).m = _, generalize_proofs h₂,
  have h₃ : (a.f (play_D_move_at (init_game a d s) hs).s hs h₂).m =
    (a.f s' hs₁ hvm_s').m, { congr' },
  rw [h₃, A_set_move_eq_pos],
end

lemma A_hvm_of_next_act {pw : ℕ} {g : Game pw}
  (h : g.play_move.act) :
  ∃ hs, A_has_valid_move pw (play_D_move_at g hs).s.board :=
begin
  have hs : g.act := act_of_act_play_move h, use hs,
  rw Game.play_move at h, rw dif_pos hs at h,
  rw play_A_move_at at h, split_ifs at h with h₄,
  { cases h₄ with h₄ h₅, convert h₅, },
  { cases h }
end

lemma play_move_hist_len_eq_of_act {pw : ℕ} {g : Game pw}
  (h : g.play_move.act) :
  g.play_move.s.len = g.s.len + 2 :=
begin
  have h₁ : g.act := act_of_act_play_move h,
  rw [play_move_at_act h₁, play_A_move_at],
  rw dif_pos, { rw [hist_len_play_A_move_at', hist_len_play_D_move_at] },
  exact ⟨h₁, (A_hvm_of_next_act h).some_spec⟩,
end

lemma play_hist_len_eq_of_act {pw n : ℕ} {g : Game pw}
  (h : (g.play n).act) :
  (g.play n).s.len = g.s.len + n * 2 :=
begin
  induction n with n ih, { refl }, rw play_at_succ' at h ⊢,
  let g₁ : Game pw := _, change g.play n with g₁ at ih h ⊢,
  have h₁ := act_of_act_play_move h, specialize ih h₁,
  rw [play_move_hist_len_eq_of_act h, ih, add_assoc, nat.succ_mul],
end

lemma hist_len_ne_of_play_lt {pw n k : ℕ} {g : Game pw}
  (h₁ : k < n) (h₂ : (g.play n).act) :
  (g.play k).s.len ≠ (g.play n).s.len :=
begin
  have h₃ := act_play_le (nat.le_of_lt h₁) h₂,
  rw [play_hist_len_eq_of_act h₂, play_hist_len_eq_of_act h₃], intro h,
  replace h := nat.add_left_cancel h,
  rw nat.mul_left_inj at h, swap, { dec_trivial },
  subst h, exact nat.lt_asymm h₁ h₁,
end

lemma hist_ne_of_play_lt {pw n k : ℕ} {g : Game pw}
  (h₁ : k < n) (h₂ : (g.play n).act) :
  (g.play k).s.history ≠ (g.play n).s.history :=
hist_ne_of_hist_len_ne (hist_len_ne_of_play_lt h₁ h₂)

lemma state_ne_of_play_lt {pw n k : ℕ} {g : Game pw}
  (h₁ : k < n) (h₂ : (g.play n).act) :
  (g.play k).s ≠ (g.play n).s :=
by { have h₃ := hist_ne_of_play_lt h₁ h₂, contrapose! h₃, rw h₃ }

lemma apply_A_move_ne_of_hist_ne {pw : ℕ} {s₁ s₂ : State}
  {ma₁ ma₂ : A_move} (h : s₁.len ≠ s₂.len) :
  apply_A_move s₁ ma₁ ≠ apply_A_move s₂ ma₂ :=
begin
  contrapose! h, simp_rw [apply_A_move, apply_move] at h,
  simp_rw [State.len, (snoc_eq_snoc_iff.mp h.2.1).1],
end

lemma apply_D_move_ne_of_hist_ne {s₁ s₂ : State}
  {md₁ md₂ : D_move} (h : s₁.len ≠ s₂.len) :
  apply_D_move s₁ md₁ ≠ apply_D_move s₂ md₂ :=
begin
  contrapose! h, simp_rw [apply_D_move, apply_move] at h,
  simp_rw [State.len, (snoc_eq_snoc_iff.mp h.2.1).1],
end

def mk_A_for_played_move_at_play_move {pw : ℕ}
  (a₀ a : A pw) (s' : State) (hs : s'.act) :
  A pw :=
if hvm : A_has_valid_move pw s'.board
then a₀.set_move s' (a.f s' hs hvm)
else a₀

lemma A_played_move_at_play_move {pw : ℕ}
  {g : Game pw} {s₀' : State} {ma : Valid_A_move pw s₀'.board}
  (h : A_played_move_at g.s s₀' ma) :
  A_played_move_at g.play_move.s s₀' ma :=
begin
  let a := g.a, let d := g.d, let s := g.s,
  rcases h with ⟨s₀, md₀, a₀, d₀, n, hmd, h₁, hx, hy, h₂⟩, by_cases hs : g.act,
  { let md := d.f s hs, let s' := apply_D_move s md.m,
    let d₁ := d₀.set_move s md,
    let a₁ := mk_A_for_played_move_at_play_move a₀ a s' hs,
    have hmd₁ : ∃ hs, d₁.f s₀ hs = md₀,
    { cases hmd with hs₁ hmd, use hs₁, change dite _ _ _ = _,
      rw dif_neg, { exact hmd }, change ((init_game a₀ d₀ s₀).play 0).s ≠ g.s,
      rw h₂, apply state_ne_of_play_lt (nat.pos_of_ne_zero hy),
      change g.s.act at hs, rwa h₂ at hs },
    use [s₀, md₀, a₁, d₁, n.succ, hmd₁, by rw h₁],
    have h₁ : ∀ (k ≤ n), ((init_game a₁ d₁ s₀).play k).s =
      ((init_game a₀ d₀ s₀).play k).s,
    { rintro k hk, induction k with k ih, { refl }, simp_rw play_at_succ',
      specialize ih (nat.le_of_succ_le hk),
      replace ih : (init_game a₁ d₁ s₀).play k =
        ((init_game a₀ d₀ s₀).play k).set_players a₁ d₁,
      { ext,
        { exact play_at_players_eq.1 },
        { exact play_at_players_eq.2 },
        { rw ih, refl }},
      rw ih, clear ih,
      have hs₁ : ((init_game a₀ d₀ s₀).play k).act,
      { apply act_play_le (nat.le_of_succ_le hk),
        change ((init_game a₀ d₀ s₀).play n).s.act,
        rw ←h₂, exact hs },
      repeat { rw play_move_at_act, swap, { exact hs₁ }},
      let g₁ : Game pw := _,
      change (init_game a₀ d₀ s₀).play k with g₁ at hs₁ ⊢,
      have ha : g₁.a = a₀ := play_at_players_eq.1,
      have hd : g₁.d = d₀ := play_at_players_eq.2,
      let sk := g₁.s, let mdk := d₀.f sk hs₁,
      let sk' := apply_D_move sk mdk.m,
      have hy : (play_D_move_at g₁ hs₁).s = sk',
      { change apply_D_move sk _ = apply_D_move _ _, congr' 2, rw hd },
      have h₁ : d₁.f sk hs₁ = mdk,
      { change dite _ _ _ = _, rw dif_neg,
        change ((init_game a₀ d₀ s₀).play k).s ≠ g.s, rw h₂,
        apply state_ne_of_play_lt (nat.succ_le_iff.mp hk),
        change ((init_game a₀ d₀ s₀).play n).s.act, rw ←h₂, exact hs },
      have hx : play_D_move_at (g₁.set_players a₁ d₁) hs₁ =
        (play_D_move_at g₁ hs₁).set_players a₁ d₁,
      { ext,
        { exact play_D_move_at_players_eq.1, },
        { exact play_D_move_at_players_eq.2, },
        { change apply_D_move g₁.s _ = apply_D_move _ _,
          congr' 2, change d₁.f sk _ = _, rw [h₁, hd] }},
      rw hx, clear hx, have hx : A_has_valid_move pw sk'.board,
      { have h₃ : g₁.play_move.act,
        { change ((init_game a₀ d₀ s₀).play k).play_move.act,
          rw ←play_at_succ', apply act_play_le hk,
          change ((init_game a₀ d₀ s₀).play n).s.act,
          rw ←h₂, exact hs },
        convert (A_hvm_of_next_act h₃).some_spec, rw ←hy, refl },
      simp_rw play_A_move_at,
      repeat { rw dif_pos, swap, { use hs₁, convert hx }},
      change apply_A_move (play_D_move_at g₁ hs₁).s
        (a₁.f (play_D_move_at g₁ hs₁).s _ _).m =
        apply_A_move _ (g₁.a.f (play_D_move_at g₁ hs₁).s _ _).m,
      congr' 2, rw ha, generalize_proofs h₃,
      change (mk_A_for_played_move_at_play_move _ _ _ _).f _ _ _ = _,
      rw mk_A_for_played_move_at_play_move,
      split_ifs with hh, swap, { refl },
      change dite _ _ _ = _, rw dif_neg, rw hy,
      change apply_D_move ((init_game a₀ d₀ s₀).play k).s mdk.m ≠
        apply_D_move g.s md.m,
      rw h₂, replace hk := nat.lt_of_succ_le hk,
      apply apply_D_move_ne_of_hist_ne, apply hist_len_ne_of_play_lt hk,
      change ((init_game a₀ d₀ s₀).play n).s.act, rw ←h₂, exact hs },
    specialize h₁ n (le_refl n),
    replace h₁ : (init_game a₁ d₁ s₀).play n = g.set_players a₁ d₁,
    { ext,
      { exact play_at_players_eq.1 },
      { exact play_at_players_eq.2 },
      { rw h₁, exact h₂.symm }},
    rw [play_at_succ', play_move_at_act hs, h₁, play_move_at_act],
    swap, { exact hs }, refine ⟨_, _, _⟩,
    { clear h₁, rcases hx with ⟨hs', h, hx⟩,
      use [hs', h], rw ←hx, clear hx,
      change (mk_A_for_played_move_at_play_move _ _ _ _).f _ _ _ = _,
      rw mk_A_for_played_move_at_play_move,
      split_ifs with hss, swap, { refl }, change dite _ _ _ = _,
      rw dif_neg, change s₀' ≠ apply_D_move g.s _, rw [h₁, h₂],
      apply apply_D_move_ne_of_hist_ne,
      change ((init_game a₀ d₀ s₀).play 0).s.len ≠ _,
      apply hist_len_ne_of_play_lt (pos_iff_ne_zero.mpr hy),
      rw [Game.act, ←h₂], exact hs }, { dec_trivial }, symmetry,
    have h₁ : play_D_move_at (g.set_players a₁ d₁) hs =
      (play_D_move_at g hs).set_players a₁ d₁,
    { ext,
      { exact play_D_move_at_players_eq.1 },
      { exact play_D_move_at_players_eq.2 },
      { change apply_D_move g.s _ = apply_D_move _ _,
        congr' 2, change d₁.f s hs = g.d.f g.s hs,
        change dite _ _ _ = _, rw dif_pos rfl }},
    rw h₁, clear h₁, simp_rw play_A_move_at,
    split_ifs with h₁, swap, { refl }, cases h₁ with h₁ h₂,
    change apply_A_move ((play_D_move_at g hs).s) _ =
      apply_A_move _ _,
    congr' 2, change a₁.f s' _ _ = a.f s' _ _, generalize_proofs,
    change (mk_A_for_played_move_at_play_move _ _ _ _).f _ _ _ = _,
    rw mk_A_for_played_move_at_play_move, rw dif_pos, swap, { exact h₂ },
    change dite _ _ _ = _, rw dif_pos rfl },
  { use [s₀, md₀, a₀, d₀, n, hmd, h₁, hx, hy],
    rw play_move_at_not_act hs, exact h₂ },
end

lemma A_played_move_at_play {pw n : ℕ}
  {g : Game pw} {s' : State} {ma : Valid_A_move pw s'.board}
  (h : A_played_move_at g.s s' ma) :
  A_played_move_at (g.play n).s s' ma :=
begin
  induction n with n ih, { exact h }, rw play_at_succ',
  exact A_played_move_at_play_move ih,
end

lemma hist_overlaps_of_A_played_move_at {pw : ℕ}
  {s s₀' : State} {ma : Valid_A_move pw s₀'.board}
  (h₁ : A_played_move_at s s₀' ma) :
  ∀ (k : ℕ), k.succ < s₀'.len →
  s.history.nth k = s₀'.history.nth k :=
begin
  rintro k h₂,
  rcases h₁ with ⟨s₀, md, a, d, n, hmd, rfl, hx, hy, rfl⟩, clear' hx hy,
  change (apply_D_move s₀ md.m).history with (_ ++ _ : list _) at h₂ ⊢,
  change _ < (snoc _ _).length at h₂,
  rw [length_snoc, nat.succ_lt_succ_iff] at h₂ ,induction n with n ih,
  { change s₀.history.nth k = _, exact (list.nth_append h₂).symm },
  { simp_rw play_at_succ', let g : Game pw := _,
    change (init_game a d s₀).play n with g at h₂ ih ⊢, rw ←ih, clear ih,
    rw Game.play_move, split_ifs with hs, swap, { refl }, rw play_A_move_at,
    have h₆ : s₀.len ≤ g.s.len,
    { change (init_game a d s₀).s.len ≤ _, exact hist_len_le_play },
    split_ifs with h₃,
    { change (_ ++ _ : list _).nth _ = _, rw list.nth_append,
      { change (_ ++ _ : list _).nth _ = _, rw list.nth_append,
        exact gt_of_ge_of_gt h₆ h₂ },
      { rw [←State.len, hist_len_play_D_move_at],
        exact nat.lt_succ_of_le (nat.le_trans (le_of_lt h₂) h₆) }},
    { change (_ ++ _ : list _).nth _ = _, rw list.nth_append,
      exact gt_of_ge_of_gt h₆ h₂ }},
end

lemma A_played_move_at_eq_aux {pw n : ℕ}
  {sx s₀ s' : State} {md : Valid_D_move s₀.board}
  {a : A pw} {d : D} {hs hvm h₄}
  (h₁ : s' = apply_D_move s₀ md.m)
  (h₂ : sx = ((init_game a d s₀).play n).s)
  (h₃ : n ≠ 0)
  (hh : md = d.f s₀ h₄) :
  sx.nth (s₀.len + 2) = option.some
    (apply_A_move s' (a.f s' hs hvm).m).board :=
begin
  cases n, { contradiction }, clear h₃,
  let i : ℕ := _, change s₀.len + 2 with i,
  let s₁ : State := apply_A_move s' (a.f s' hs hvm).m,
  change _ = some (State.board s₁), have h₅ : i = s₁.len,
  { change s₁ with apply_A_move _ _, subst s',
    rw [apply_A_move_len, apply_D_move_len] },
  induction n with n ih generalizing sx,
  { rw [play_1, play_move_at_act] at h₂, swap, { exact h₄ },
    subst sx, have h₆ : play_D_move_at (init_game a d s₀) h₄ =
      (init_game a d s'),
    { ext,
      { exact play_D_move_at_players_eq.1 },
      { exact play_D_move_at_players_eq.2 },
      { subst s',
        change apply_D_move s₀ (d.f s₀ _).m = apply_D_move s₀ _, rw hh }},
    rw [h₆, play_A_move_at, dif_pos], clear h₆, swap, { exact ⟨hs, hvm⟩ },
    change s₁.nth _ = _, rw h₅, exact state_nth_len },
  { rw play_at_succ' at h₂, let g₁ : Game pw := (init_game a d s₀).play n.succ,
    change (init_game a d s₀).play n.succ with g₁ at ih h₂, subst sx,
    specialize ih rfl, rw Game.play_move, split_ifs with hs₁, swap, { exact ih },
    let g₂ : Game pw := _, change play_D_move_at g₁ hs₁ with g₂,
    have ih₁ : g₂.s.nth i = some s₁.board,
    { exact apply_move_state_nth_eq_some_of ih },
    rw play_A_move_at, split_ifs with hh,
    { exact apply_move_state_nth_eq_some_of ih₁ },
    { exact ih₁ }},
end

lemma A_played_move_at_eq {pw : ℕ}
  {sx s' : State} {ma₁ ma₂ : Valid_A_move pw s'.board}
  (hx : A_played_move_at sx s' ma₁)
  (hy : A_played_move_at sx s' ma₂) :
  ma₁ = ma₂ :=
begin
  obtain ⟨s₀, md₁, a₁, d₁, n₁, hmd₁, h₁, ⟨hs₁, hvm₁, rfl⟩, h₃, h₄⟩ := hx,
  obtain ⟨s₀', md₂, a₂, d₂, n₂, hmd₂, h₅, ⟨hs₂, hvm₂, rfl⟩, h₇, h₈⟩ := hy,
  have hs : s₀.act,
  { subst s', exact hs₂ },
  obtain rfl : s₀ = s₀',
  { subst h₁, exact state_eq_of_apply_D_move_eq h₅ },
  obtain rfl : md₁ = md₂,
  { subst h₁, rwa ←D_moves_eq_iff at h₅ },
  clear h₅, change hvm₂ with hvm₁, clear hvm₂,
  change hs₂ with hs₁, clear hs₂, let i := s₀.len,
  have h₅ : sx.nth (i + 2) = option.some
    (apply_A_move s' (a₁.f s' hs₁ hvm₁).m).board,
  { exact A_played_move_at_eq_aux h₁ h₄ h₃ hmd₁.some_spec.symm },
  have h₆ : sx.nth (i + 2) = option.some
    (apply_A_move s' (a₂.f s' hs₁ hvm₁).m).board,
  { exact A_played_move_at_eq_aux h₁ h₈ h₇ hmd₂.some_spec.symm },
  simp [h₅] at h₆, rwa A_moves_eq_iff',
end