import breen_deligne.main
import breen_deligne.eg
import condensed.tensor_short_exact
import condensed.evaluation_homology
import condensed.sheafification_homology
import pseudo_normed_group.QprimeFP
import for_mathlib.AddCommGroup
import for_mathlib.map_to_sheaf_is_iso
import condensed.is_iso_iff_extrdisc
import Lbar.torsion_free_condensed
import condensed.ab5
import condensed.ab4
import for_mathlib.endomorphisms.ab4
import for_mathlib.homology_exact
import condensed.Qprime_isoms2
import for_mathlib.free_abelian_exact
import for_mathlib.unflip
import breen_deligne.eval_Pow_functor_nat_trans_compatibility

.

noncomputable theory

universes u

open category_theory category_theory.limits breen_deligne opposite
open_locale big_operators

section
open category_theory.preadditive

attribute [simps map] AddCommGroup.free

lemma oof (A B : AddCommGroup.{u}) : (A →+ B) = (A ⟶ B) := rfl

lemma reorder {M : Type*} [add_comm_monoid M] (a b c d : M) :
  (a + b) + (c + d) = (a + c) + (b + d) :=
by { simp only [add_assoc, add_left_comm b c d], }

def eval_free_π (A : AddCommGroup.{u}) (i : fin 2) : (preadditive.Pow 2).obj A ⟶ (preadditive.Pow 1).obj A :=
biproduct.π _ (ulift.up i) ≫ biproduct.ι (λ _, A) (ulift.up 0)

lemma eval_free_π_eq (A : AddCommGroup.{u}) (k : fin 2) :
  eval_free_π A k = biproduct.matrix
    (λ (i : ulift (fin 2)) (j : ulift (fin 1)), basic_universal_map.proj 1 k j.down i.down • 𝟙 A) :=
begin
  apply biproduct.hom_ext, rintro ⟨j⟩, fin_cases j,
  rw [biproduct.matrix_π, eval_free_π, category.assoc, biproduct.ι_π, dif_pos rfl, eq_to_hom_refl,
    category.comp_id],
  apply biproduct.hom_ext', rintro ⟨i⟩, rw [biproduct.ι_desc],
  suffices : basic_universal_map.proj 1 k 0 i = if i = k then 1 else 0,
  { rw [this, biproduct.ι_π], dsimp, obtain (rfl|hik) := eq_or_ne i k,
    { rw [if_pos rfl, if_pos rfl, one_smul], },
    { rw [if_neg, if_neg hik, zero_smul], intro H, apply hik, apply equiv.ulift.symm.injective, exact H } },
  { dsimp [basic_universal_map.proj, basic_universal_map.proj_aux], dec_trivial! },
end

def eval_free_σ (A : AddCommGroup.{u}) : (preadditive.Pow 2).obj A ⟶ (preadditive.Pow 1).obj A :=
eval_free_π A 0 + eval_free_π A 1

lemma eval_free_d10 (A : AddCommGroup.{u}) :
  (((data.eval_functor (forget _ ⋙ AddCommGroup.free)).obj breen_deligne.eg.data).obj A).d 1 0 =
  ((forget _ ⋙ AddCommGroup.free).map $ eval_free_π A 0) +
  ((forget _ ⋙ AddCommGroup.free).map $ eval_free_π A 1) -
  ((forget _ ⋙ AddCommGroup.free).map $ eval_free_σ A) :=
begin
  dsimp only [eg, eg.BD, data.eval_functor_obj_obj_d], rw [dif_pos rfl],
  dsimp only [universal_map.eval_Pow], rw [lift_app],
  dsimp only [whisker_right_app, eg.map, eg.σπ, universal_map.proj, universal_map.sum],
  simp only [add_monoid_hom.map_sub, free_abelian_group.lift.of,
    basic_universal_map.eval_Pow_app, functor.comp_map, forget_map_eq_coe, sub_comp, add_comp,
    preadditive.Pow_obj, forget_obj_eq_coe, fin.sum_univ_two, add_monoid_hom.map_add],
  refine congr_arg2 _ (congr_arg2 _ _ _) _; congr' 2,
  { rw eval_free_π_eq, refl, },
  { rw eval_free_π_eq, refl, },
  { rw [eval_free_σ, eval_free_π_eq, eval_free_π_eq],
    apply biproduct.hom_ext, rintro ⟨j⟩, fin_cases j, simp only [add_comp, biproduct.matrix_π],
    erw [biproduct.matrix_π, biproduct.matrix_π],
    apply biproduct.hom_ext', rintro ⟨i⟩, simp only [comp_add, biproduct.ι_desc, ← add_smul],
    refl }
end

def Pow_1_iso (A : AddCommGroup.{u}) : (preadditive.Pow 1).obj A ≅ A :=
{ hom := biproduct.π (λ _, A) (ulift.up 0),
  inv := biproduct.ι (λ _, A) (ulift.up 0),
  hom_inv_id' := begin
    erw [← biproduct.total, ← equiv.ulift.symm.sum_comp, fin.sum_univ_one], refl,
  end,
  inv_hom_id' := by simp only [biproduct.ι_π, dif_pos rfl, eq_to_hom_refl] }

def Pow_2_iso (A : AddCommGroup.{u}) : (preadditive.Pow 2).obj A ≅ AddCommGroup.of (A × A) :=
{ hom := add_monoid_hom.prod (biproduct.π (λ _, A) (ulift.up 0)) (biproduct.π (λ _, A) (ulift.up 1)),
  inv := add_monoid_hom.coprod (biproduct.ι (λ _, A) (ulift.up 0)) (biproduct.ι (λ _, A) (ulift.up 1)),
  hom_inv_id' := begin
    ext x, erw [← biproduct.total, ← equiv.ulift.symm.sum_comp, comp_apply],
    swap, apply_instance,
    dsimp only [add_monoid_hom.coprod_apply, add_monoid_hom.prod_apply],
    simp only [← comp_apply, fin.sum_univ_two], refl,
  end,
  inv_hom_id' := begin
    ext1 x, rw [comp_apply, id_apply],
    dsimp only [add_monoid_hom.coprod_apply, add_monoid_hom.prod_apply],
    simp only [add_monoid_hom.map_add, ← comp_apply, biproduct.ι_π, dif_pos rfl, eq_to_hom_refl, id_apply],
    rw [dif_neg], swap, dec_trivial,
    rw [dif_neg], swap, dec_trivial,
    erw [add_zero, zero_add], cases x, refl,
  end }
.

lemma eval_free_π_eq_fst (A : AddCommGroup.{u}) :
  (Pow_2_iso A).inv ≫ eval_free_π A 0 ≫ (Pow_1_iso A).hom =
  AddCommGroup.of_hom (add_monoid_hom.fst A A) :=
begin
  ext x, simp only [comp_apply],
  dsimp only [Pow_2_iso, Pow_1_iso, eval_free_π, add_monoid_hom.coprod_apply],
  simp only [← comp_apply, category.assoc, biproduct.ι_π, dif_pos rfl, eq_to_hom_refl,
    category.comp_id, add_monoid_hom.map_add, id_apply],
  erw [dif_neg, add_zero], refl, dec_trivial,
end

lemma eval_free_π_eq_snd (A : AddCommGroup.{u}) :
  (Pow_2_iso A).inv ≫ eval_free_π A 1 ≫ (Pow_1_iso A).hom =
  AddCommGroup.of_hom (add_monoid_hom.snd A A) :=
begin
  ext x, simp only [comp_apply],
  dsimp only [Pow_2_iso, Pow_1_iso, eval_free_π, add_monoid_hom.coprod_apply],
  simp only [← comp_apply, category.assoc, biproduct.ι_π, dif_pos rfl, eq_to_hom_refl,
    category.comp_id, add_monoid_hom.map_add, id_apply],
  erw [dif_neg, zero_add], refl, dec_trivial,
end

lemma eval_free_σ_eq_add (A : AddCommGroup.{u}) :
  (Pow_2_iso A).inv ≫ eval_free_σ A ≫ (Pow_1_iso A).hom =
  AddCommGroup.of_hom (add_monoid_hom.coprod (add_monoid_hom.id _) (add_monoid_hom.id _)) :=
by { simp only [eval_free_σ, add_comp, comp_add, eval_free_π_eq_fst, eval_free_π_eq_snd], refl, }

lemma eval_free_homology_zero_exact (A : AddCommGroup.{u}) :
  exact
  ((((data.eval_functor (forget _ ⋙ AddCommGroup.free)).obj breen_deligne.eg.data).obj A).d 1 0)
  ((forget _ ⋙ AddCommGroup.free).map (Pow_1_iso A).hom ≫ AddCommGroup.of_hom (free_abelian_group.lift id)) :=
begin
  let F := forget _ ⋙ AddCommGroup.free,
  refine exact_of_iso_of_exact' _ _ _ _
    (F.map_iso (Pow_2_iso A).symm) (F.map_iso (Pow_1_iso A).symm) (iso.refl _) _ _
    (free_abelian_group.exact_σπ A),
  swap,
  { dsimp only [functor.map_iso_hom, iso.symm_hom, iso.refl_hom, F],
    rw [category.comp_id, ← functor.map_iso_inv, ← functor.map_iso_hom, iso.inv_hom_id_assoc], },
  rw [← iso.comp_inv_eq, category.assoc, eval_free_d10],
  simp only [comp_add, add_comp, comp_sub, sub_comp],
  refine congr_arg2 _ (congr_arg2 _ _ _) _,
  { simp only [functor.map_iso_hom, functor.map_iso_inv, iso.symm_hom, iso.symm_inv,
      ← functor.map_comp, eval_free_π_eq_fst], refl },
  { simp only [functor.map_iso_hom, functor.map_iso_inv, iso.symm_hom, iso.symm_inv,
      ← functor.map_comp, eval_free_π_eq_snd], refl },
  { simp only [functor.map_iso_hom, functor.map_iso_inv, iso.symm_hom, iso.symm_inv,
      ← functor.map_comp, eval_free_σ_eq_add], refl },
end

instance eval_free_homology_zero_epi (A : AddCommGroup.{u}) :
  epi ((forget _ ⋙ AddCommGroup.free).map (Pow_1_iso A).hom ≫ AddCommGroup.of_hom (free_abelian_group.lift id)) :=
begin
  apply_with epi_comp {instances:=ff}, apply_instance,
  rw [AddCommGroup.epi_iff_surjective], intro a,
  exact ⟨free_abelian_group.of a, free_abelian_group.lift.of _ _⟩
end

open_locale zero_object

section

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
variables {A B C X : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (γ : B ⟶ X)

def of_epi_g (hfg : exact f g) (hg : epi g) (hγ : γ = 0) :
  homology_iso_datum f γ C :=
{ w := by rw [hγ, comp_zero],
  K := B,
  ι := 𝟙 B,
  f' := f,
  fac' := category.comp_id _,
  zero₁' := by rw [hγ, comp_zero],
  π := g,
  zero₂' := hfg.w,
  fork_is_limit := is_limit_aux _ (λ s, s.ι) (λ s, by apply category.comp_id)
      (λ s m hm, begin rw [← hm], symmetry, apply category.comp_id, end),
  cofork_is_colimit := @abelian.is_colimit_of_exact_of_epi _ _ _ _ _ _ _ _ hg hfg }

@[simp] lemma of_epi_g.to_homology_iso_predatum_π
  (hfg : exact f g) (hg : epi g) (hγ : γ = 0) :
  (of_epi_g f g γ hfg hg hγ).to_homology_iso_predatum.π = g := rfl

end

def nat_trans_eval_free :
  ((data.eval_functor (forget _ ⋙ AddCommGroup.free.{u})).obj breen_deligne.eg.data) ⋙
    homological_complex.eval _ _ 0 ⟶ 𝟭 AddCommGroup :=
{ app := λ A, (forget _ ⋙ AddCommGroup.free).map (Pow_1_iso A).hom ≫
    AddCommGroup.of_hom (free_abelian_group.lift id),
  naturality' := λ A₁ A₂ f, begin
    simp only [functor.comp_map, homological_complex.eval_map, data.eval_functor_obj_map_f,
      forget_map_eq_coe, AddCommGroup.free_map, functor.id_map, category.assoc],
    ext x,
    dsimp [eg, eg.BD, eg.rank] at x,
    have h : ∃ y, x = (Pow_1_iso A₁).inv y,
    { use (Pow_1_iso A₁).hom x,
      rw [← comp_apply, iso.hom_inv_id, id_apply], },
    cases h with y hy,
    subst hy,
    simp only [comp_apply, free_abelian_group.map_of_apply, AddCommGroup.of_hom_apply,
      free_abelian_group.lift.of, id.def, iso.inv_hom_id_apply, biproduct.map_eq],
    let z : fin (eg.data.X 0) := ⟨0, begin
      dsimp [eg, eg.BD, eg.rank],
      linarith,
    end⟩,
    rw finset.sum_eq_single (ulift.up z), rotate,
    { intros b hb₁ hb₂,
      exfalso,
      apply hb₂,
      cases b,
      simp only [ulift.up_inj],
      rw fin.eq_mk_iff_coe_eq,
      have hb₃ := b.is_lt,
      dsimp [eg, eg.BD, eg.rank] at hb₃,
      linarith, },
    { intro h,
      exfalso,
      apply h,
      simp only [finset.mem_univ], },
    simp only [← comp_apply, category.assoc],
    congr' 1,
    dsimp,
    change _ ≫ (Pow_1_iso A₁).hom ≫ _ ≫ (Pow_1_iso A₂).inv ≫ _ = _,
    rw [iso.inv_hom_id, iso.inv_hom_id_assoc, category.comp_id],
  end, }

def short_complex_nat_trans_eval_free :
  ((data.eval_functor (forget _ ⋙ AddCommGroup.free)).obj breen_deligne.eg.data)
    ⋙ short_complex.functor_homological_complex _ _ 0 ⟶ short_complex.ι_middle :=
begin
  refine short_complex.nat_trans_hom_mk 0 nat_trans_eval_free 0 _
    (begin apply is_zero.eq_of_tgt, apply short_complex.ι_middle_π₃_is_zero, end),
  ext1, ext1 A,
  simp only [zero_comp, nat_trans.app_zero, nat_trans.hcomp_app, nat_trans.comp_app,
    nat_trans.id_app, short_complex.π₂.map_id, category.comp_id],
  dsimp only [short_complex.φ₁₂, short_complex.functor_homological_complex, functor.comp_obj,
    short_complex.mk],
  simp only [@homological_complex.d_to_eq _ _ _ _ (complex_shape.down ℕ) _ _ 1 0 (zero_add 1),
    category.assoc],
  erw [(eval_free_homology_zero_exact A).w, comp_zero],
end

lemma short_complex_nat_trans_eval_free_app_τ₂ (A : AddCommGroup) :
  (short_complex_nat_trans_eval_free.app A).τ₂ = nat_trans_eval_free.app A := rfl

def eval_free_homology_zero_nat_trans :=
short_complex_nat_trans_eval_free ◫ (𝟙 short_complex.homology_functor)

lemma _root_.short_complex.homology_map_is_iso_of_exact_and_epi
  {A : Type*} [category A] [abelian A]
  {S₁ S₂ : short_complex A} (φ : S₁ ⟶ S₂) (hg₁ : S₁.1.g = 0) (hf₂ : S₂.1.f = 0) (hg₂ : S₂.1.g = 0)
  (ex : exact S₁.1.f φ.τ₂) (epi_τ₂ : epi φ.τ₂) :
  is_iso (short_complex.homology_functor.map φ) :=
begin
  let h₁ := homology_iso_datum.of_g_is_zero S₁.1.f S₁.1.g hg₁,
  let h₂ := homology_iso_datum.of_both_zeros S₂.1.f S₂.1.g hf₂ hg₂,
  let ψ := cokernel.desc _ φ.τ₂ ex.w,
  let μ : homology_map_datum φ h₁ h₂ ψ :=
  { κ := φ.τ₂,
    fac₁' := by { erw [φ.comm₁₂], simp only [hf₂], refl, },
    fac₂' := by { erw [category.id_comp, category.comp_id], },
    fac₃' := by { erw [category.comp_id], apply cokernel.π_desc, }, },
  rw μ.homology_map_eq,
  suffices : is_iso ψ,
  { haveI := this, apply_instance, },
  exact abelian.category_theory.limits.cokernel.desc.category_theory.is_iso _ _ ex,
end

instance : is_iso eval_free_homology_zero_nat_trans.{u} :=
begin
  suffices : ∀ A, is_iso ((short_complex_nat_trans_eval_free ◫
    (𝟙 short_complex.homology_functor)).app A),
  { apply_with nat_iso.is_iso_of_is_iso_app { instances := ff }, exact this, },
  intro A,
  simp only [nat_trans.hcomp_id_app],
  refine short_complex.homology_map_is_iso_of_exact_and_epi _ _ rfl rfl _ _,
  { apply is_zero.eq_of_tgt,
    refine is_zero.of_iso (is_zero_zero _) _,
    apply homological_complex.X_next_iso_zero,
    rcases h : (complex_shape.down ℕ).next 0 with _ | ⟨i, hi⟩,
    { refl, },
    { exfalso,
      change i+1=0 at hi,
      simpa only using hi, }, },
  { refine exact_of_iso_of_exact' _ _ _ _ _ _ _ _ _ (eval_free_homology_zero_exact A),
    { symmetry,
      exact (homological_complex.X_prev_iso _ (zero_add 1)), },
    { refl, },
    { apply eq_to_iso, cases A, refl, },
    { dsimp only [short_complex.functor_homological_complex, functor.comp_obj,
        short_complex.mk],
      rw homological_complex.d_to_eq, swap 3, exact 1, swap, dsimp, refl,
      simp only [iso.symm_hom, iso.refl_hom, category.comp_id],
      apply iso.inv_hom_id_assoc, },
    { apply category.id_comp, }, },
  { rw short_complex_nat_trans_eval_free_app_τ₂,
    dsimp [nat_trans_eval_free],
    convert eval_free_homology_zero_epi.{u} A,
    cases A,
    refl, },
end

def eval_free_homology_zero :
  ((data.eval_functor (forget _ ⋙ AddCommGroup.free)).obj breen_deligne.eg.data) ⋙
    homology_functor _ _ 0 ≅ 𝟭 _ :=
  iso_whisker_left _ (short_complex.homology_functor_iso _ _ _) ≪≫
    (functor.associator _ _ _).symm ≪≫ as_iso eval_free_homology_zero_nat_trans ≪≫
    short_complex.ι_middle_homology_nat_iso.symm

end

open bounded_homotopy_category

namespace Condensed

def HQ'Z (n : ℤ) : Ab :=
((eg.eval $ category_theory.forget AddCommGroup ⋙ AddCommGroup.free).obj
  (AddCommGroup.free.obj punit)).val.as.homology n

variables (BD : package)

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : abelian (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
endomorphisms.category_theory.abelian

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_finite_biproducts (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
abelian.has_finite_biproducts

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : enough_projectives (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
endomorphisms.category_theory.enough_projectives

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_coproducts_of_shape (ulift.{u+1} ℕ) (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
endomorphisms.has_colimits_of_shape

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_products_of_shape (ulift ℕ) (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
endomorphisms.has_limits_of_shape

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_coproducts (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
λ (J : Type (u+1)), endomorphisms.has_colimits_of_shape

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : AB4 (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
endomorphisms.category_theory.AB4 _

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_finite_limits (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
abelian.has_finite_limits

-- `by apply_instance` takes for ever, so we provide this shortcut
instance : has_finite_colimits (endomorphisms $ Condensed.{u} Ab.{u+1}) :=
abelian.has_finite_colimits
.

-- move this
attribute [reassoc] homology_bd_eval_natural

def exists_tensor_iso (A : endomorphisms (Condensed.{u} Ab.{u+1}))
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.X.val.obj (op S.val))]
  (n : ℕ) :
  ((package.endo_T tensor_functor).obj A).obj (HQ'Z (-n)) ≅
      ((eg.eval freeCond'.map_endomorphisms).obj A).val.as.homology (-n) :=
begin
  refine endomorphisms.mk_iso _ _,
  { refine _ ≪≫ ((package.hH_endo₁ eg freeCond' n).app A).symm,
    refine (homology_bd_eval eg A.X (-n)).symm ≪≫ _,
    exact (package.eval'_homology eg freeCond' n).app A.X, },
  { dsimp only [iso.trans_hom, iso.symm_hom, package.endo_T_obj_obj_e, tensor_functor, HQ'Z],
    simp only [category.assoc, ← homology_bd_eval_natural_assoc],
    refine congr_arg2 _ rfl _,
    dsimp only [iso.app_hom, iso.app_inv],
    rw [← functor.comp_map, nat_trans.naturality_assoc],
    refine congr_arg2 _ rfl _,
    dsimp only [← iso.app_inv],
    rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp],
    exact (eg.hH_endo₁_natural freeCond' A n).symm, }
end
.

-- move this
lemma is_tensor_unit_of_iso (A B : Ab) (e : A ≅ B) (ha : AddCommGroup.is_tensor_unit A) :
  AddCommGroup.is_tensor_unit B :=
begin
  obtain ⟨a, ha⟩ := ha,
  refine ⟨e.hom a, _⟩,
  intro C, specialize ha C,
  let φ := iso.AddCommGroup_iso_to_add_equiv ((preadditive_yoneda.obj C).map_iso e.op),
  exact ha.comp φ.bijective,
end

lemma bd_lemma (A : Condensed.{u} Ab.{u+1}) (B : Condensed.{u} Ab.{u+1})
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))]
  (f : A ⟶ A) (g : B ⟶ B) :
  (∀ i, is_iso $ ((Ext' i).map f.op).app B - ((Ext' i).obj (op A)).map g) ↔
  (∀ i, is_iso $
    ((Ext i).map ((breen_deligne.eg.eval freeCond').map f).op).app ((single _ 0).obj B) -
    ((Ext i).obj (op $ (breen_deligne.eg.eval freeCond').obj A)).map ((single _ 0).map g)) :=
begin
  apply eg.main_lemma_general' _ A B f g tensor_functor tensor_punit (λ n, HQ'Z (-n)),
  { apply tensor_tunit,
    apply is_tensor_unit_of_iso
      (AddCommGroup.free.obj punit) (HQ'Z 0),
    { let e := (eval_free_homology_zero.app (AddCommGroup.free.obj punit)).symm,
      refine e ≪≫ _, clear e,
      let e := (package.eval'_homology eg (forget AddCommGroup ⋙ AddCommGroup.free) 0).symm,
      exact e.app (AddCommGroup.free.obj punit), },
    { refine ⟨free_abelian_group.of punit.star, _⟩,
      intro B, split,
      { intros f g h, ext ⟨⟩, exact h },
      { intros b, refine ⟨free_abelian_group.lift (λ _, b), _⟩,
        apply free_abelian_group.lift.of } } },
  { apply exists_tensor_iso }
end

end Condensed


import Mt.Thread.Traced
import Mt.System.Basic
import Mt.System.BasicAux
import Mt.Utils.List

namespace Mt.Traced

structure TracedSystem (spec : Spec) where
  state   : spec.State
  threads : List (TracedThread spec)

namespace TracedSystem

variable {spec : Spec}

local instance : IsReservation spec.Reservation :=spec.is_reservation

def ThreadIndex (s : TracedSystem spec) : Type :=Fin s.threads.length
def done (s : TracedSystem spec) : Bool :=s.threads.length = 0

def iterate (s : TracedSystem spec) (idx : s.ThreadIndex) : Thread.IterationResult spec :=
  (s.threads.get idx).iterate s.state

def update_thread (s : TracedSystem spec) (idx : Nat) (state : spec.State)
  (r : spec.Reservation) (cont : Thread spec) : TracedSystem spec :={
  state
  threads :=s.threads.set idx ⟨cont, r⟩
}

def remove_thread (s : TracedSystem spec) (idx : Nat) (state : spec.State)
  : TracedSystem spec :={
  state
  threads :=s.threads.eraseIdx idx
}

def reservations (s : TracedSystem spec) : spec.Reservation :=
  s.threads.foldl (λ env_r thread => env_r + thread.reservation) spec.is_reservation.empty

def other_reservations (s : TracedSystem spec) (idx : Nat) : spec.Reservation :=
  (s.threads.eraseIdx idx).foldl (λ env_r thread => env_r + thread.reservation) spec.is_reservation.empty

theorem decompose_reservations (s : TracedSystem spec) (idx : s.ThreadIndex) :
  s.reservations = s.other_reservations idx.val + (s.threads.get idx).reservation :=
  System.Traced.decompose_reservation s.threads idx _ rfl

structure valid (s : TracedSystem spec) : Prop where
  currently_valid : spec.validate s.reservations s.state
  threads_valid : ∀ t, t ∈ s.threads → t.valid

def to_system (s : TracedSystem spec) : System spec :={
  state := s.state
  threads := s.threads.map λ ⟨t, _⟩ => t
  panics := 0
}

def mk_initial (s : System spec) : TracedSystem spec :={
  state := s.state
  threads := s.threads.map λ t => ⟨t, IsReservation.empty⟩
}

theorem mk_initial.valid (s : System spec)
  (initial_valid : spec.validate IsReservation.empty s.state)
  (threads_valid : ∀ t, t ∈ s.threads → t.valid)
  : (mk_initial s).valid :=by
  constructor
  . simp only [mk_initial]
    induction s.threads
    . exact initial_valid
    . rename_i head tail IH
      simp only [List.map, Traced.TracedSystem.reservations, List.foldl, IsReservation.empty_add]
      exact IH
  . intro t t_hyp
    simp only [mk_initial] at t_hyp
    cases Utils.List.eq_of_in_map t_hyp
    rename_i t_orig t_orig_hyp
    rw [t_orig_hyp.right]
    exact threads_valid t_orig t_orig_hyp.left

theorem mk_initial.cancels_to_system {s : System spec}
  (no_panics_yet : s.panics = 0)
  :
  (mk_initial s).to_system = s :=by
  simp only [mk_initial, to_system]
  rw [System.mk.injEq]
  constructor
  . rfl
  constructor
  . induction s.threads
    . rfl
    . rename_i head tail IH
      simp only [List.map]
      rw [IH]
  . exact no_panics_yet.symm

theorem valid_by_iteration (s s' : System spec)
  {idx : s.ThreadIndex}
  {ts : TracedSystem spec}
  (has_traced_system : s = ts.to_system)
  (ts_valid : ts.valid)
  (iteration : s.iterate idx = s')
  : ∃ ts' : TracedSystem spec,
    ts'.to_system = s' ∧ ts'.valid :=by

  simp only [System.iterate] at iteration
  cases blocked_until : (s.threads.get idx).block_until s.state
  <;> simp only [blocked_until, ite_true, ite_false] at iteration
  . exists ts
    simp only [<- iteration, has_traced_system, ts_valid]

  have ts_state_eq : ts.state = s.state :=by rw [has_traced_system] ; rfl

  let idx' : ts.ThreadIndex :=Utils.Fin.cast idx (by
    rw [has_traced_system]
    exact List.length_map ..)
  have get_idx' : (ts.threads.get idx').thread = s.threads.get idx :=by
    have :=congrArg System.threads has_traced_system
    rw [Utils.List.get_congr idx this]
    simp only [to_system, Utils.List.get_of_map]
    rfl

  let env_r :=ts.other_reservations idx.val
  have decompose : ts.reservations = env_r + _ :=ts.decompose_reservations idx'

  have t_valid :=TracedThread.valid_elim
    (ts_valid.threads_valid (ts.threads.get idx') (Utils.List.get_in ..))
    env_r s.state
    (by
      simp only [TracedThread.block_until, get_idx']
      exact blocked_until)
    (by
      rw [<- decompose, <- ts_state_eq]
      exact ts_valid.currently_valid)
  cases t_valid
  rename_i r' t_valid
  rw [TracedThread.iterate, get_idx'] at t_valid

  cases h : (s.threads.get idx).iterate s.state
  <;> simp only [h] at iteration
  <;> simp only [h] at t_valid

  . rename_i state
    exists ts.remove_thread idx.val state
    rw [<- iteration] ; clear iteration s'
    simp only [remove_thread]
    constructor
    . simp only [to_system, has_traced_system, System.mk.injEq, and_true, true_and]
      exact Utils.List.erase_map_commutes ..
    . rw [t_valid.right, IsReservation.toIsCommutative.comm, IsReservation.empty_add] at t_valid
      constructor
      . exact t_valid.left
      . intro t (t_hyp : t ∈ ts.threads.eraseIdx idx.val)
        exact ts_valid.threads_valid t <| Utils.List.erase_subset _ _ t_hyp
  . rename_i state cont
    exists ts.update_thread idx.val state r' cont
    rw [<- iteration] ; clear iteration s'
    simp only [update_thread]
    constructor
    . simp only [to_system, System.mk.injEq, true_and, has_traced_system, and_true]
      exact Utils.List.set_map_commutes ..
    . constructor
      . let ts' :=ts.update_thread idx.val state r' cont
        show spec.validate ts'.reservations ts'.state

        let idx'' : ts'.ThreadIndex :=⟨idx.val, by calc
          idx.val < ts.threads.length :=idx'.isLt
                _ = ts'.threads.length :=Eq.symm <| List.length_set ..⟩
        have decompose' :=ts'.decompose_reservations idx''

        conv at decompose' =>
          rhs
          conv =>
            arg 1
            simp only [other_reservations, update_thread, Utils.List.erase_set]
          conv =>
            arg 2
            simp only [update_thread, Utils.List.get_of_set]
          arg 1
          change env_r

        rw [decompose']
        exact t_valid.left
      . intro t (t_hyp : t ∈ ts.threads.set idx.val ⟨cont, r'⟩)
        cases Utils.List.set_subset _ _ _ t_hyp <;> rename_i t_hyp
        . rw [t_hyp]
          exact t_valid.right
        . exact ts_valid.threads_valid t t_hyp

end TracedSystem

end Mt.Traced


import Radon.setup

open_locale nnreal big_operators classical

noncomputable theory

open category_theory
open category_theory.limits
open topological_space

local attribute [instance]
  locally_constant.seminormed_add_comm_group
  locally_constant.pseudo_metric_space

namespace Profinite

/--
The space of signed `p`-Radon measures on `X`, bounded by `c`.
-/
@[derive topological_space]
def Radon (X : Profinite.{0}) (p c : ℝ≥0) :
  Top.{0} :=
Top.of { μ : weak_dual ℝ C(X,ℝ) // μ.bdd p c }

/--
The space of signed `p`-Radon measures on `X`, bounded by `c`.
This is a variant of `Radon` which uses the dual of locally constant functions
as opposed to continuous functions, to be used an an auxiliary declaration in the
constructions below.
-/
@[derive topological_space]
def Radon_LC (X : Profinite.{0}) (p c : ℝ≥0) :
  Top.{0} :=
Top.of { μ : weak_dual ℝ (locally_constant X ℝ) // μ.bdd_LC p c }

/--
A continuous map `X → Y` induces a map between spaces of `p`-Radon measures
with a given bound.
-/
def map_Radon {X Y : Profinite.{0}} (f : X ⟶ Y)
  (p c : ℝ≥0) [fact (0 < p)] :
  X.Radon p c ⟶ Y.Radon p c :=
{ to_fun := λ μ, ⟨weak_dual.comap f.comap μ.1,
    weak_dual.bdd_comap _ μ.2 _⟩,
  continuous_to_fun := begin
    apply continuous.subtype_mk,
    refine continuous.comp _ continuous_subtype_coe,
    exact continuous_linear_map.continuous _,
  end }

/--
A continuous map `X → Y` induces a map between spaces of `p`-Radon measures
with a given bound. (This is the locally constant variant.)
-/
def map_Radon_LC {X Y : Profinite.{0}} (f : X ⟶ Y)
  (p c : ℝ≥0) [fact (0 < p)] :
  X.Radon_LC p c ⟶ Y.Radon_LC p c :=
{ to_fun := λ μ, ⟨weak_dual.comap f.comap_LC μ.1,
    weak_dual.bdd_LC_comap _ μ.2 _⟩,
  continuous_to_fun := begin
    apply continuous.subtype_mk,
    refine continuous.comp _ continuous_subtype_coe,
    exact continuous_linear_map.continuous _,
  end }

/--
The functor sending a topological space to the space of `p`-Radon
measures bounded by `c`.
-/
def Radon_functor (p c : ℝ≥0) [fact (0 < p)] :
  Profinite.{0} ⥤ Top.{0} :=
{ obj := λ X, X.Radon p c,
  map := λ X Y f, map_Radon f _ _,
  map_id' := λ X, by { ext, dsimp [map_Radon, weak_dual.comap], congr' 1,
    ext, refl },
  map_comp' := λ X Y Z f g, by { ext, refl } }

/--
The functor sending a topological space to the space of `p`-Radon
measures bounded by `c`. This is the locally constant variant.
-/
def Radon_LC_functor (p c : ℝ≥0) [fact (0 < p)] :
  Profinite.{0} ⥤ Top.{0} :=
{ obj := λ X, X.Radon_LC p c,
  map := λ X Y f, map_Radon_LC f _ _,
  map_id' := λ X,
    by { ext, dsimp [map_Radon_LC, weak_dual.comap], congr' 1, ext, refl },
  map_comp' := λ X Y Z f g, by { ext, refl } }

/--
An auxiliary definition to be used in the constructions below.
-/
def weak_dual_C_to_LC (X : Profinite.{0}) :
  weak_dual ℝ C(X,ℝ) →L[ℝ] weak_dual ℝ (locally_constant X ℝ) :=
weak_dual.comap $ lc_to_c _

lemma dense_range_coe₂ (X : Profinite.{0}) :
  dense_range (λ p : locally_constant X ℝ × locally_constant X ℝ,
    (lc_to_c X p.1, lc_to_c X p.2)) :=
begin
  letI : uniform_space (locally_constant.pkg X ℝ).space :=
    (locally_constant.pkg X ℝ).uniform_struct,
  exact (locally_constant.pkg X ℝ).dense.prod_map (locally_constant.pkg X ℝ).dense
end

/--
An auxiliary definition to be used in the constructions below.
-/
def weak_dual_LC_to_C (X : Profinite.{0}) :
  weak_dual ℝ (locally_constant X ℝ) →ₗ[ℝ] weak_dual ℝ C(X,ℝ) :=
{ to_fun := λ f,
  { to_fun := (locally_constant.pkg X ℝ).extend f,
    map_add' := begin
      letI : uniform_space (locally_constant.pkg X ℝ).space :=
        (locally_constant.pkg X ℝ).uniform_struct,
      letI : add_group (locally_constant.pkg X ℝ).space :=
        continuous_map.add_group,
      letI : topological_add_group (locally_constant.pkg X ℝ).space :=
        continuous_map.topological_add_group,
      rw ← prod.forall',
      refine is_closed_property (dense_range_coe₂ X) _ _,
      { apply is_closed_eq,
        { refine (locally_constant.pkg X ℝ).continuous_extend.comp continuous_add },
        { refine continuous.add _ _;
          refine (locally_constant.pkg X ℝ).continuous_extend.comp _,
          exact continuous_fst,
          exact continuous_snd } },
      { rintro ⟨φ, ψ⟩, dsimp only,
        have hf := continuous_linear_map.uniform_continuous f,
        rw [← (lc_to_c X).map_add],
        erw [(locally_constant.pkg X ℝ).extend_coe hf, (locally_constant.pkg X ℝ).extend_coe hf,
          (locally_constant.pkg X ℝ).extend_coe hf, map_add], }
    end,
    map_smul' := begin
      letI : uniform_space (locally_constant.pkg X ℝ).space :=
        (locally_constant.pkg X ℝ).uniform_struct,
      letI : add_group (locally_constant.pkg X ℝ).space :=
        continuous_map.add_group,
      letI : topological_add_group (locally_constant.pkg X ℝ).space :=
        continuous_map.topological_add_group,
      letI : has_smul ℝ (locally_constant.pkg X ℝ).space :=
        continuous_map.has_smul,
      letI : has_continuous_smul ℝ (locally_constant.pkg X ℝ).space :=
        continuous_map.has_continuous_smul,
      intros r φ,
      apply (locally_constant.pkg X ℝ).induction_on φ; clear φ,
      { apply is_closed_eq,
        { refine (locally_constant.pkg X ℝ).continuous_extend.comp
            (continuous_const.smul continuous_id), },
        { refine continuous_const.smul (locally_constant.pkg X ℝ).continuous_extend } },
      { intro φ,
        have hf := continuous_linear_map.uniform_continuous f,
        erw [← (lc_to_c X).map_smul, (locally_constant.pkg X ℝ).extend_coe hf,
          (locally_constant.pkg X ℝ).extend_coe hf, map_smul],
        refl }
    end,
    cont := (locally_constant.pkg X ℝ).continuous_extend },
  map_add' := begin
    letI : uniform_space (locally_constant.pkg X ℝ).space :=
      (locally_constant.pkg X ℝ).uniform_struct,
    intros f g, ext ff, dsimp,
    apply (locally_constant.pkg X ℝ).induction_on ff,
    { apply is_closed_eq,
      apply (locally_constant.pkg X ℝ).continuous_extend, apply_instance,
      let G : C(X,ℝ) → ℝ × ℝ := λ ff,
        ((locally_constant.pkg X ℝ).extend f ff, (locally_constant.pkg X ℝ).extend g ff),
      change continuous ((λ a : ℝ × ℝ, a.1 + a.2) ∘ G),
      refine continuous.comp continuous_add _,
      apply continuous.prod_mk,
      apply (locally_constant.pkg X ℝ).continuous_extend, apply_instance,
      apply (locally_constant.pkg X ℝ).continuous_extend, apply_instance },
    { intros a,
      rw [(locally_constant.pkg X ℝ).extend_coe],
      rw [(locally_constant.pkg X ℝ).extend_coe],
      rw [(locally_constant.pkg X ℝ).extend_coe],
      refl,
      any_goals { apply continuous_linear_map.uniform_continuous },
      any_goals { apply_instance } },
  end,
  map_smul' := begin
    letI : uniform_space (locally_constant.pkg X ℝ).space :=
      (locally_constant.pkg X ℝ).uniform_struct,
    intros r f, ext ff, dsimp,
    apply (locally_constant.pkg X ℝ).induction_on ff,
    { apply is_closed_eq,
      apply (locally_constant.pkg X ℝ).continuous_extend, apply_instance,
      refine continuous.comp (continuous_mul_left r) _,
      apply (locally_constant.pkg X ℝ).continuous_extend, apply_instance },
    { intros a,
      rw [(locally_constant.pkg X ℝ).extend_coe],
      rw [(locally_constant.pkg X ℝ).extend_coe],
      refl,
      any_goals { apply_instance },
      exact f.uniform_continuous,
      exact (r • f).uniform_continuous },
  end }

end Profinite


import ReactorModel.Objects.Reactor.Indexable

namespace ReactorType

open Indexable

-- About the `↔`-condition in `prio`:  We want to establish a dependency between mutations with
-- priorities as well normal reactions with priorities, but not between normal reactions and
-- mutations. Otherwise a normal reaction might take precedence over a mutation. Also the precedence
-- of mutations over normal reactions is handled by `mutNorm`, so this would potentially create a
-- redundancy.
--
-- Note: `Dependency rtr i₁ i₂` means that in `i₁` must occur before `i₂`.
inductive Dependency [Indexable α] (rtr : α) : ID → ID → Prop
  | prio :
    (rtr[.rtr][i] = some con) → (rcns con i₁ = some rcn₁) → (rcns con i₂ = some rcn₂) →
    (rcn₁.Mutates ↔ rcn₂.Mutates) → (rcn₁.prio > rcn₂.prio) → Dependency rtr i₁ i₂
  | depOverlap {d : Reaction.Dependency} :
    (rtr[.rcn][i₁] = some rcn₁) → (rtr[.rcn][i₂] = some rcn₂) → (d ∈ rcn₁.deps .out) →
    (d ∈ rcn₂.deps .in) → (d.cpt ≠ .stv) → Dependency rtr i₁ i₂
  | mutNorm :
    (rtr[.rtr][i] = some con) → (rcns con iₘ = some m) → (rcns con iₙ = some n) → (m.Mutates) →
    (n.Normal) → Dependency rtr iₘ iₙ
  | mutNest :
    (rtr[.rtr][i] = some rtr₁) → (nest rtr₁ j = some rtr₂) → (rcns rtr₁ iₘ = some m) → (m.Mutates) →
    (iᵣ ∈ rcns rtr₂) → Dependency rtr iₘ iᵣ
  | trans :
    Dependency rtr i₁ i₂ → Dependency rtr i₂ i₃ → Dependency rtr i₁ i₃

notation i₁ " <[" rtr "] " i₂ => Dependency rtr i₁ i₂

def Dependency.Acyclic [Indexable α] (rtr : α) : Prop :=
  ∀ i, ¬(i <[rtr] i)

namespace Wellformed

-- `ValidDependency rtr rk dk d` means that in reactor `rtr`, reactions of kind `rk` can have `d` as
-- a valid dependency target of kind `dk`. For example `ValidDependency rtr .mut .out (.port .in i)`
-- states that mutations can specify the input port identified by `i` as effect and
-- `ValidDependency rtr .norm .in (.action i)` states that normal reactions can specify the action
-- identified by `i` as source.
inductive ValidDependency [ReactorType α] (rtr : α) :
    Reaction.Kind → Kind → Reaction.Dependency → Prop
  | stv       : (i ∈ state rtr) → ValidDependency rtr _ _ ⟨.stv, i⟩
  | act       : (i ∈ acts rtr) → ValidDependency rtr _ _ ⟨.act, i⟩
  | prt       : (i ∈ ports rtr dk) → ValidDependency rtr _ dk ⟨.prt k, i⟩
  | nestedIn  : (nest rtr j = some con) → (i ∈ ports con .in) →
                ValidDependency rtr _ .out ⟨.prt .in, i⟩
  | nestedOut : (nest rtr j = some con) → (i ∈ ports con .out) →
                ValidDependency rtr .norm .in ⟨.prt .in, i⟩

variable [Indexable α] [Indexable β] {rtr rtr₁ : α}

-- TODO: Refactor the `prio` conditions into one.
structure _root_.ReactorType.Wellformed (rtr : α) : Prop where
  unique_inputs : (rtr[.rcn][i₁] = some rcn₁) → (rtr[.rcn][i₂] = some rcn₂) → (i₁ ≠ i₂) →
                  (i ∈ rtr[.prt .in]) → (⟨.prt .in, i⟩ ∈ rcn₁.deps .out) →
                  (⟨.prt .in, i⟩ ∉ rcn₂.deps .out)
  overlap_prio  : (rtr[.rtr][i] = some con) → (rcns con i₁ = some rcn₁) →
                  (rcns con i₂ = some rcn₂) → (i₁ ≠ i₂) →
                  (rcn₁.deps .out ∩ rcn₂.deps .out).Nonempty →
                  (rcn₁.prio < rcn₂.prio ∨ rcn₂.prio < rcn₁.prio)
  hazards_prio  : (rtr[.rtr][i] = some con) → (rcns con i₁ = some rcn₁) →
                  (rcns con i₂ = some rcn₂) → (i₁ ≠ i₂) → (⟨.stv, s⟩ ∈ rcn₁.deps k₁) →
                  (⟨.stv, s⟩ ∈ rcn₂.deps k₂) → (k₁ = .out ∨ k₂ = .out) →
                  (rcn₁.prio < rcn₂.prio ∨ rcn₂.prio < rcn₁.prio)
  mutation_prio : (rtr[.rtr][i] = some con) → (rcns con i₁ = some rcn₁) →
                  (rcns con i₂ = some rcn₂) → (i₁ ≠ i₂) → (rcn₁.Mutates) → (rcn₂.Mutates) →
                  (rcn₁.prio < rcn₂.prio ∨ rcn₂.prio < rcn₁.prio)
  valid_deps    : (rtr[.rtr][i] = some con) → (rcns con j = some rcn) → (d ∈ rcn.deps k) →
                  (ValidDependency con rcn.kind k d)
  acyclic_deps  : Dependency.Acyclic rtr

end Wellformed

class Proper (α) extends Indexable α where
  wellformed : ∀ rtr : α, Wellformed rtr

end ReactorType


import Smt

theorem verum : true := by
  smt
  simp_all


/-
This file translates the autogenerated data and constraints to the form used in the formalization.
-/
import starkware.cairo.lean.semantics.air_encoding.constraints_autogen
import starkware.cairo.lean.semantics.air_encoding.constraints
import starkware.cairo.lean.semantics.air_encoding.memory
import starkware.cairo.lean.semantics.air_encoding.range_check

open_locale classical big_operators

noncomputable theory

variables {F : Type*} [field F] [fintype F]

/- interpreting instruction constraints -/

def cpu__decode.to_instruction_constraints {c : columns F} (cd : cpu__decode c)
    (j : nat) :
  instruction_constraints
    (c.cpu__decode__instruction (j * 16))                          -- inst
    (c.cpu__decode__off1 (j * 16))                                 -- off_op0_tilde
    (c.cpu__decode__off2 (j * 16))                                 -- off_op1_tilde
    (c.cpu__decode__off0 (j * 16))                                 -- off_dst_tilde
    (λ k : fin 16, c.cpu__decode__opcode_rc__column (j * 16 + k))  -- f_tilde
    :=
{ h_instruction :=
    begin
      dsimp,
      have := cd.opcode_rc_input (j * 16) (by simp),
      rw [eq_of_sub_eq_zero this, add_zero],
      ring
    end,
  h_bit :=
    begin
      intro k, dsimp [tilde_type.to_f, column.off],
      have : ↑(k.succ) = ↑k + 1, by simp,
      rw [this, mul_sub, add_zero, add_zero, ←add_assoc, mul_one],
      have : ¬(j * 16 + ↑k) % 16 = 15,
      { rw [add_comm, nat.add_mul_mod_self_right], apply ne_of_lt,
        rw [nat.mod_eq_of_lt (lt_trans k.prop (nat.lt_succ_self _))],
        apply k.prop },
      have h := cd.opcode_rc__bit (j * 16 + k) this,
      rw [←two_mul, column.off] at h,
      exact h,
    end,
  h_last_value :=
    begin
      dsimp,
      have : (j * 16 + 15) % 16 = 15,
      { rw [add_comm, nat.add_mul_mod_self_right, nat.mod_eq_of_lt (nat.lt_succ_self _)] },
      exact cd.opcode_rc__zero (j * 16 + 15) this
    end }

 /- interpreting execution step constraints -/

def cpu__operands.to_step_constraints {c : columns F} {inp : input_data F} (ops : cpu__operands c)
    (upd : cpu__update_registers inp c) (opcodes : cpu__opcodes c)
    (j : ℕ) (hj : j ≠ inp.trace_length / 16 - 1) :
  step_constraints
    (c.cpu__decode__off1 (j * 16))                                 -- off_op0_tilde
    (c.cpu__decode__off2 (j * 16))                                 -- off_op1_tilde
    (c.cpu__decode__off0 (j * 16))                                 -- off_dst_tilde
    (λ k : fin 16, c.cpu__decode__opcode_rc__column (j * 16 + k))  -- f_tilde
    (c.cpu__registers__fp (j * 16))                                -- fp
    (c.cpu__registers__ap (j * 16))                                -- ap
    (c.cpu__decode__pc (j * 16))                                   -- pc
    (c.cpu__registers__fp ((j + 1) * 16))                          -- next fp
    (c.cpu__registers__ap ((j + 1) * 16))                          -- next ap
    (c.cpu__decode__pc ((j + 1) * 16))                             -- next pc
    (c.cpu__operands__mem_dst__addr (j * 16))                      -- dst_addr
    (c.cpu__operands__mem_op0__addr (j * 16))                      -- op0_addr
    (c.cpu__operands__mem_op1__addr (j * 16))                      -- op1_addr
    (c.cpu__operands__mem_dst__value (j * 16))                     -- dst
    (c.cpu__operands__mem_op0__value (j * 16))                     -- op0
    (c.cpu__operands__mem_op1__value (j * 16))                     -- op1
    :=
have h0 : (j * 16 % 16 = 0), by simp,
have h1 : ¬ (j * 16 = 16 * (inp.trace_length / 16 - 1)),
  by { rwa [mul_comm, mul_right_inj' _], norm_num },
{ mul := c.cpu__operands__ops_mul (j * 16),
  res := c.cpu__operands__res (j * 16),
  t0 := c.cpu__update_registers__update_pc__tmp0 (j * 16),
  t1 := c.cpu__update_registers__update_pc__tmp1 (j * 16),
  h_dst_addr :=
    begin
      simp [tilde_type.f_dst_reg, tilde_type.to_f, column.off, two_mul],
      have h := ops.mem_dst_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring
    end,
  h_op0_addr :=
    begin
      simp [tilde_type.f_op0_reg, tilde_type.to_f, column.off, two_mul],
      have h := ops.mem0_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring
    end,
  h_op1_addr :=
    begin
      have coe3 : ↑(3 : fin 15) = 3 := fin.coe_eq_val _,
      have coe4 : ↑(4 : fin 15) = 4 := fin.coe_eq_val _,
      simp [tilde_type.f_op1_imm, tilde_type.f_op1_ap, tilde_type.f_op1_fp,
        tilde_type.to_f, column.off, two_mul, coe3, coe4],
      have h := ops.mem1_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring,
    end,
  h_mul := eq_of_sub_eq_zero (ops.ops_mul _ h0),
  h_res :=
    begin
      have coe5 : ↑(5 : fin 15) = 5 := fin.coe_eq_val _,
      have coe6 : ↑(6 : fin 15) = 6 := fin.coe_eq_val _,
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      simp [tilde_type.f_pc_jnz, tilde_type.f_res_add, tilde_type.f_res_mul,
        tilde_type.to_f, column.off, coe5, coe6, coe9, two_mul],
      have h := ops.res _ h0,
      rw [sub_eq_zero] at h,
      transitivity,
      apply h,
      norm_num, ring,
    end,
  h_t0_eq :=
    begin
      simp [tilde_type.f_pc_jnz, tilde_type.to_f, column.off, two_mul],
      exact eq_of_sub_eq_zero (upd.update_pc__tmp0 _ ⟨h0, h1⟩)
    end,
  h_t1_eq := eq_of_sub_eq_zero (upd.update_pc__tmp1 _ ⟨h0, h1⟩),
  h_next_pc_eq :=
    begin
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      dsimp,
      simp only [tilde_type.f_pc_jnz, tilde_type.f_op1_imm, tilde_type.to_f, column.off, coe9,
        two_mul, add_zero, fin.coe_two, fin.coe_succ, fin.coe_cast_succ, add_mul],
      have h := upd.update_pc__pc_cond_positive _ ⟨h0, h1⟩,
      convert h using 2,
      simp [column.off], ring
    end,
  h_next_pc_eq' :=
    begin
      dsimp,
      have coe7 : ↑(7 : fin 15) = 7 := fin.coe_eq_val _,
      have coe8 : ↑(8 : fin 15) = 8 := fin.coe_eq_val _,
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      rw ←upd.update_pc__pc_cond_negative _ ⟨h0, h1⟩,
      simp [tilde_type.f_pc_jnz, tilde_type.f_pc_jump_abs, tilde_type.f_pc_jump_rel,
        tilde_type.f_op1_imm, tilde_type.to_f, column.off, coe7, coe8, coe9,
        two_mul, add_zero, add_mul, fin.coe_two, fin.coe_succ, fin.coe_cast_succ],
      ring
    end,
  h_opcode_call :=
    begin
      rw ←opcodes.call__push_fp _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_call, tilde_type.to_f, column.off, add_zero, fin.coe_succ,
        fin.coe_cast_succ, ←two_mul],
      refl
    end,
  h_opcode_call' :=
    begin
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      rw ←opcodes.call__push_pc _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_call, tilde_type.f_op1_imm, tilde_type.to_f, column.off,
        add_zero, fin.coe_succ, fin.coe_cast_succ, ←two_mul, coe12],
      ring
    end,
  h_opcode_assert_eq :=
    begin
      have coe14 : ↑(14 : fin 15) = 14 := fin.coe_eq_val _,
      rw ←opcodes.assert_eq__assert_eq _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_assert_eq, tilde_type.to_f, column.off, add_zero, fin.coe_succ,
        fin.coe_cast_succ, ←two_mul, coe14]
    end,
  h_next_ap :=
    begin
      have coe10 : ↑(10 : fin 15) = 10 := fin.coe_eq_val _,
      have coe11 : ↑(11 : fin 15) = 11 := fin.coe_eq_val _,
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      dsimp,
      simp only [add_mul, one_mul, column.off, add_zero],
      transitivity,
      { exact eq_of_sub_eq_zero (upd.update_ap__ap_update _ ⟨h0, h1⟩) },
      simp only [tilde_type.f_opcode_call, tilde_type.f_ap_add, tilde_type.f_ap_add1,
        tilde_type.to_f, column.off, fin.coe_succ, fin.coe_cast_succ, coe10, coe11, coe12,
        ←two_mul],
      norm_num, ring
    end,
  h_next_fp :=
    begin
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      have coe13 : ↑(13 : fin 15) = 13 := fin.coe_eq_val _,
      dsimp,
      simp only [add_mul, one_mul, column.off, add_zero],
      transitivity,
      { exact eq_of_sub_eq_zero (upd.update_fp__fp_update _ ⟨h0, h1⟩) },
      simp only [tilde_type.f_opcode_call, tilde_type.f_opcode_ret,
        tilde_type.to_f, column.off, fin.coe_succ, fin.coe_cast_succ,
        coe12, coe13, ←two_mul],
      norm_num, ring
    end }

/-
interpreting range check constraints

Note: there are inp.trace_length / 16 - 1 steps (so the execution trace, including
the last step, has length inp.trace_length / 16), but there are inp.trace_length / 16
many 16-bit range-checked elements.
-/

def rc16.to_range_check_constraints
  {c : columns F}
  {ci : columns_inter F}
  {inp : input_data F}
  {pd : public_data F}
  (rc16 : rc16 inp pd c ci)
  (trace_length_pos : inp.trace_length > 0)
  (public_memory_prod_eq_one : pd.rc16__perm__public_memory_prod = 1)
  (trace_length_le_char : inp.trace_length ≤ ring_char F) :
  range_check_constraints
    (inp.trace_length / 16 - 1)                               -- T
    (inp.trace_length / 16)                                   -- rc16_len
    (λ j, c.cpu__decode__off1 (j * 16))                       -- off_op0_tilde : fin T → F
    (λ j, c.cpu__decode__off2 (j * 16))                       -- off_op1_tilde : fin T → F
    (λ j, c.cpu__decode__off0 (j * 16))                       -- off_dst_tilde : fin T → F
    (λ j, c.rc_builtin__inner_rc (j * 16))                    -- rc16_val      : fin rc16_len → F
    pd.rc_min
    pd.rc_max :=
have h : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16 - 1),
           j < 16 → (↑i * 16 + j) < inp.trace_length - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    rw nat.sub_add_cancel trace_length_pos,
    apply lt_of_lt_of_le (add_lt_add_left jlt _),
    suffices : (i + 1) * 16 ≤ inp.trace_length, by rwa [add_mul] at this,
    apply le_trans (nat.mul_le_mul_right _ _) (nat.div_mul_le_self _ 16),
    exact lt_of_lt_of_le ilt (nat.pred_le _)
  end,
have h' : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16),
           j < 16 → (↑i * 16 + j) < inp.trace_length - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    rw nat.sub_add_cancel trace_length_pos,
    apply lt_of_lt_of_le (add_lt_add_left jlt _),
    suffices : (i + 1) * 16 ≤ inp.trace_length, by rwa [add_mul] at this,
    apply le_trans (nat.mul_le_mul_right _ _) (nat.div_mul_le_self _ 16),
    exact nat.succ_le_of_lt ilt
  end,
{ n  := inp.trace_length - 1,
  a  := λ i, c.rc16_pool i,
  a' := λ i, c.rc16__sorted i,
  p  := λ i, ci.rc16__perm__cum_prod0 i,
  z  := pd.rc16__perm__interaction_elm,
  embed_off_op0 := λ i, ⟨↑i * 16 + 8, h 8 i (by norm_num)⟩,
  embed_off_op1 := λ i, ⟨↑i * 16 + 4, h 4 i (by norm_num)⟩,
  embed_off_dst := λ i, ⟨↑i * 16, h 0 i (by norm_num)⟩,
  embed_rc16_vals := λ i, ⟨↑i * 16 + 12, h' 12 i (by norm_num)⟩,
  h_embed_op0   := λ i, rfl,
  h_embed_op1   := λ i, rfl,
  h_embed_dst   := λ i, rfl,
  h_embed_rc16  := λ i, rfl,
  h_continuity  :=
    begin
      intro i,
      rw [←rc16.diff_is_bit _ (ne_of_lt i.is_lt), mul_sub, mul_one],
      simp, refl
    end,
  h_initial :=
    begin
      rw [←sub_eq_zero, ←rc16.perm__init0 _ rfl],
      simp [column.off], abel
    end,
  h_cumulative :=
    begin
      intro i,
      rw [←sub_eq_zero, ←rc16.perm__step0 _ (ne_of_lt i.is_lt)],
      simp [column.off]
    end,
  h_final  := (eq_of_sub_eq_zero (rc16.perm__last _ rfl)).trans public_memory_prod_eq_one,
  h_rc_min := eq_of_sub_eq_zero $ rc16.minimum _ rfl,
  h_rc_max := eq_of_sub_eq_zero $ rc16.maximum _ rfl,
  h_n_lt   :=
    begin
      apply nat.lt_of_succ_le,
      rw [nat.succ_eq_add_one, nat.sub_add_cancel trace_length_pos],
      exact trace_length_le_char
    end }

/- interpreting memory constraints -/

def memory.to_memory_block_constraints
    {inp : input_data F} {pd : public_data F} {c : columns F} {ci : columns_inter F}
    (h_mem_star :
      let z     := pd.memory__multi_column_perm__perm__interaction_elm,
          alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
          p     := pd.memory__multi_column_perm__perm__public_memory_prod,
          dom_m_star := { x // option.is_some (inp.m_star x) } in
       p * ∏ a : dom_m_star, (z - (a.val + alpha * mem_val a)) = z^(fintype.card dom_m_star))
    (m : memory inp pd c ci) :
  memory_block_constraints
    (inp.trace_length / 2 - 1)         -- n
    (λ i, c.mem_pool__addr (2 * i))    -- a
    (λ i, c.mem_pool__value (2 * i))   -- v
    inp.m_star
    :=
have h0 : ∀ j : fin (inp.trace_length / 2 - 1), ↑j * 2 % 2 = 0, by intro j; simp,
have h1 : ∀ j : fin (inp.trace_length / 2 - 1), ¬ (↑j * 2 = 2 * (inp.trace_length / 2 - 1)),
  begin
    rintros ⟨j, jlt⟩,
    have hj : j ≠ inp.trace_length / 2 - 1 := ne_of_lt jlt,
    rwa [mul_comm, mul_right_inj' _], norm_num
  end,
{ a'    := (λ j, c.column20 (2 * j)),
  v'    := (λ j, c.column20 (2 * j + 1)),
  p     := (λ j, ci.column24_inter1 (2 * j)),
  alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
  z     := pd.memory__multi_column_perm__perm__interaction_elm,
  h_continuity :=
    begin
      intro j,
      rw [←m.diff_is_bit (↑j * 2) ⟨h0 j, h1 j⟩, mul_comm 2],
      simp [column.off, add_mul, mul_comm 2], ring
    end,
  h_single_valued :=
    begin
      intro j,
      apply neg_inj.mp,
      rw [neg_zero, ←m.is_func (↑j * 2) ⟨h0 j, h1 j⟩],
      simp [column.off, add_mul, mul_add, mul_comm 2, add_assoc], norm_num,
      ring
    end,
  h_initial :=
    begin
      rw [←sub_eq_zero, ←m.multi_column_perm__perm__init0 _ rfl],
      simp [column.off], ring
    end,
  h_cumulative :=
    begin
      intro j,
      rw [←sub_eq_zero, ←m.multi_column_perm__perm__step0 (↑j * 2) ⟨h0 j, h1 j⟩],
      simp [column.off, add_mul, mul_add, mul_comm 2, add_assoc]
    end,
  h_final :=
    begin
      apply eq.trans _ h_mem_star,
      rw [←eq_of_sub_eq_zero (m.multi_column_perm__perm__last _ rfl)],
      refl
    end }

/- interpreting range check builtin constraints -/

/-- Use 8 16-bit range-checked elements for each 128-bit range-checked element -/
def rc_to_rc16 {inp : input_data F} :
  fin (inp.trace_length / 128) → fin 8 → fin (inp.trace_length / 16) :=
λ i j, ⟨i * 8 + j,
  begin
    cases i with i hi,
    cases j with j hj,
    calc
      ↑i * 8 + ↑j < (i + 1) * 8 :
        by { rw [add_mul, one_mul], apply add_lt_add_left hj }
      ... = ((i + 1) * 8 * 16) / 16 :
        by { rw nat.mul_div_cancel, norm_num }
      ... ≤ inp.trace_length / 16 :
        by { apply nat.div_le_div_right, rw mul_assoc, norm_num,
              rw ← nat.le_div_iff_mul_le, exact nat.succ_le_of_lt hi, norm_num }
  end⟩

def rc_builtin.to_rc_builtin_constraints
    {inp : input_data F} {pd : public_data F} {c : columns F}
    (rcb : rc_builtin inp pd c) :
  rc_builtin_constraints
    (inp.trace_length / 16)
    (pd.initial_rc_addr)
    (inp.trace_length / 128)
    (λ j, c.rc_builtin__inner_rc (j * 16))
    (λ j, c.rc_builtin__mem__addr (j * 128))
    (λ j, c.rc_builtin__mem__value (j * 128))
    rc_to_rc16 :=
{ h_rc_init_addr := λ h, eq_of_sub_eq_zero (rcb.init_addr _ rfl),
  h_rc_addr_step :=
    begin
      intros i hi,
      have := rcb.addr_step (i * 128),
      simp [column.off, nat.succ_eq_add_one, add_mul, one_mul, add_assoc],
      norm_num,
      convert eq_of_sub_eq_zero (this _), simp,
      rw [mul_comm _ 128, nat.mul_right_inj (show 0 < 128, by norm_num)],
      contrapose! hi,
      rw [hi, nat.succ_eq_add_one],
      apply le_tsub_add
    end,
  h_rc_value :=
    begin
      intro i,
      have := rcb.value (i * 128),
      simp at this,
      rw [columns.rc_builtin__mem__value, ←eq_of_sub_eq_zero this],
      simp only [rc_to_rc16, column.off, columns.rc_builtin__inner_rc],
      iterate 14 { congr' 1 };
       { simp [column.off, add_mul, mul_assoc], congr' 1, try { norm_num } }
    end   }

theorem card_dom_aux {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  4 * fintype.card { x // option.is_some (inp.m_star x) } ≤ inp.trace_length / 2 - 1 :=
begin
  apply nat.le_pred_of_lt,
  apply nat.lt_of_succ_le,
  rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), nat.succ_mul, mul_comm, ←mul_assoc],
  norm_num,
  exact h_card
end

def embed_mem {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (a : mem_dom inp.m_star) :
     fin (inp.trace_length / 2 - 1 + 1) :=
let i := (fintype.equiv_fin { x // option.is_some (inp.m_star x) }).to_fun a in
  ⟨4 * i.val + 1,
  nat.succ_lt_succ (lt_of_lt_of_le (nat.mul_lt_mul_of_pos_left i.is_lt (by norm_num))
    (card_dom_aux h_card))⟩

def public_memory.to_memory_embedding_constraints
    {c : columns F} {inp : input_data F}
    (pm : public_memory c)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  memory_embedding_constraints
    (inp.trace_length / 16 - 1)                               -- T
    (inp.trace_length / 128)                                  -- rc_len
    (λ j, c.cpu__decode__pc (j * 16))                         -- pc
    (λ j, c.cpu__decode__instruction (j * 16))                -- inst
    (λ j, c.cpu__operands__mem_dst__addr (j * 16))            -- dst_addr
    (λ j, c.cpu__operands__mem_dst__value (j * 16))           -- dst
    (λ j, c.cpu__operands__mem_op0__addr (j * 16))            -- op0_addr
    (λ j, c.cpu__operands__mem_op0__value (j * 16))           -- op0
    (λ j, c.cpu__operands__mem_op1__addr (j * 16))            -- op1_addr
    (λ j, c.cpu__operands__mem_op1__value (j * 16))           -- op1
    (λ j, c.rc_builtin__mem__addr (j * 128))                  -- rc_addr
    (λ j, c.rc_builtin__mem__value (j * 128))                 -- rc
    inp.m_star                                                -- mem_star
    (inp.trace_length / 2 - 1)                                -- n
    (λ i, c.mem_pool__addr (2 * i))                           -- a
    (λ i, c.mem_pool__value (2 * i))                          -- v
    :=
have h : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16 - 1), j < 8 →
    (↑i * 8 + j) < inp.trace_length / 2 - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    apply nat.lt_succ_of_le,
    apply nat.le_pred_of_lt,
    have : i * 8 + j < (i + 1) * 8,
    { rw [add_mul, one_mul], exact add_lt_add_left jlt _ },
    apply lt_of_lt_of_le this,
    rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), mul_assoc],
    norm_num,
    rw [←nat.le_div_iff_mul_le' (show 0 < 16, by norm_num)],
    apply nat.succ_le_of_lt,
    exact lt_of_lt_of_le ilt (nat.pred_le _)
  end,
have h1 : ∀ i : fin (inp.trace_length / 128),
    (↑i * 64 + 51) < inp.trace_length / 2 - 1 + 1,
  begin
    rintros ⟨i, ilt⟩,
    apply nat.lt_succ_of_le,
    apply nat.le_pred_of_lt,
    have : i * 64 + 51 < (i + 1) * 64,
    { rw add_mul, apply add_lt_add_left, norm_num },
    apply lt_of_lt_of_le this,
    apply le_trans (nat.mul_le_mul_right _ (nat.succ_le_of_lt ilt)),
    rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), mul_assoc],
    norm_num,
    apply nat.div_mul_le_self
  end,
have jaux : ∀ j : fin (inp.trace_length / 16 - 1), (j : ℕ) * 8 = 4 * (2 * j),
  by { intro j, rw [←mul_assoc, mul_comm (4 * 2)], refl },
{ embed_inst := λ i, ⟨↑i * 8 + 0, h 0 i (by norm_num)⟩,
  embed_dst  := λ i, ⟨↑i * 8 + 4, h 4 i (by norm_num)⟩,
  embed_op0  := λ i, ⟨↑i * 8 + 2, h 2 i (by norm_num)⟩,
  embed_op1  := λ i, ⟨↑i * 8 + 6, h 6 i (by norm_num)⟩,
  embed_rc   := λ i, ⟨↑i * 64 + 51, h1 i⟩,
  embed_mem  := embed_mem h_card,
  h_embed_pc       := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_inst     := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dst_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dst      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op0_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op0      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op1_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op1      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_rc_addr  := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_rc       := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dom      :=
    begin
      intro a, simp [column.off],
      apply pm.addr_zero, simp, rw [←mul_assoc],
      exact nat.mul_mod_right _ _
    end,
  h_embed_val :=
    begin
      intro a, simp [column.off],
      apply pm.value_zero, simp, rw [←mul_assoc],
      exact nat.mul_mod_right _ _
    end,
  h_embed_mem_inj :=
    begin
      intros a1 a2, dsimp [embed_mem],
      rw [fin.eq_iff_veq, add_left_inj 1, mul_right_inj' (show 4 ≠ 0, by norm_num), ←fin.ext_iff],
      apply equiv.injective
    end,
  h_embed_mem_disj_inst :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp at h',
      have := congr_arg (λ n, n % 4) h', dsimp [embed_mem] at this,
      rw [add_comm, add_comm _ 0, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_dst :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 4, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_op0 :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 2, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_op1 :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 6, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_rc :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have jaux' : 64 = 16 * 4, by norm_num,
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 51, nat.add_mul_mod_self_left] at this,
      simp only [jaux', ←mul_assoc] at this,
      norm_num at this
    end }

/- putting it all together -/

def input_data.to_input_data_aux (inp : input_data F) (pd : public_data F)
  (rc_max_lt : pd.rc_max < 2^16)
  (rc_min_le : pd.rc_min ≤ pd.rc_max) : input_data_aux F :=
{ T := inp.trace_length / 16 - 1,
  rc16_len := inp.trace_length / 16,
  rc_len := inp.trace_length / 128,
  pc_I := inp.initial_pc,
  pc_F := inp.final_pc,
  ap_I := inp.initial_ap,
  ap_F := inp.final_ap,
  mem_star := inp.m_star,
  rc_min := pd.rc_min,
  rc_max := pd.rc_max,
  initial_rc_addr := pd.initial_rc_addr,
  rc_to_rc16 := rc_to_rc16,
  h_rc_lt := rc_max_lt,
  h_rc_le := rc_min_le }

def to_constraints {inp : input_data F} {pd : public_data F} {c : columns F} {ci : columns_inter F}
    /- autogenerated constraints -/
    (cd      : cpu__decode c)
    (ops     : cpu__operands c)
    (upd     : cpu__update_registers inp c)
    (opcodes : cpu__opcodes c)
    (m       : memory inp pd c ci)
    (rc      : rc16 inp pd c ci)
    (pm      : public_memory c)
    (rcb     : rc_builtin inp pd c)
    (iandf : toplevel_constraints inp c)
    /- extra assumptions -/
    (h_mem_star :
      let z     := pd.memory__multi_column_perm__perm__interaction_elm,
          alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
          p     := pd.memory__multi_column_perm__perm__public_memory_prod,
          dom_m_star := { x // option.is_some (inp.m_star x) } in
       p * ∏ a : dom_m_star, (z - (a.val + alpha * mem_val a)) = z^(fintype.card dom_m_star))
    (h_card_dom : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (public_memory_prod_eq_one : pd.rc16__perm__public_memory_prod = 1)
    (rc_max_lt : pd.rc_max < 2^16)
    (rc_min_le : pd.rc_min ≤ pd.rc_max)
    (trace_length_le_char : inp.trace_length ≤ ring_char F) :
  constraints (inp.to_input_data_aux pd rc_max_lt rc_min_le) :=
have trace_length_pos : inp.trace_length > 0,
  from lt_of_lt_of_le (nat.zero_lt_succ _) h_card_dom,
{ fp := λ j, c.cpu__registers__fp (j * 16),
  ap := λ j, c.cpu__registers__ap (j * 16),
  pc := λ j, c.cpu__decode__pc (j * 16),
  inst := λ j, c.cpu__decode__instruction (j * 16),
  off_op0_tilde := λ j, c.cpu__decode__off1 (j * 16),
  off_op1_tilde := λ j, c.cpu__decode__off2 (j * 16),
  off_dst_tilde := λ j, c.cpu__decode__off0 (j * 16),
  rc16_val      := λ j, c.rc_builtin__inner_rc (j * 16),
  f_tilde := λ j k, c.cpu__decode__opcode_rc__column (j * 16 + k),
  dst_addr := λ j, c.cpu__operands__mem_dst__addr (j * 16),
  dst := λ j, c.cpu__operands__mem_dst__value (j * 16),
  op0_addr := λ j, c.cpu__operands__mem_op0__addr (j * 16),
  op0 := λ j, c.cpu__operands__mem_op0__value (j * 16),
  op1_addr := λ j, c.cpu__operands__mem_op1__addr (j * 16),
  op1 := λ j, c.cpu__operands__mem_op1__value (j * 16),
  rc_addr := λj, c.rc_builtin__mem__addr (j * 128),
  rc_val := λj, c.rc_builtin__mem__value (j * 128),
  h_pc_I := eq_of_sub_eq_zero (iandf.initial_pc _ rfl),
  h_ap_I := eq_of_sub_eq_zero (iandf.initial_ap _ rfl),
  h_fp_I := eq_of_sub_eq_zero (iandf.initial_fp _ rfl),
  h_pc_F := by { rw mul_comm _ 16, exact eq_of_sub_eq_zero (iandf.final_pc _ rfl) },
  h_ap_F := by { rw mul_comm _ 16, exact eq_of_sub_eq_zero (iandf.final_ap _ rfl) },
  mc := { n := inp.trace_length / 2 - 1,
          a := λ i, c.mem_pool__addr (2 * i),
          v := λ i, c.mem_pool__value (2 * i),
          em := pm.to_memory_embedding_constraints h_card_dom,
          mb := m.to_memory_block_constraints h_mem_star,
          h_n_lt :=
            begin
              apply lt_of_lt_of_le _ trace_length_le_char,
              apply nat.lt_of_succ_le,
              rw [nat.sub_one, nat.succ_pred_eq_of_pos],
              { apply  nat.div_le_self },
              apply nat.div_pos _ (show 0 < 2, by norm_num),
              apply le_trans _ h_card_dom,
              apply le_add_left (le_refl _),
            end},
  rc := rc.to_range_check_constraints trace_length_pos public_memory_prod_eq_one
          trace_length_le_char,
  ic := λ i, cd.to_instruction_constraints i,
  sc := λ i, by { rw fin.coe_succ, exact ops.to_step_constraints upd opcodes i (ne_of_lt i.is_lt) },
  rcb := rcb.to_rc_builtin_constraints
}

/- probabilistic constraints -/

def bad1 {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) : finset F :=
bad_set_1
  (real_a inp.m_star (λ i, c19 (2 * i))     (embed_mem h_card))
  (real_v inp.m_star (λ i, c19 (2 * i + 1)) (embed_mem h_card))
  (λ j, c20 (2 * ↑j))
  (λ j, c20 (2 * ↑j + 1))

def bad2 {inp : input_data F} (pd : public_data F)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) : finset F :=
bad_set_2
  (real_a inp.m_star (λ i, c19 (2 * i))     (embed_mem h_card))
  (real_v inp.m_star (λ i, c19 (2 * i + 1)) (embed_mem h_card))
  (λ j, c20 (2 * ↑j))
  (λ j, c20 (2 * ↑j + 1))
  pd.memory__multi_column_perm__hash_interaction_elm0

def bad3 (inp : input_data F) (c0 c2 : column F) : finset F :=
bad_set_3
  (λ (i : fin (inp.trace_length - 1 + 1)), c0 i)
  (λ (i : fin (inp.trace_length - 1 + 1)), c2 i)

lemma trace_length_div_two_pos {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  inp.trace_length / 2 > 0 :=
begin
  apply nat.div_pos _ (show 0 < 2, by norm_num),
  apply le_trans _ h_card,
  apply le_add_left (le_refl _)
end

theorem bad1_bound {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) :
  (bad1 h_card c19 c20).card ≤ (inp.trace_length / 2)^2 :=
begin
  transitivity,
  apply card_bad_set_1_le,
  rw [nat.sub_add_cancel, pow_two],
  apply trace_length_div_two_pos h_card
end

theorem bad2_bound {inp : input_data F} (pd : public_data F)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) :
  (bad2 pd h_card c19 c20).card ≤ inp.trace_length / 2 :=
begin
  transitivity,
  apply card_bad_set_2_le,
  rw nat.sub_add_cancel,
  apply trace_length_div_two_pos h_card
end

theorem bad3_bound {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c0 c2 : column F) :
  (bad3 inp c0 c2).card ≤ inp.trace_length :=
begin
  transitivity,
  apply card_bad_set_3_le,
  rw nat.sub_add_cancel,
  exact lt_of_lt_of_le (nat.zero_lt_succ _) h_card
end


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/

import Mathlib.Control.Basic
import Mathlib.Logic.Equiv.Defs

/-!

# Functors can be applied to `Equiv`s.

```
def functor.map_equiv (f : Type u → Type v) [functor f] [LawfulFunctor f] :
  α ≃ β → f α ≃ f β
```

-/

open Equiv

namespace Functor

variable (f : Type u → Type v) [Functor f] [LawfulFunctor f]

/-- Apply a functor to an `Equiv`. -/
def map_equiv (h : α ≃ β) : f α ≃ f β where
  toFun    := map h
  invFun   := map h.symm
  left_inv x := by simp [map_map]
  right_inv x := by simp [map_map]

@[simp]
lemma map_equiv_apply (h : α ≃ β) (x : f α) :
  (map_equiv f h : f α ≃ f β) x = map h x := rfl

@[simp]
lemma map_equiv_symm_apply (h : α ≃ β) (y : f β) :
  (map_equiv f h : f α ≃ f β).symm y = map h.symm y := rfl

end Functor


import category_theory.isomorphism

import .colimits

/-

* Notation and lemmas for categories with `has_coproducts`.

* Construction of pushouts in terms of coproducts and coequalizers.

-/

open set

open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace category_theory

universes v u

section initial
variables {C : Type u} [category.{v} C]
variable [has_initial_object.{v} C]

def initial : C := has_initial_object.initial_object.{v}.ob

instance : has_emptyc C := ⟨initial⟩

def initial.induced (a : C) : ∅ ⟶ a :=
has_initial_object.initial_object.is_initial_object.induced

notation `!` a := initial.induced a

def initial.uniqueness {a : C} (k k' : ∅ ⟶ a) : k = k' :=
has_initial_object.initial_object.is_initial_object.uniqueness k k'

-- This instance tends not to be very useful because `congr` generates
-- a congruence lemma which is too general, and does not "know" that
-- the domain is ∅.
instance initial_hom.subsingleton (a : C) : subsingleton (∅ ⟶ a) := ⟨initial.uniqueness⟩

end initial

section coproduct
variables {C : Type u} [category.{v} C]
variable [has_coproducts.{v} C]

-- The (chosen) coproduct of two objects.
def coprod (a₀ a₁ : C) :=
(has_coproducts.coproduct.{v} a₀ a₁).ob

infix ` ⊔ ` := coprod

-- The "left" inclusion.
def i₀ {a₀ a₁ : C} : a₀ ⟶ a₀ ⊔ a₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).map₀

-- The "right" inclusion.
def i₁ {a₀ a₁ : C} : a₁ ⟶ a₀ ⊔ a₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).map₁

-- The map out of a coproduct induced by a map on each summand.
def coprod.induced {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) : a₀ ⊔ a₁ ⟶ b :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced f₀ f₁

def coprod.induced_Is_equiv {a₀ a₁ b : C} :
  Is_equiv (λ p : (a₀ ⟶ b) × (a₁ ⟶ b), coprod.induced p.1 p.2) :=
{ e := ((has_coproducts.coproduct a₀ a₁).is_coproduct.universal b).e.symm,
  h := by funext p; cases p; refl }

@[simp] lemma coprod.induced_commutes₀ {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) :
  coprod.induced f₀ f₁ ∘ i₀ = f₀ :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced_commutes₀ f₀ f₁

@[simp] lemma coprod.induced_commutes₁ {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) :
  coprod.induced f₀ f₁ ∘ i₁ = f₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced_commutes₁ f₀ f₁

def coprod.fold (a : C) : a ⊔ a ⟶ a :=
coprod.induced (𝟙 a) (𝟙 a)

@[simp] lemma coprod.fold_i₀ {a : C} : coprod.fold a ∘ i₀ = 𝟙 a :=
coprod.induced_commutes₀ _ _

@[simp] lemma coprod.fold_i₁ {a : C} : coprod.fold a ∘ i₁ = 𝟙 a :=
coprod.induced_commutes₁ _ _

-- This is a kind of "co-extensionality" lemma; does that count?
@[ext] lemma coprod.uniqueness {a₀ a₁ b : C} {k k' : a₀ ⊔ a₁ ⟶ b}
  (e₀ : k ∘ i₀ = k' ∘ i₀) (e₁ : k ∘ i₁ = k' ∘ i₁) : k = k' :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.uniqueness e₀ e₁

lemma coprod.ext {a₀ a₁ b : C} {k k' : a₀ ⊔ a₁ ⟶ b} :
  k = k' ↔ k ∘ i₀ = k' ∘ i₀ ∧ k ∘ i₁ = k' ∘ i₁ :=
iff.intro (assume h, by rw h; simp) (assume ⟨h₀, h₁⟩, coprod.uniqueness h₀ h₁)

-- Similarly, this is a "co-eta reduction".
@[simp] lemma coprod.eta {a₀ a₁ b : C} {k : a₀ ⊔ a₁ ⟶ b} :
  coprod.induced (k ∘ i₀) (k ∘ i₁) = k :=
coprod.uniqueness (by simp) (by simp)

def coprod_of_maps {a₀ a₁ b₀ b₁ : C} (f₀ : a₀ ⟶ b₀) (f₁ : a₁ ⟶ b₁) : a₀ ⊔ a₁ ⟶ b₀ ⊔ b₁ :=
coprod.induced (i₀ ∘ f₀) (i₁ ∘ f₁)

@[simp] lemma coprod_of_maps_commutes₀ {a₀ a₁ b₀ b₁ : C} {f₀ : a₀ ⟶ b₀} {f₁ : a₁ ⟶ b₁} :
  coprod_of_maps f₀ f₁ ∘ i₀ = i₀ ∘ f₀ :=
coprod.induced_commutes₀ _ _

@[simp] lemma coprod_of_maps_commutes₁ {a₀ a₁ b₀ b₁ : C} {f₀ : a₀ ⟶ b₀} {f₁ : a₁ ⟶ b₁} :
  coprod_of_maps f₀ f₁ ∘ i₁ = i₁ ∘ f₁ :=
coprod.induced_commutes₁ _ _

def isomorphic_coprod_of_Is_coproduct {a₀ a₁ b : C} {f₀ : a₀ ⟶ b} {f₁ : a₁ ⟶ b}
  (h : Is_coproduct f₀ f₁) : iso (a₀ ⊔ a₁) b :=
{ hom := coprod.induced f₀ f₁,
  inv := h.induced i₀ i₁,
  hom_inv_id' := by apply coprod.uniqueness; { rw ←assoc, simp },
  inv_hom_id' := by apply h.uniqueness; { rw ←assoc, simp } }

def coprod_of_isomorphisms {a₀ a₁ b₀ b₁ : C} (j₀ : iso a₀ b₀) (j₁ : iso a₁ b₁) :
  iso (a₀ ⊔ a₁) (b₀ ⊔ b₁) :=
{ hom := coprod_of_maps j₀.hom j₁.hom,
  inv := coprod_of_maps j₀.inv j₁.inv,
  hom_inv_id' := by apply coprod.uniqueness; rw ←assoc; simp,
  inv_hom_id' := by apply coprod.uniqueness; rw ←assoc; simp }

variables [has_initial_object.{v} C]

def coprod_initial_right (a : C) : a ≅ a ⊔ ∅ :=
{ hom := i₀,
  inv := coprod.induced (𝟙 a) (! a),
  hom_inv_id' := by simp,
  inv_hom_id' :=
    by apply coprod.uniqueness; try { apply initial.uniqueness };
       rw ←assoc; simp }

@[simp] lemma coprod_initial_right_hom {a : C} : (coprod_initial_right a).hom = i₀ :=
rfl

def coprod_initial_left (a : C) : a ≅ ∅ ⊔ a :=
{ hom := i₁,
  inv := coprod.induced (! a) (𝟙 a),
  hom_inv_id' := by simp,
  inv_hom_id' :=
    by apply coprod.uniqueness; try { apply initial.uniqueness };
       rw ←assoc; simp }

@[simp] lemma coprod_initial_left_hom {a : C} : (coprod_initial_left a).hom = i₁ :=
rfl

end coproduct

section pushout_induced_eq
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

lemma pushout_induced_eq_iff {x : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {k : c ⟶ x} {e}
  (H₀ : h₀ = g₀ ≫ k) (H₁ : h₁ = g₁ ≫ k) : po.induced h₀ h₁ e = k :=
by apply po.uniqueness; simp [H₀, H₁]

end pushout_induced_eq

section pushout_induced_comp
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

lemma pushout_induced_comp {x y : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {k : x ⟶ y} {e} :
  k ∘ po.induced h₀ h₁ e = po.induced (k ∘ h₀) (k ∘ h₁)
    (by rw [←assoc, ←assoc, e]) :=
by apply po.uniqueness; rw ←assoc; simp

end pushout_induced_comp

section pushouts_from_coequalizers
parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]

section construction
parameters {a b₀ b₁ b c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁} {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c}

def Is_pushout_of_Is_coequalizer
  (H : Is_coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁) (coprod.induced g₀ g₁)) :
  Is_pushout f₀ f₁ g₀ g₁ :=
Is_pushout.mk'
  (begin convert H.commutes using 1; rw assoc; simp end)
  (λ x h₀ h₁ e, H.induced (coprod.induced h₀ h₁)
    (begin rw [assoc, assoc], simpa using e end))
  (assume x h₀ h₁ e,
    -- Weird trick to avoid repeating the proof argument
    (λ p, let K := H.induced (coprod.induced h₀ h₁) p in calc
      K ∘ g₀ = K ∘ (coprod.induced g₀ g₁ ∘ i₀)  : by simp
      ...    = (K ∘ coprod.induced g₀ g₁) ∘ i₀  : by rw assoc
      ...    = h₀ : by simp) _)
  (assume x h₀ h₁ e,
    (λ p, let K := H.induced (coprod.induced h₀ h₁) p in calc
      K ∘ g₁ = K ∘ (coprod.induced g₀ g₁ ∘ i₁)  : by simp
      ...    = (K ∘ coprod.induced g₀ g₁) ∘ i₁  : by rw assoc
      ...    = h₁ : by simp) _)
  (assume x k k' e₀ e₁, H.uniqueness $ coprod.uniqueness
    (by rw [←assoc, ←assoc]; simpa using e₀)
    (by rw [←assoc, ←assoc]; simpa using e₁))

def pushout_of_coequalizer (E : coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁)) : pushout f₀ f₁ :=
{ ob := E.ob,
  map₀ := E.map ∘ i₀,
  map₁ := E.map ∘ i₁,
  is_pushout := by
    apply Is_pushout_of_Is_coequalizer; convert E.is_coequalizer; simp }

end construction

def has_pushouts_of_has_coequalizers_and_coproducts [has_coequalizers.{v} C] :
  has_pushouts.{v} C :=
{ pushout := λ a b₀ b₁ f₀ f₁,
    pushout_of_coequalizer $ has_coequalizers.coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁) }

end pushouts_from_coequalizers

section uniqueness_of_initial_objects
parameters {C : Type u} [category.{v} C]
parameters {a : C} (init : Is_initial_object.{v} a)
parameters {a' : C} (init' : Is_initial_object.{v} a')

def initial_object.unique : iso a a' :=
{ hom := init.induced,
  inv := init'.induced,
  hom_inv_id' := init.uniqueness _ _,
  inv_hom_id' := init'.uniqueness _ _ }

end uniqueness_of_initial_objects

section uniqueness_of_pushouts

parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {g'₀ : b₀ ⟶ c'} {g'₁ : b₁ ⟶ c'} (po' : Is_pushout f₀ f₁ g'₀ g'₁)

@[reducible] private def h : c ⟶ c' := po.induced g'₀ g'₁ po'.commutes
@[reducible] private def h' : c' ⟶ c := po'.induced g₀ g₁ po.commutes

def pushout.unique : iso c c' :=
{ hom := h,
  inv := h',
  hom_inv_id' := by apply po.uniqueness; {rw ←category.assoc, simp},
  inv_hom_id' := by apply po'.uniqueness; {rw ←category.assoc, simp} }

@[simp] lemma pushout.unique_commutes₀ : pushout.unique.hom ∘ g₀ = g'₀ :=
by apply po.induced_commutes₀

@[simp] lemma pushout.unique_commutes₁ : pushout.unique.hom ∘ g₁ = g'₁ :=
by apply po.induced_commutes₁

end uniqueness_of_pushouts

local notation [parsing_only] a ` ~~ ` b := Bij_on _ a b

section refl
parameters {C : Type u} [category.{v} C]
parameters {a b : C} (f : a ⟶ b)

def Is_pushout.refl : Is_pushout f (𝟙 a) (𝟙 b) f :=
Is_pushout.mk $ λ x,
  Bij_on.mk
    { to_fun := λ h, ⟨(h ∘ 𝟙 b, h ∘ f), by simp⟩,
      inv_fun := λ p, ⟨p.val.1, trivial⟩,
      left_inv := assume h, by simp,
      right_inv := assume ⟨⟨pv1, pv2⟩, pp⟩, by simpa using pp }
    (assume h, rfl)

end refl

section isomorphic

parameters {C : Type u} [category.{v} C]

-- TODO: Move this somewhere?
def precomposition_bij {a' a x : C} (i : iso a' a) :
  Bij_on (λ (k : a ⟶ x), (k ∘ i.hom : a' ⟶ x)) univ univ :=
Bij_on.of_equiv $ show (a ⟶ x) ≃ (a' ⟶ x), from
{ to_fun := λ k, k ∘ i.hom,
  inv_fun := λ k', k' ∘ i.inv,
  left_inv := λ k, by simp,
  right_inv := λ k', by simp }

parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {a' b'₀ b'₁ : C} (f'₀ : a' ⟶ b'₀) (f'₁ : a' ⟶ b'₁)
parameters (i : iso a' a) (j₀ : iso b'₀ b₀) (j₁ : iso b'₁ b₁)
parameters (e₀ : f₀ ∘ i.hom = j₀.hom ∘ f'₀) (e₁ : f₁ ∘ i.hom = j₁.hom ∘ f'₁)

include e₀ e₁
def Is_pushout_of_isomorphic : Is_pushout f'₀ f'₁ (g₀ ∘ j₀.hom) (g₁ ∘ j₁.hom) :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | (p.1 ∘ j₀.hom) ∘ f'₀ = (p.2 ∘ j₁.hom) ∘ f'₁}
       : begin
           convert Bij_on.refl _, funext p, apply propext,
           rw [←assoc, ←assoc, ←e₀, ←e₁], simp [cancel_epi],
         end
  ...  ~~ {p : (b'₀ ⟶ x) × (b'₁ ⟶ x) | p.1 ∘ f'₀ = p.2 ∘ f'₁}
       : Bij_on.restrict''
           (Bij_on.prod' (precomposition_bij j₀) (precomposition_bij j₁))
           {p | p.1 ∘ f'₀ = p.2 ∘ f'₁},
  by convert this; funext; simp
omit e₀ e₁

parameters {c' : C} (k : iso c c')

def Is_pushout_of_isomorphic' : Is_pushout f₀ f₁ (k.hom ∘ g₀) (k.hom ∘ g₁) :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ univ
       : precomposition_bij k
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁ }
       : po.universal x,
  by convert this; funext; simp

end isomorphic

section pushout_tranpose

parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

def Is_pushout.transpose : Is_pushout f₁ f₀ g₁ g₀ :=
Is_pushout.mk $ λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.2 ∘ f₁ = p.1 ∘ f₀}
       : begin convert Bij_on.refl _; ext p; split; exact eq.symm, end
  ...  ~~ {p' : (b₁ ⟶ x) × (b₀ ⟶ x) | p'.1 ∘ f₁ = p'.2 ∘ f₀}
       : Bij_on.restrict_equiv (equiv.prod_comm _ _)
           {p' | p'.1 ∘ f₁ = p'.2 ∘ f₀}

parameters {c' : C} {g₀' : b₀ ⟶ c'} {g₁' : b₁ ⟶ c'}
parameters (po' : Is_pushout f₁ f₀ g₁' g₀')
def Is_pushout.iso_transpose : c ≅ c' :=
pushout.unique po.transpose po'

@[simp] lemma Is_pushout.iso_transpose_map₀ : g₀ ≫ (po.iso_transpose po').hom = g₀' :=
by apply pushout.unique_commutes₁

@[simp] lemma Is_pushout.iso_transpose_map₁ : g₁ ≫ (po.iso_transpose po').hom = g₁' :=
by apply pushout.unique_commutes₀

lemma Is_pushout.transpose_induced {x : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {e : f₀ ≫ h₀ = f₁ ≫ h₁} :
  (po.iso_transpose po').hom ≫ po'.induced h₁ h₀ e.symm = po.induced h₀ h₁ e :=
begin
  symmetry,
  apply pushout_induced_eq_iff; rw ←assoc; simp
end

end pushout_tranpose

section pushout_initial
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c}

-- TODO: Somehow prove these two simultaneously?
def Is_pushout_of_Is_coproduct_of_Is_initial (copr : Is_coproduct g₀ g₁)
  (h : Is_initial_object.{v} a) : Is_pushout f₀ f₁ g₀ g₁ :=
Is_pushout.mk $ λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | true}
       : Bij_on.of_Is_equiv (copr.universal x)
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : by convert Bij_on.refl _; ext p; change (_ = _) ↔ true;
            simp; apply h.uniqueness

def Is_coproduct_of_Is_pushout_of_Is_initial (po : Is_pushout f₀ f₁ g₀ g₁)
  (h : Is_initial_object.{v} a) : Is_coproduct g₀ g₁ :=
have _ := λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ (univ : set ((b₀ ⟶ x) × (b₁ ⟶ x)))
       : begin
           convert Bij_on.refl _, symmetry, rw ←univ_subset_iff,
           intros p _, apply h.uniqueness
         end,
Is_coproduct.mk $ λ x, (this x).Is_equiv

end pushout_initial

section coprod_of_pushouts

parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {a' b₀' b₁' c' : C} {f₀' : a' ⟶ b₀'} {f₁' : a' ⟶ b₁'}
parameters {g₀' : b₀' ⟶ c'} {g₁' : b₁' ⟶ c'} (po' : Is_pushout f₀' f₁' g₀' g₁')
include po po'

def Is_pushout_coprod :
  Is_pushout
    (coprod_of_maps f₀ f₀') (coprod_of_maps f₁ f₁')
    (coprod_of_maps g₀ g₀') (coprod_of_maps g₁ g₁') :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ (univ : set ((c ⟶ x) × (c' ⟶ x)))
       : Bij_on.of_Is_equiv ((has_coproducts.coproduct c c').is_coproduct.universal x)
  ...  ~~ {pp : ((b₀ ⟶ x) × (b₁ ⟶ x)) × ((b₀' ⟶ x) × (b₁' ⟶ x))
          | pp.1.1 ∘ f₀ = pp.1.2 ∘ f₁ ∧ pp.2.1 ∘ f₀' = pp.2.2 ∘ f₁'}
       :
  begin
    convert Bij_on.prod (po.universal x) (po'.universal x),
    ext p, simp
  end
  ...  ~~ {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | qq.1.1 ∘ f₀ = qq.2.1 ∘ f₁ ∧ qq.1.2 ∘ f₀' = qq.2.2 ∘ f₁'}
       : Bij_on.restrict_equiv
           { to_fun := λ (pp : ((b₀ ⟶ x) × (b₁ ⟶ x)) × ((b₀' ⟶ x) × (b₁' ⟶ x))), ((pp.1.1, pp.2.1), (pp.1.2, pp.2.2)),
             inv_fun := λ qq, ⟨⟨qq.1.1, qq.2.1⟩, ⟨qq.1.2, qq.2.2⟩⟩,
             left_inv := assume ⟨⟨_,_⟩,⟨_,_⟩⟩, rfl,
             right_inv := assume ⟨⟨_,_⟩,⟨_,_⟩⟩, rfl }
           {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | qq.1.1 ∘ f₀ = qq.2.1 ∘ f₁ ∧ qq.1.2 ∘ f₀' = qq.2.2 ∘ f₁'}
  ...  ~~ {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | coprod.induced qq.1.1 qq.1.2 ∘ coprod_of_maps f₀ f₀' =
            coprod.induced qq.2.1 qq.2.2 ∘ coprod_of_maps f₁ f₁' }
       :
  begin
    convert Bij_on.refl _,
    ext qq, change _ = _ ↔ _ = _ ∧ _ = _,
    rw [coprod.ext, ←assoc, ←assoc, ←assoc, ←assoc],
    simp
  end
  ...  ~~ {qq : (b₀ ⊔ b₀' ⟶ x) × (b₁ ⊔ b₁' ⟶ x)
          | qq.1 ∘ coprod_of_maps f₀ f₀' = qq.2 ∘ coprod_of_maps f₁ f₁'}
       : Bij_on.restrict''
           (Bij_on.prod'
             (Bij_on.of_Is_equiv coprod.induced_Is_equiv)
             (Bij_on.of_Is_equiv coprod.induced_Is_equiv))
           {qq : (b₀ ⊔ b₀' ⟶ x) × (b₁ ⊔ b₁' ⟶ x)
           | qq.1 ∘ coprod_of_maps f₀ f₀' = qq.2 ∘ coprod_of_maps f₁ f₁'},
  begin
    convert this,
    funext k, apply prod.ext; apply coprod.uniqueness;
    { change _ ∘ _ ∘ _ = _ ∘ _, simp [coproduct_comparison],
      rw ←assoc, simp, refl },
  end

end coprod_of_pushouts

section pushout_i

parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]
-- Obviously we shouldn't really need C to have an initial object here, but oh well
parameters [has_initial_object.{v} C]
parameters {a b c : C} (f : a ⟶ b)

/-
  a → a ⊔ c
  ↓     ↓
  b → b ⊔ c
-/

def Is_pushout_i₀ : Is_pushout f i₀ i₀ (coprod_of_maps f (𝟙 c)) :=
let po := Is_pushout_coprod (Is_pushout.refl f) (Is_pushout.refl (! c)).transpose in
by convert Is_pushout_of_isomorphic po f i₀
     (coprod_initial_right a) (coprod_initial_right b) (iso.refl _) _ _; simp

/-
  a → c ⊔ a
  ↓     ↓
  b → c ⊔ b
-/

def Is_pushout_i₁ : Is_pushout f i₁ i₁ (coprod_of_maps (𝟙 c) f) :=
let po := Is_pushout_coprod (Is_pushout.refl (! c)).transpose (Is_pushout.refl f) in
by convert Is_pushout_of_isomorphic po f i₁
     (coprod_initial_left a) (coprod_initial_left b) (iso.refl _) _ _; simp

end pushout_i

section pushout_swap
parameters {C : Type u} [category.{v} C]
parameters {a b c : C} {f : a ⟶ b} {g₀ g₁ : b ⟶ c} (po : Is_pushout f f g₀ g₁)

def Is_pushout.swap : c ⟶ c := po.induced g₁ g₀ po.commutes.symm

def Is_pushout.swap_iso : c ≅ c :=
{ hom := po.swap,
  inv := po.swap,
  hom_inv_id' := by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp,
  inv_hom_id' := by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp }

@[simp] def Is_pushout.induced_swap {x} {h₀ h₁ : b ⟶ x} {p p'} :
  po.induced h₀ h₁ p ∘ po.swap = po.induced h₁ h₀ p' :=
by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp

end pushout_swap

section pushout_of_maps
parameters {C : Type u} [category.{v} C]
variables {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
variables {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
variables {a' b₀' b₁' c' : C} {f₀' : a' ⟶ b₀'} {f₁' : a' ⟶ b₁'}
variables {g₀' : b₀' ⟶ c'} {g₁' : b₁' ⟶ c'} (po' : Is_pushout f₀' f₁' g₀' g₁')
variables {a'' b₀'' b₁'' c'' : C} {f₀'' : a'' ⟶ b₀''} {f₁'' : a'' ⟶ b₁''}
variables {g₀'' : b₀'' ⟶ c''} {g₁'' : b₁'' ⟶ c''} (po'' : Is_pushout f₀'' f₁'' g₀'' g₁'')
variables (ha : a ⟶ a') (hb₀ : b₀ ⟶ b₀') (hb₁ : b₁ ⟶ b₁')
variables (h₀ : hb₀ ∘ f₀ = f₀' ∘ ha) (h₁ : hb₁ ∘ f₁ = f₁' ∘ ha)
variables (ka : a' ⟶ a'') (kb₀ : b₀' ⟶ b₀'') (kb₁ : b₁' ⟶ b₁'')
variables (k₀ : kb₀ ∘ f₀' = f₀'' ∘ ka) (k₁ : kb₁ ∘ f₁' = f₁'' ∘ ka)

include po po' h₀ h₁

def pushout_of_maps : c ⟶ c' :=
po.induced (g₀' ∘ hb₀) (g₁' ∘ hb₁)
  (by rw [←assoc, ←assoc, h₀, h₁]; simp [po'.commutes])

omit po po' h₀ h₁

lemma induced_pushout_of_maps {x : C} {k₀ : b₀' ⟶ x} {k₁ : b₁' ⟶ x} {e} :
  po'.induced k₀ k₁ e ∘ pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ = po.induced (k₀ ∘ hb₀) (k₁ ∘ hb₁)
    (by rw [←assoc, ←assoc, h₀, h₁]; simp [e]) :=
begin
  unfold pushout_of_maps,
  apply po.uniqueness; { rw ←assoc, simp }
end

@[simp] lemma pushout_of_maps_commutes₀ : pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ∘ g₀ = g₀' ∘ hb₀ :=
by simp [pushout_of_maps]

@[simp] lemma pushout_of_maps_commutes₁ : pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ∘ g₁ = g₁' ∘ hb₁ :=
by simp [pushout_of_maps]

lemma pushout_of_maps_id : pushout_of_maps po po (𝟙 a) (𝟙 b₀) (𝟙 b₁) (by simp) (by simp) = 𝟙 _ :=
by apply pushout_induced_eq_iff; simp

lemma pushout_of_maps_comp :
  pushout_of_maps po po'' (ha ≫ ka) (hb₀ ≫ kb₀) (hb₁ ≫ kb₁)
    (by rw [←assoc, h₀, assoc, k₀, ←assoc]) (by rw [←assoc, h₁, assoc, k₁, ←assoc]) =
  pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ≫ pushout_of_maps po' po'' ka kb₀ kb₁ k₀ k₁ :=
by apply pushout_induced_eq_iff; rw ←assoc; simp

end pushout_of_maps

end category_theory


import tactic
import category_theory.functor
import data.W.basic
import category_theory.closed.types
import algebra.category.CommRing.basic
import algebra.category.Module.basic

universes u v w x

open category_theory
--W

variables {𝒞 : Type u} [category.{v} 𝒞]

@[protect_proj] class struc (F : 𝒞 → Type w) :=
( hom : Π {A B : 𝒞} (f : A ⟶ B) (a : F A) (b : F B), Type x )
( id : Π {A : 𝒞} (a : F A), hom (𝟙 A) a a )
( comp : Π {A B C : 𝒞} {a : F A} {b : F B} {c : F C}
    {f : A ⟶ B} {g : B ⟶ C} (f' : hom f a b) (g' : hom g b c)
    {h : A ⟶ C} (H : f ≫ g = h), hom h a c )
( id_comp : Π {A B : 𝒞} {f : A ⟶ B} {a : F A} {b : F B}
    (f' : hom f a b), comp (id a) f' (category.id_comp f) = f' )
( comp_id : Π {A B : 𝒞} {f : A ⟶ B} {a : F A} {b : F B}
    (f' : hom f a b), comp f' (id b) (category.comp_id f) = f' )
( assoc : Π {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : hom f a b) (g' : hom g b c) (h' : hom h c d),
    comp (comp f' g' rfl) h' rfl = comp f' (comp g' h' rfl)
      (category.assoc _ _ _).symm )

-- @[protect_proj] class GS (F : 𝒞 → Type w) :=
-- ( hom : Π {A B : 𝒞} (f : A ⟶ B) (a : F A) (b : F B), Type x )
-- ( id : Π {A : 𝒞} (a b : F A) (h : a = b) (f : A ⟶ A) (hf : f = 𝟙 A), hom f a b )

attribute [simp] struc.id_comp struc.comp_id

namespace struc

variables (F : 𝒞 → Type w) [struc F]

lemma assoc_left {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : struc.hom f a b) (g' : struc.hom g b c) (h' : struc.hom h c d)
    (i : A ⟶ C) (k : A ⟶ D)
    (hi : f ≫ g = i) (hk : i ≫ h = k) :
    struc.comp (struc.comp f' g' hi) h' hk = struc.comp f'
      (struc.comp g' h' rfl) (by rw [← hk, ← hi, category.assoc]) :=
begin
  substs i k,
  rw struc.assoc,
end

lemma comp_eq_cast {A B C : 𝒞} {f : A ⟶ B} {g : B ⟶ C}
  {a : F A} {b : F B} {c : F C} (f' : struc.hom f a b) (g' : struc.hom g b c)
  (i : A ⟶ C) (hi : f ≫ g = i)
  (j : A ⟶ C) (hj : f ≫ g = j) :
  struc.comp f' g' hi = cast (by substs i j) (struc.comp f' g' hj) :=
begin
  substs i j, refl
end

lemma assoc_left' {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : struc.hom f a b) (g' : struc.hom g b c) (h' : struc.hom h c d)
    (i : A ⟶ C) (k : A ⟶ D)
    (hi : f ≫ g = i) (hk : i ≫ h = k) :
    struc.comp (struc.comp f' g' hi) h' hk = cast (by rw [← hk, ← hi, category.assoc])
      (struc.comp f' (struc.comp g' h' rfl) rfl)  :=
begin
  rw struc.assoc_left,
  substs i k,
  rw [comp_eq_cast]
end

lemma id_comp' {A B : 𝒞} {f : A ⟶ B} (g : A ⟶ B) {a : F A} {b : F B}
  (h : 𝟙 A ≫ f = g) (f' : struc.hom f a b) :
  struc.comp (struc.id a) f' h = cast (by rw [← h, category.id_comp]) f' :=
begin
  rw [category.id_comp] at h,
  subst h,
  simp
end

lemma comp_id' {A B : 𝒞} {f : A ⟶ B} (g : A ⟶ B) {a : F A} {b : F B}
  (h : f ≫ 𝟙 B = g) (f' : struc.hom f a b) :
  struc.comp f' (struc.id b) h = cast (by rw [← h, category.comp_id]) f' :=
begin
  rw [category.comp_id] at h,
  subst h,
  simp
end

instance  : category_struct (sigma F) :=
{ hom := λ A B, Σ (f : A.1 ⟶ B.1), struc.hom f A.2 B.2,
  id := λ A, ⟨𝟙 A.1, struc.id A.2⟩,
  comp := λ A B C f g, ⟨f.1 ≫ g.1, struc.comp f.2 g.2 rfl⟩ }

@[simp] lemma comp_fst {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).fst = f.1 ≫ g.1 := rfl

@[simp] lemma comp_snd {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).snd = struc.comp f.2 g.2 rfl := rfl

@[simp] lemma id_fst {A : sigma F} : sigma.fst (𝟙 A) = 𝟙 A.1 := rfl

@[simp] lemma id_snd {A : sigma F} : sigma.snd (𝟙 A) = struc.id A.2 := rfl

instance sigma.category : category (sigma F) :=
{ id_comp' := λ A B f, sigma.ext (category.id_comp _) $
    by simp [struc.id_comp'],
  comp_id' := λ A B f, sigma.ext (category.comp_id _) $
    by simp [struc.comp_id'],
  assoc' := λ A B C D f g h, sigma.ext (category.assoc _ _ _) $
    by simp [assoc_left'] }

instance (X : 𝒞) : category_struct (F X) :=
{ hom := λ A B, struc.hom (𝟙 X) A B,
  id := λ A, struc.id A,
  comp := λ A B C f g, (struc.comp f g (category.id_comp _)) }

instance (X : 𝒞) : category (F X) :=
{ id_comp' := λ A B f, struc.id_comp _,
  comp_id' := λ A B f, struc.comp_id _,
  assoc' := λ A B C D f g h,
    show (f ≫ g) ≫ h = f ≫ g ≫ h,
      begin
        dsimp [category_struct.comp],
        rw [struc.assoc_left],
        congr' 2; simp
      end }

def forget : sigma F ⥤ 𝒞 :=
{ obj := sigma.fst,
  map := λ _ _, sigma.fst }

def thing (X : 𝒞) : F X ⥤ sigma F :=
{ obj := λ A, ⟨X, A⟩,
  map := λ A B f, ⟨𝟙 X, f⟩,
  map_id' := λ A, rfl,
  map_comp' := λ A B C f g, sigma.ext
    (by simp) begin simp only [comp_snd],
       rw [struc.comp_eq_cast F f g (𝟙 X ≫ 𝟙 X) rfl (𝟙 X)
         (category.comp_id _)],
       symmetry,
       rw [← cast_eq_iff_heq],
       simp, refl,
       simp,
     end }

instance inst1 (F : 𝒞 ⥤ Type) : struc F.obj :=
{ hom := λ A B f a b, plift (F.map f a = b),
  id := λ A a, ⟨by simp⟩,
  comp := λ A B C a b c f g h₁ h₂ _ h, ⟨by simp [← h, F.map_comp, h₁.down, h₂.down]⟩,
  assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
    begin simp [h₁.down, h₂.down, h₃.down] end,
  id_comp := λ _ _ _ _ _ h,
    begin simp [h.down] end,
  comp_id := λ _ _ _ _ _ h,
    begin simp [h.down] end }

-- instance inst2 (F : 𝒞 ⥤ Typeᵒᵖ) : struc (λ x, (F.obj x).unop) :=
-- { hom := λ A B f a b, plift ((F.map f).unop b = a),
--   id := λ A a, ⟨by simp⟩,
--   comp := λ A B C a b c f g h₁ h₂, ⟨by simp [F.map_comp, h₁.down, h₂.down]⟩,
--   assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
--     begin refine heq_of_cast_eq _ _;
--       simp [h₁.down, h₂.down, h₃.down] end,
--   id_comp := λ _ _ _ _ _ h,
--     begin refine heq_of_cast_eq _ _; simp [h.down] end,
--   comp_id := λ _ _ _ _ _ h,
--     begin refine heq_of_cast_eq _ _; simp [h.down] end }

example : struc (λ R : Ring, Module R) :=
{ hom := λ R S f M₁ M₂, M₁ →ₛₗ[f] M₂,
  id := λ R M, linear_map.id,
  comp := λ R S T M₁ M₂ M₃ f g f' g' _ h,
    @linear_map.comp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ⟨h⟩ g' f',
  id_comp := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl
    end,
  comp_id := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl,
    end,
  assoc := λ R S T U f g h M₁ M₂ M₃ M₄ f' g' h',
    begin
      cases f, cases g, cases h, cases f', cases g', cases h',
      refl
    end }

example (F : 𝒞 ⥤ Type) (G : 𝒞 → Type) [struc G] : struc (λ A : 𝒞, F.obj A → G A) :=
{ hom := λ X Y f x y, Π (a : F.obj X) (b : F.obj Y), struc.hom f (x a) (y (F.map f a)),
  id := λ X x a, cast (by simp) (struc.id (x a)),
  comp := λ X Y Z x y z f g f' g' _ h a, struc.comp (f' a)
    (g' (F.map f a)) _,
  id_comp := λ X Y f x y f', begin
      apply function.hfunext,
      { refl },
      { intros a a' h,
        rw [heq_iff_eq] at h,
        subst a',
        refine cast_eq_iff_heq.1 _,
        simp,
        simp, admit }
    end,
  comp_id := sorry,
  assoc := λ W X Y Z f g h w x y z f' g' h',
    begin
      apply function.hfunext,
    { refl },
    { intros a a' h,
      rw [heq_iff_eq] at h,
      subst a',
      dsimp,
      admit }

    end }

def pi.struc (F : 𝒞 ⥤ Type) (G : (Σ A : 𝒞, F.obj A) → Type) [struc G] :
  struc (λ A : 𝒞, Π a : F.obj A, G ⟨A, a⟩) :=
{ hom := λ X Y f x y, Π (a : F.obj X),
    @struc.hom _ _ G _ ⟨X, a⟩ ⟨Y, F.map f a⟩ ⟨f, ⟨rfl⟩⟩ (x a) (y (F.map f a)),
  id := λ X x a, by convert @struc.id _ _ G _ ⟨X, a⟩ (x a); simp,
  comp := sorry,
  id_comp := sorry,
  comp_id := sorry,
  assoc := sorry }

-- Maybe think about W.

end struc


import data.cpi.species

namespace cpi

/-- A concretion represents the potential for a species to interact with another.
    -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive concretion (ℍ : Type) (ω : context) : context → ℕ → ℕ → Type
| apply {Γ} {b} (bs : vector (name Γ) b) (y : ℕ)
  : species ℍ ω (context.extend y Γ)
  → concretion Γ b y
| parallel₁ {Γ} {b y} : concretion Γ b y → species ℍ ω Γ → concretion Γ b y
| parallel₂ {Γ} {b y} : species ℍ ω Γ → concretion Γ b y → concretion Γ b y
| restriction {Γ} {b y} (M : affinity ℍ)
  : concretion (context.extend M.arity Γ) b y
  → concretion Γ b y

notation `#(` b ` ; ` y `)` A := concretion.apply b y A

reserve infixr ` |₁ ` :50
reserve infixr ` |₂ ` :50

infixr ` |₁ ` := concretion.parallel₁
infixr ` |₂ ` := concretion.parallel₂

notation `ν'(` M `) ` A := concretion.restriction M A

variables {ℍ : Type} {ω : context}

namespace concretion

/-- Convert a concretion to a string. Can use `repr` normally. -/
protected def to_string [has_repr ℍ]: ∀ {Γ} {b y} , concretion ℍ ω Γ b y → string
| ._ ._ ._ (concretion.apply bs y A') := "(" ++ repr bs.val ++ ";" ++ repr y ++ ")" ++ repr A'
| ._ ._ ._ (F |₁ A') := "(" ++ to_string F ++ " | " ++ repr A' ++ ")"
| ._ ._ ._ (A' |₂ F) := "(" ++ repr A' ++ " | " ++ to_string F ++ ")"
| ._ ._ ._ (ν'(M) A') := "(ν ?)(" ++ to_string A' ++ ")"

instance [has_repr ℍ] {b y} {Γ} : has_repr (concretion ℍ ω b y Γ) := ⟨ concretion.to_string ⟩

section free
  /-- Determine whether a level occurs within a concretion. -/
  def free_in : ∀ {Γ} {b y} (l : level Γ) (F : concretion ℍ ω Γ b y), Prop
  | Γ b y l (#(bs; _) A) := (∃ b ∈ bs.val, l ∈ b) ∨ level.extend l ∈ A
  | Γ b y l (F |₁ A) := free_in l F ∨ l ∈ A
  | Γ b y l (A |₂ F) := l ∈ A ∨ free_in l F
  | Γ b y l (ν'(M) F) := free_in (level.extend l) F

  instance {Γ} {b y} : has_mem (level Γ) (concretion ℍ ω Γ b y) := ⟨ free_in ⟩

  private def free_in_decide : ∀ {Γ} {b y} (l : level Γ) (F : concretion ℍ ω Γ b y), decidable (free_in l F)
  | Γ b y l (#(bs; _) A) := by { unfold free_in, apply_instance }
  | Γ b y l (F |₁ A) := @or.decidable _ _ (free_in_decide l F) _
  | Γ b y l (A |₂ F) := @or.decidable _ _ _ (free_in_decide l F)
  | Γ b y l (ν'(M) F) := free_in_decide (level.extend l) F

  instance free_in.decidable {Γ} {b y} {l} {F : concretion ℍ ω Γ b y} : decidable (l ∈ F)
    := free_in_decide l F
end free

section rename
  /-- Rename a concretion. -/
  def rename : ∀ {Γ Δ} {b y} (ρ : name Γ → name Δ), concretion ℍ ω Γ b y → concretion ℍ ω Δ b y
  | Γ Δ b y ρ (#(bs; _) A) := #( vector.map ρ bs; y) species.rename (name.ext ρ) A
  | Γ Δ b y ρ (F |₁ A) := rename ρ F |₁ species.rename ρ A
  | Γ Δ b y ρ (A |₂ F) := species.rename ρ A |₂ rename ρ F
  | Γ Δ b y ρ (ν'(M) A) := ν'(M) (rename (name.ext ρ) A)

  lemma rename_id
    : ∀ {Γ} {b y} (F : concretion ℍ ω Γ b y)
    , rename id F = F
  | Γ b ._ (#(⟨ list, n ⟩; y) A) := begin
      simp only [rename, vector.map, list.map_id, subtype.mk_eq_mk],
      rw name.ext_id,
      from ⟨ rfl, species.rename_id A ⟩
    end
  | Γ b y (F |₁ A) := begin
      simp only [rename],
      from ⟨ rename_id F, species.rename_id A ⟩
    end
  | Γ b y (A |₂ F) := begin
      simp only [rename],
      from ⟨ species.rename_id A, rename_id F ⟩
    end
  | Γ b y (ν'(M) F) := begin
      simp only [rename], rw name.ext_id,
      from ⟨ rfl, heq_of_eq (rename_id F) ⟩,
    end

  lemma rename_compose :
    ∀ {Γ Δ η} {b y} (ρ : name Γ → name Δ) (σ : name Δ → name η) (A : concretion ℍ ω Γ b y)
    , rename σ (rename ρ A) = rename (σ ∘ ρ) A
  | Γ Δ η b ._ ρ σ (#(⟨ elem, n ⟩; y) A) := begin
      unfold rename vector.map,
      rw [species.rename_compose _ _ A, name.ext_comp],
      simp
    end
  | Γ Δ η b y ρ σ (F |₁ A) := begin
      unfold rename,
      rw [rename_compose ρ σ F, species.rename_compose ρ σ A]
    end
  | Γ Δ η b y ρ σ (A |₂ F) := begin
      unfold rename,
      rw [rename_compose ρ σ F, species.rename_compose ρ σ A]
    end
  | Γ Δ η b y ρ σ (ν'(M) A) := begin
      unfold rename,
      rw [rename_compose (name.ext ρ) (name.ext σ) A, name.ext_comp]
    end

end rename

end concretion

/-- A quotient of all equivalent concretions. -/
@[nolint has_inhabited_instance]
def concretion' (ℍ : Type) (ω Γ : context) (b y : ℕ) [r : setoid (concretion ℍ ω Γ b y)]
  := quotient r

end cpi

#lint-