import category_theory.limits.preserves.limits
import for_mathlib.derived.K_projective
import for_mathlib.AddCommGroup.explicit_limits

open category_theory
open category_theory.limits

universes v u
variables {A : Type u} [category.{v} A] [abelian A] [has_coproducts.{v} A]

open_locale zero_object

namespace category_theory

instance is_iso_coproduct {α : Type v} (X Y : α → A) (f : Π a, X a ⟶ Y a)
  [∀ a, is_iso (f a)] :
  is_iso (sigma.desc $ λ a, f a ≫ sigma.ι _ a) :=
begin
  use sigma.desc (λ a, inv (f a) ≫ sigma.ι _ a),
  split,
  { ext, dsimp, cases j, simp },
  { ext, dsimp, cases j, simp }
end

noncomputable
lemma is_initial_colimit {J : Type v} [small_category J] (K : J ⥤ A)
  (hK : ∀ j, is_initial (K.obj j)) [has_colimit K] :
  is_initial (colimit K) :=
{ desc := λ T, colimit.desc _ ⟨_,
  { app := λ j, (hK j).to _,
    naturality' := λ i j f, (hK _).hom_ext _ _ }⟩,
  fac' := by rintros S ⟨⟨⟩⟩,
  uniq' := begin
    intros S m hm, apply colimit.hom_ext, intros j,
    apply (hK _).hom_ext
  end }

lemma is_zero_colimit {J : Type v} [small_category J] (K : J ⥤ A)
  (hK : ∀ j, is_zero (K.obj j)) [has_colimit K] :
  is_zero (colimit K) :=
begin
  suffices : is_initial (colimit K),
  { let e : colimit K ≅ ⊥_ _ := (initial_iso_is_initial this).symm,
    apply is_zero_of_iso_of_zero _ e.symm,
    apply is_zero_initial },
  apply is_initial_colimit,
  intros j,
  apply is_zero.is_initial,
  apply hK,
end

noncomputable
def preadditive_yoneda_coproduct_to_product {A : Type u} [category.{v} A]
  [preadditive A]
  {α : Type v} (X : α → A) [has_coproduct X] (Y : A) :
  (preadditive_yoneda.obj Y).obj (opposite.op $ sigma_obj X) ⟶
  pi_obj (λ a, (preadditive_yoneda.obj Y).obj (opposite.op $ X a)) :=
pi.lift $ λ b, functor.map _ $ quiver.hom.op $ sigma.ι _ _

set_option pp.universes true

instance is_iso_preadditive_yoneda_coproduct_to_product
  {A : Type u} [category.{v} A]
  [preadditive A]
  {α : Type v} (X : α → A) [has_coproduct X] (Y : A) :
  is_iso (preadditive_yoneda_coproduct_to_product X Y) :=
begin
  apply is_iso_of_reflects_iso _ (forget AddCommGroup),
  rw is_iso_iff_bijective,
  split,
  { intros f g h, dsimp [preadditive_yoneda_coproduct_to_product] at f g h ⊢,
    apply colimit.hom_ext,
    intros a,
    let q : (∏ λ (a : α), AddCommGroup.of (X a ⟶ Y)) ⟶ (AddCommGroup.of (X a.1 ⟶ Y)) :=
      pi.π _ a.1,
    apply_fun (λ e, q e) at h,
    simp only [← comp_apply, limit.lift_π] at h, cases a, exact h },
  { intros f, dsimp at f,
    let P : Π a, (∏ λ (a : α), AddCommGroup.of (X a ⟶ Y)) ⟶ (AddCommGroup.of (X a ⟶ Y)) :=
      λ a, pi.π _ a,
    let q : sigma_obj X ⟶ Y := sigma.desc (λ a, P a f),
    use q,
    apply concrete.limit_ext (discrete.functor (λ a, AddCommGroup.of (X a ⟶ Y))),
    intros i, dsimp [preadditive_yoneda_coproduct_to_product],
    simp only [← comp_apply, limit.lift_π],
    dsimp, rw colimit.ι_desc, cases i, refl }
end

noncomputable
def preadditive_yoneda_coproduct_iso {A : Type u} [category.{v} A]
  [preadditive A]
  {α : Type v} (X : α → A) [has_coproduct X] (Y : A) :
  (preadditive_yoneda.obj Y).obj (opposite.op $ sigma_obj X) ≅
  pi_obj (λ a, (preadditive_yoneda.obj Y).obj (opposite.op $ X a)) :=
as_iso (preadditive_yoneda_coproduct_to_product _ _)

noncomputable
def pi_iso {A : Type u} [category.{v} A] {α : Type v}
  (X Y : α → A)
  (I : Π a, X a ≅ Y a)
  [has_product X] [has_product Y] :
  pi_obj X ≅ pi_obj Y :=
{ hom := pi.lift $ λ b, pi.π _ _ ≫ (I b).hom,
  inv := pi.lift $ λ b, pi.π _ _ ≫ (I b).inv,
  hom_inv_id' := begin
    apply limit.hom_ext, rintros ⟨i⟩,
    simp,
  end,
  inv_hom_id' := begin
    apply limit.hom_ext, rintros ⟨i⟩,
    simp,
  end }

end category_theory

namespace homotopy_category

noncomputable
def coproduct_iso {α : Type v} (X : α → cochain_complex A ℤ) (i) :
  (sigma_obj X).X i ≅ sigma_obj (λ a : α, (X a).X i) :=
(category_theory.preserves_colimit_iso (homological_complex.eval A
  (complex_shape.up ℤ) i) (discrete.functor X)) ≪≫
  has_colimit.iso_of_nat_iso
  (nat_iso.of_components (λ _, iso.refl _) begin
    rintros ⟨⟩ ⟨⟩ ⟨⟨⟨⟩⟩⟩,
    simp,
  end)

@[simp, reassoc]
lemma coproduct_ι_coproduct_iso_inv {α : Type v} (X : α → cochain_complex A ℤ) (i) (a) :
  sigma.ι _ a ≫ (coproduct_iso X i).inv = ((sigma.ι X a : _ ⟶ _)).f i :=
begin
  dsimp [coproduct_iso, has_colimit.iso_of_nat_iso,
    is_colimit.map, preserves_colimit_iso, is_colimit.cocone_point_unique_up_to_iso],
  simp, dsimp, simp,
end

@[simp, reassoc]
lemma coproduct_ι_coproduct_iso_hom {α : Type v} (X : α → cochain_complex A ℤ) (i) (a : α) :
  (sigma.ι X a : _ ⟶ _).f i ≫ (coproduct_iso X i).hom = sigma.ι _ a :=
begin
  dsimp [coproduct_iso, has_colimit.iso_of_nat_iso,
    is_colimit.map, preserves_colimit_iso, is_colimit.cocone_point_unique_up_to_iso],
  slice_lhs 0 1
  { erw (is_colimit_of_preserves (homological_complex.eval A (complex_shape.up ℤ) i)
    (colimit.is_colimit (discrete.functor X))).fac },
  simp, dsimp, simp,
end

noncomputable
def homotopy_coprod {α : Type v} (X : α → cochain_complex A ℤ) (Y)
  (f g : sigma_obj X ⟶ Y)
  (h : Π a, homotopy (sigma.ι _ a ≫ f) (sigma.ι _ a ≫ g)) :
  homotopy f g :=
{ hom := λ i j, (coproduct_iso X i).hom ≫
    (sigma.desc $ λ a, (h a).hom _ _),
  zero' := begin
    intros i j hh,
    simp only [preadditive.is_iso.comp_left_eq_zero],
    apply colimit.hom_ext, intros a,
    simp only [colimit.ι_desc, cofan.mk_ι_app, comp_zero, (h a.1).zero' i j hh],
  end,
  comm := begin
    intros i,
    rw ← cancel_epi (coproduct_iso X i).inv,
    apply colimit.hom_ext, rintros ⟨a⟩,
    simp only [coproduct_ι_coproduct_iso_inv_assoc, homological_complex.cochain_complex_d_next,
      homological_complex.cochain_complex_prev_d, category.assoc, preadditive.comp_add,
      homological_complex.hom.comm_assoc, coproduct_ι_coproduct_iso_hom_assoc,
      colimit.ι_desc, cofan.mk_ι_app, colimit.ι_desc_assoc],
    have := (h a).comm i,
    refine this.trans _,
    simp only [homological_complex.cochain_complex_d_next,
      homological_complex.cochain_complex_prev_d],
    refl
  end }

lemma homotopic_coprod {α : Type v} (X : α → cochain_complex A ℤ) (Y)
  (f g : sigma_obj X ⟶ Y)
  (h : ∀ a : α, homotopic _ _ (sigma.ι _ a ≫ f) (sigma.ι _ a ≫ g)) :
  homotopic _ _ f g :=
begin
  constructor,
  apply homotopy_coprod,
  intros a,
  exact (h a).some,
end

-- Move this
lemma homotopic_of_quotient_map_eq {X Y : cochain_complex A ℤ}
  (f g : X ⟶ Y) (h : (quotient _ _).map f = (quotient _ _).map g) :
  homotopic _ _ f g :=
begin
  erw quotient.functor_map_eq_iff at h, assumption,
end

noncomputable
def colimit_cofan {α : Type v} (X : α → homotopy_category A (complex_shape.up ℤ)) :
  cofan X :=
cofan.mk
((quotient _ _).obj $ sigma_obj (λ a, (X a).as))
(λ a, (quotient _ _).map $ sigma.ι _ a)

noncomputable
def is_colimit_cofan {α : Type v} (X : α → homotopy_category A (complex_shape.up ℤ)) :
  is_colimit (colimit_cofan X) :=
{ desc := λ S, (quotient _ _).map $ sigma.desc $ λ a, (S.ι.app ⟨a⟩).out,
  fac' := begin
    rintros S ⟨j⟩,
    dsimp,
    erw [← (quotient A (complex_shape.up ℤ)).map_comp, colimit.ι_desc],
    dsimp [quotient],
    simp,
  end,
  uniq' := begin
    intros S m hm,
    let mm := m.out,
    have : (quotient _ _).map mm = m, by simp,
    rw ← this,
    apply quot.sound,
    apply quotient.comp_closure.of,
    apply homotopic_coprod,
    intros a,
    specialize hm ⟨a⟩, rw ← this at hm, dsimp at hm,
    erw [← (quotient A (complex_shape.up ℤ)).map_comp] at hm,
    erw colimit.ι_desc,
    dsimp,
    have : S.ι.app ⟨a⟩ = (quotient _ _).map (S.ι.app ⟨a⟩).out, by simp,
    rw this at hm,
    apply homotopic_of_quotient_map_eq,
    exact hm
  end }

instance {α : Type v} (X : α → homotopy_category A (complex_shape.up ℤ)) :
  has_coproduct X :=
{ exists_colimit := nonempty.intro $ ⟨colimit_cofan _, is_colimit_cofan _⟩ }

instance {α : Type v} : has_colimits_of_shape (discrete α)
  (homotopy_category A (complex_shape.up ℤ)) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (λ n, K.obj ⟨n⟩) := discrete.nat_iso (λ ⟨i⟩, iso.refl _),
  apply has_colimit_of_iso E,
end

noncomputable
instance {α : Type v} : preserves_colimits_of_shape (discrete α)
  (quotient A (complex_shape.up ℤ)) :=
begin
  constructor, intros K,
  apply preserves_colimit_of_preserves_colimit_cocone
    (colimit.is_colimit K),
  let T : K ⋙ quotient A _ ≅ discrete.functor
    ((λ a : α, (quotient _ _).obj ((λ n, K.obj ⟨n⟩) a))) := nat_iso.of_components
    (λ ⟨i⟩, iso.refl _) _,
  swap,
  { rintros ⟨i⟩ ⟨⟩ ⟨⟨⟨⟩⟩⟩,
    dsimp,
    simp only [category_theory.functor.map_id, category.id_comp],
    dsimp,
    simp only [category.comp_id]},
  apply (is_colimit.precompose_inv_equiv T
    ((quotient A (complex_shape.up ℤ)).map_cocone (colimit.cocone K))).to_fun,
  let ee : colimit_cofan (λ a : α, (quotient _ _).obj (K.obj ⟨a⟩)) ≅
    (cocones.precompose T.inv).obj
    ((quotient A (complex_shape.up ℤ)).map_cocone (colimit.cocone K)) := _,
  swap,
  { refine cocones.ext _ _,
    { apply functor.map_iso,
      refine has_colimit.iso_of_nat_iso _,
      refine nat_iso.of_components (λ ⟨i⟩, iso.refl _) _,
      rintro ⟨i⟩ ⟨⟩ ⟨⟨⟨⟩⟩⟩,
      dsimp,
      simp only [discrete.functor_map_id, category.comp_id],
      dsimp,
      simp only [category.id_comp]},
    rintros ⟨i⟩,
    dsimp [colimit_cofan, T, nat_iso.of_components,
      has_colimit.iso_of_nat_iso, is_colimit.map],
    simp only [← functor.map_comp, category.id_comp, colimit.ι_desc],
    dsimp [cocones.precompose],
    simpa only [functor.map_comp] },
  apply is_colimit.of_iso_colimit _ ee,
  apply is_colimit_cofan,
end

instance is_K_projective_sigma {α : Type v}
  (X : α → homotopy_category A (complex_shape.up ℤ))
  [∀ a, is_K_projective (X a)] : is_K_projective (sigma_obj X) :=
begin
  constructor,
  introsI Y hY f,
  apply colimit.hom_ext,
  rintros ⟨a⟩,
  rw comp_zero,
  apply is_K_projective.cond Y,
  dsimp, apply_instance,
end

instance is_K_projective_colimit_cofan {α : Type v}
  (X : α → homotopy_category A (complex_shape.up ℤ))
  [∀ a, is_K_projective (X a)] : is_K_projective (colimit_cofan X).X :=
begin
  let e : (colimit_cofan X).X ≅ sigma_obj X :=
    (is_colimit_cofan X).cocone_point_unique_up_to_iso (colimit.is_colimit _),
  apply is_K_projective_of_iso _ _ e.symm,
end

end homotopy_category


def Ctx := String → Type
abbrev State (Γ : Ctx) := {x : String} → Γ x

opaque p {Γ : Ctx} (s : State Γ) : Prop

theorem ex {Γ : Ctx} (s : State Γ) (h : (a : State Γ) → @p Γ a) : @p Γ s :=
  h ‹_›


import tactic algebra.big_operators.fin

universes u v

open_locale big_operators

def fintype_sup {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α] [order_bot α] (f : ι → α) : α :=
  (finset.univ : finset ι).sup f

notation `⋁ ` binders `, ` r:(scoped f, fintype_sup f) := r

namespace fintype
variables {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α]  [order_bot α] (f : ι → α)

lemma le_fintype_sup {n} (f : fin n → α) (i : fin n) :
  f i ≤ ⋁ j, f j := @finset.le_sup _ _ _ _ _ f i (by simp)

@[simp] lemma fintype_fin {n} (f : fin (n + 1) → α) :
  (⋁ i : fin (n + 1), f i) = (f 0 ⊔ ⋁ i : fin n, f i.succ) :=
begin
  refine le_antisymm_iff.mpr _, simp[fintype_sup], split,
  { intros m,
    have : m = 0 ∨ ∃ (j : fin n), m = j.succ, from fin.eq_zero_or_eq_succ m,
    rcases this with (rfl | ⟨j, rfl⟩); try {simp},
    refine le_sup_of_le_right
      (@finset.le_sup _ _ _ _ _ (λ (i : fin n), f i.succ) j (by simp)) },
  split,
  { refine le_fintype_sup f 0 },
  intros i,
  refine le_fintype_sup f _
end

end fintype

notation `𝔹` := list bool

def safe_case : vector 𝔹 3 → 𝔹
| ⟨[tt :: b, w, v], _⟩ := v
| ⟨[_, w, v], _⟩       := w

def fgegegeg (n : ℕ) : (fin n → ℕ) → vector ℕ n :=
by { exact vector.of_fn }

def safe_rec
  {m n i}
  (f  : fin i → (vector 𝔹 m → vector 𝔹 n → 𝔹))
  (g₀ : fin i → vector 𝔹 (m + 1) → vector 𝔹 (n + i) → 𝔹)
  (g₁ : fin i → vector 𝔹 (m + 1) → vector 𝔹 (n + i) → 𝔹)
   : fin i → vector 𝔹 (m + 1) → vector 𝔹 n → 𝔹
| j ⟨[]        :: w, p⟩ v := f j ⟨w, by simpa using p⟩ v
| j ⟨(ff :: x) :: w, p⟩ v := g₀ j ⟨x :: w, by simpa using p⟩
  (vector.append v (vector.of_fn $ λ k, safe_rec k ⟨x :: w, by simpa using p⟩ v : vector 𝔹 i))
| j ⟨(tt :: x) :: w, p⟩ v := g₁ j ⟨x :: w, by simpa using p⟩
  (vector.append v (vector.of_fn $ λ k, safe_rec k ⟨x :: w, by simpa using p⟩ v : vector 𝔹 i))
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, x.2.1.head.length)⟩]}

-- f : (unsafeな引数) → (safeな引数) → 𝔹
inductive safe : Π {m n}, (vector 𝔹 m → vector 𝔹 n → 𝔹) → Prop
| const     : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 1), [])
| zero      : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 1), ff :: v.head)
| one       : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 1), tt :: v.head)
| tail      : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 1), v.head.tail)
| case      : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 3), safe_case v)
| nth (n m) : safe (λ (_ : vector 𝔹 0) (v : vector 𝔹 n), v.nth m)
| safe_comp :
  ∀ {m n} (f : vector 𝔹 m → vector 𝔹 n → 𝔹)
    {k} (g : fin m → vector 𝔹 k → vector 𝔹 0 → 𝔹)
    {l} (h : fin n → vector 𝔹 k → vector 𝔹 l → 𝔹),
    safe f → (∀ i, safe (g i)) → (∀ i, safe (h i)) →
    safe (λ (w : vector 𝔹 k) (v : vector 𝔹 l),
      f (vector.of_fn $ λ i, g i w vector.nil) (vector.of_fn $ λ i, h  i w v))
| safe_rec :
  ∀ {m n i}
  (f  : fin i → vector 𝔹 m → vector 𝔹 n → 𝔹)
  (g₀ : fin i → vector 𝔹 (m + 1) → vector 𝔹 (n + i) → 𝔹)
  (g₁ : fin i → vector 𝔹 (m + 1) → vector 𝔹 (n + i) → 𝔹) {j},
  (∀ j, safe (f j)) → (∀ j, safe (g₀ j)) → (∀ j, safe (g₁ j)) → safe (safe_rec f g₀ g₁ j)

theorem bcs_poly {m n} (f : vector 𝔹 m → vector 𝔹 n → 𝔹) (H : safe f) :
  ∃ p q r : ℕ, ∀ (w : vector 𝔹 m) (v : vector 𝔹 n),
  (f w v).length ≤ p * (∑ i, (w.nth i).length)^q + (⋁ i, (v.nth i).length) + r :=
begin
  induction H,
  case const { refine ⟨0, 0, 0, _⟩, intros w v, simp },
  case zero { refine ⟨0, 0, 1, _⟩, intros w v, simp[fintype_sup] },
  case one  { refine ⟨0, 0, 1, _⟩, intros w v, simp[fintype_sup] },
  case tail { refine ⟨0, 0, 0, _⟩, intros w v, simp[fintype_sup] },
  case case { refine ⟨0, 0, 0, _⟩, intros w v,
    rcases v with ⟨(_ | ⟨b, l⟩), p⟩,
    { simp at p, contradiction },
    rcases l with (_ | ⟨w, l⟩), { simp at p, contradiction },
    rcases l with (_ | ⟨v, l⟩), { simp at p, exfalso, linarith },
    rcases l with (_ | _),
    { rcases b with (_ | ⟨B, b⟩),
      { simp[safe_case], right, left, refl },
      { rcases B; simp[safe_case],
        { right, left, refl }, { right, right, left, refl } } },
    { exfalso, simp at p, linarith } },
  case nth : n m { refine ⟨0, 0, 0, _⟩, intros w v, simp, refine fintype.le_fintype_sup _ m },
  case safe_comp : m n f k g l h safe_f safe_g safe_h IH_f IH_g IH_h
  { simp, simp at IH_g IH_h,
    rcases IH_f with ⟨p_f, q_f, r_f, IH_f⟩, refine ⟨0, 0, 0, _⟩, intros w v,
    have := IH_f (vector.of_fn $ λ i, g i w vector.nil) (vector.of_fn $ λ i, h  i w v),
    simp at this,
     }
end


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import logic.small
import category_theory.skeletal

/-!
# Essentially small categories.

A category given by `(C : Type u) [category.{v} C]` is `w`-essentially small
if there exists a `small_model C : Type w` equipped with `[small_category (small_model C)]`.

A category is `w`-locally small if every hom type is `w`-small.

The main theorem here is that a category is `w`-essentially small iff
the type `skeleton C` is `w`-small, and `C` is `w`-locally small.
-/

universes w v v' u u'

open category_theory

variables (C : Type u) [category.{v} C]

namespace category_theory

/-- A category is `essentially_small.{w}` if there exists
an equivalence to some `S : Type w` with `[small_category S]`. -/
class essentially_small (C : Type u) [category.{v} C] : Prop :=
(equiv_small_category : ∃ (S : Type w) [small_category S], by exactI nonempty (C ≌ S))

/-- Constructor for `essentially_small C` from an explicit small category witness. -/

/--
An arbitrarily chosen small model for an essentially small category.
-/
@[nolint has_inhabited_instance]
def small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : Type w :=
classical.some (@essentially_small.equiv_small_category C _ _)

noncomputable
instance small_category_small_model
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : small_category (small_model C) :=
classical.some (classical.some_spec (@essentially_small.equiv_small_category C _ _))

/--
The (noncomputable) categorical equivalence between
an essentially small category and its small model.
-/
noncomputable
def equiv_small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : C ≌ small_model C :=
nonempty.some (classical.some_spec (classical.some_spec
  (@essentially_small.equiv_small_category C _ _)))

lemma essentially_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : essentially_small.{w} C ↔ essentially_small.{w} D :=
begin
  fsplit,
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.symm.trans f), },
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.trans f), },
end

/--
A category is `w`-locally small if every hom set is `w`-small.

See `shrink_homs C` for a category instance where every hom set has been replaced by a small model.
-/
class locally_small (C : Type u) [category.{v} C] : Prop :=
(hom_small : ∀ X Y : C, small.{w} (X ⟶ Y) . tactic.apply_instance)

instance (C : Type u) [category.{v} C] [locally_small.{w} C] (X Y : C) :
  small (X ⟶ Y) :=
locally_small.hom_small X Y

lemma locally_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : locally_small.{w} C ↔ locally_small.{w} D :=
begin
  fsplit,
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.inverse.obj X) (e.inverse.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.inverse, },
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.functor.obj X) (e.functor.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.functor, },
end

@[priority 100]
instance locally_small_self (C : Type u) [category.{v} C] : locally_small.{v} C := {}

@[priority 100]
instance locally_small_of_essentially_small
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : locally_small.{w} C :=
(locally_small_congr (equiv_small_model C)).mpr (category_theory.locally_small_self _)

/--
We define a type alias `shrink_homs C` for `C`. When we have `locally_small.{w} C`,
we'll put a `category.{w}` instance on `shrink_homs C`.
-/
@[nolint has_inhabited_instance]
def shrink_homs (C : Type u) := C

namespace shrink_homs

section
variables {C' : Type*} -- a fresh variable with no category instance attached

/-- Help the typechecker by explicitly translating from `C` to `shrink_homs C`. -/
def to_shrink_homs {C' : Type*} (X : C') : shrink_homs C' := X
/-- Help the typechecker by explicitly translating from `shrink_homs C` to `C`. -/
def from_shrink_homs {C' : Type*} (X : shrink_homs C') : C' := X

@[simp] lemma to_from (X : C') : from_shrink_homs (to_shrink_homs X) = X := rfl
@[simp] lemma from_to (X : shrink_homs C') : to_shrink_homs (from_shrink_homs X) = X := rfl

end

variables (C) [locally_small.{w} C]

@[simps]
noncomputable
instance : category.{w} (shrink_homs C) :=
{ hom := λ X Y, shrink (from_shrink_homs X ⟶ from_shrink_homs Y),
  id := λ X, equiv_shrink _ (𝟙 (from_shrink_homs X)),
  comp := λ X Y Z f g,
    equiv_shrink _ (((equiv_shrink _).symm f) ≫ ((equiv_shrink _).symm g)), }.

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def functor : C ⥤ shrink_homs C :=
{ obj := λ X, to_shrink_homs X,
  map := λ X Y f, equiv_shrink (X ⟶ Y) f, }

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def inverse : shrink_homs C ⥤ C :=
{ obj := λ X, from_shrink_homs X,
  map := λ X Y f, (equiv_shrink (from_shrink_homs X ⟶ from_shrink_homs Y)).symm f, }

/--
The categorical equivalence between `C` and `shrink_homs C`, when `C` is locally small.
-/
@[simps]
noncomputable
def equivalence : C ≌ shrink_homs C :=
equivalence.mk (functor C) (inverse C)
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))

end shrink_homs

/--
A category is essentially small if and only if
the underlying type of its skeleton (i.e. the "set" of isomorphism classes) is small,
and it is locally small.
-/
theorem essentially_small_iff (C : Type u) [category.{v} C] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) ∧ locally_small.{w} C :=
begin
  -- This theorem is the only bit of real work in this file.
  fsplit,
  { intro h,
    fsplit,
    { rcases h with ⟨S, 𝒮, ⟨e⟩⟩,
      resetI,
      refine ⟨⟨skeleton S, ⟨_⟩⟩⟩,
      exact e.skeleton_equiv, },
    { resetI, apply_instance, }, },
  { rintro ⟨⟨S, ⟨e⟩⟩, L⟩,
    resetI,
    let e' := (shrink_homs.equivalence C).skeleton_equiv.symm,
    refine ⟨⟨S, _, ⟨_⟩⟩⟩,
    apply induced_category.category (e'.trans e).symm,
    refine (shrink_homs.equivalence C).trans
      ((from_skeleton _).as_equivalence.symm.trans
      ((induced_functor (e'.trans e).symm).as_equivalence.symm)), },
end

/--
Any thin category is locally small.
-/
@[priority 100]
instance locally_small_of_thin {C : Type u} [category.{v} C] [∀ X Y : C, subsingleton (X ⟶ Y)] :
  locally_small.{w} C := {}

/--
A thin category is essentially small if and only if the underlying type of its skeleton is small.
-/
theorem essentially_small_iff_of_thin
  {C : Type u} [category.{v} C] [∀ X Y : C, subsingleton (X ⟶ Y)] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) :=
by simp [essentially_small_iff, category_theory.locally_small_of_thin]

end category_theory


import tactic

#check (=)

inductive mcrl2 (α : Type) : Type
| atom : α → mcrl2
| seq : mcrl2 → mcrl2 → mcrl2
| alt : mcrl2 → mcrl2 → mcrl2

instance (α) : has_add (mcrl2 α) := ⟨mcrl2.alt⟩
infix `⬝`:70 := mcrl2.seq

meta def mcrl2.repr : mcrl2 string → string
| (mcrl2.atom a) := a
| (x ⬝ y) := mcrl2.repr x ++ mcrl2.repr y
| (x + y) := "(" ++ mcrl2.repr x ++ " + " ++ mcrl2.repr y ++ ")"

inductive mcrl2_equiv {α : Type} : mcrl2 α → mcrl2 α → Prop
| atom {a} : mcrl2_equiv (mcrl2.atom a) (mcrl2.atom a)
| alt {x y x' y'} (h₁ : mcrl2_equiv x x') (h₂ : mcrl2_equiv y y') :
  mcrl2_equiv (x + y) (x' + y')
| seq {x y x' y'} (h₁ : mcrl2_equiv x x') (h₂ : mcrl2_equiv y y') :
  mcrl2_equiv (x ⬝ y) (x' ⬝ y')
| trans {x y z} (h₁ : mcrl2_equiv x y) (h₂ : mcrl2_equiv y z) :
  mcrl2_equiv x z
| comm {x y} (h : mcrl2_equiv x y) : mcrl2_equiv y x
| alt_comm {x y} : mcrl2_equiv (x + y) (y + x)
| alt_idem {x} : mcrl2_equiv (x + x) x
| alt_assoc {x y z} : mcrl2_equiv (x + (mcrl2.alt y z)) ((x + y) + z)
| seq_rdist {x y z} : mcrl2_equiv ((x + y) ⬝ z) (x ⬝ z + y ⬝ z)
| seq_assoc {x y z} : mcrl2_equiv ((x ⬝ y) ⬝ z) (x ⬝ (y ⬝ z))

theorem mcrl2_equiv.reflexive {α : Type} : reflexive (λa b : mcrl2 α, mcrl2_equiv a b) :=
begin
  intro x,
  induction x,
  { exact mcrl2_equiv.atom},
  { apply mcrl2_equiv.seq,
    repeat {assumption}},
  { apply mcrl2_equiv.alt,
    repeat {assumption}}
end

#check option.rel

theorem mcrl2_equiv.symmetric {α : Type} : symmetric (λa b : mcrl2 α, mcrl2_equiv a b) :=
begin
  intros x y,
  intro h,
  exact mcrl2_equiv.comm h
end

theorem mcrl2_equiv.transitive {α : Type} : transitive (λa b : mcrl2 α, mcrl2_equiv a b) :=
begin
  intros x y z h h',
  exact mcrl2_equiv.trans h h'
end

@[instance] def setoid_mcrl2 {α : Type} : setoid (mcrl2 α) :=
{ r := (λa b, mcrl2_equiv a b),
  iseqv :=
    begin
      repeat {apply and.intro},
      { exact mcrl2_equiv.reflexive},
      { exact mcrl2_equiv.symmetric},
      { exact mcrl2_equiv.transitive}
    end
}

lemma setoid_iff {α : Type} (a b : mcrl2 α) :
a ≈ b ↔ mcrl2_equiv a b :=
by refl

def mcrl2' (α : Type)  := quotient $ @setoid_mcrl2 α

lemma mcrl2'_alt_comm {α} (a b : mcrl2 α) : ⟦mcrl2.alt a b⟧ = ⟦mcrl2.alt b a⟧ :=
begin
apply quotient.sound,
apply mcrl2_equiv.alt_comm
end

lemma mcrl2'_alt_assoc {α} (a b c: mcrl2 α) : ⟦mcrl2.alt a (mcrl2.alt b c)⟧ = ⟦mcrl2.alt (mcrl2.alt a b) c⟧ :=
begin
apply quotient.sound,
apply mcrl2_equiv.alt_assoc
end

#check quot.lift_on₂_mk
class mcrl2_base (α M : Type) :=
  (atom : α → M)
  (alt : M → M → M)
  (seq : M → M → M)
  (alt_comm : ∀x y, alt x y = alt y x)
  (alt_assoc : ∀x y z, alt x (alt y z) = alt (alt x y) z)
  (alt_idem : ∀x, alt x x = x)
  (seq_dist : ∀x y z, seq (alt x y) z = alt (seq x z) (seq y z))
  (seq_assoc : ∀x y z, seq (seq x y) z = seq x (seq y z))

instance (α) : mcrl2_base α (mcrl2' α) := {
  atom := λa, ⟦mcrl2.atom a⟧,
  alt := quotient.lift₂ (λa b, ⟦a + b⟧)
         begin
          intros a b a' b' ha hb,
          apply quotient.sound,
          apply mcrl2_equiv.alt,
          { exact ha},
          { exact hb}
        end,
  seq := quotient.lift₂ (λa b, ⟦a ⬝ b⟧)
         begin
          intros a b a' b' ha hb,
          apply quotient.sound,
          apply mcrl2_equiv.seq,
          { exact ha},
          { exact hb}
        end,
  alt_comm := begin
    intros x y,
    apply quot.induction_on₂ x y,
    simp,
    apply mcrl2_equiv.alt_comm
  end,
  alt_assoc := begin
    intros x y z,
    apply quot.induction_on₃ x y z,
    intros a b c,
    apply quotient.sound,
    exact mcrl2_equiv.alt_assoc
  end,
  alt_idem := begin
    intro x,
    apply quot.induction_on x,
    intro a,
    apply quotient.sound,
    exact mcrl2_equiv.alt_idem
  end,
  seq_dist := begin
    intros x y z,
    apply quot.induction_on₃ x y z,
    intros a b c,
    apply quotient.sound,
    exact mcrl2_equiv.seq_rdist
  end,
  seq_assoc := begin
    intros x y z,
    apply quot.induction_on₃ x y z,
    intros a b c,
    apply quotient.sound,
    exact mcrl2_equiv.seq_assoc
  end
}

inductive testtype : Type
| a : testtype
| b : testtype

example : mcrl2' testtype := mcrl2_base.atom testtype.a

example : mcrl2 testtype :=
(mcrl2.atom testtype.a) ⬝ (mcrl2.atom testtype.b)

example : mcrl2_base unit unit :=
{ atom := λ_, (),
  alt := λ_ _, (),
  seq := λ_ _, (),
  alt_comm := by intros x y; refl,
  alt_assoc := by intros x y z; refl,
  alt_idem := begin intro x, cases x, refl end,
  seq_dist := by intros x y z; refl,
  seq_assoc := by intros x y z; refl}

inductive mcrl2_mrg (α : Type) : Type
| base : mcrl2 α → mcrl2_mrg
| atom : α → mcrl2_mrg
| seq : mcrl2_mrg → mcrl2_mrg → mcrl2_mrg
| alt : mcrl2_mrg → mcrl2_mrg → mcrl2_mrg
| par_left : mcrl2_mrg → mcrl2_mrg → mcrl2_mrg
| comm : mcrl2_mrg → mcrl2_mrg → mcrl2_mrg
| par : mcrl2_mrg → mcrl2_mrg → mcrl2_mrg
| deadlock : mcrl2_mrg

inductive mcrl2_mrg_equiv {α : Type} (γ : α → α → option α) :
mcrl2_mrg α → mcrl2_mrg α → Prop
| base : mcrl2_mrg_equiv
| par_main {x y} : mcrl2_mrg_equiv (mcrl2_mrg.par x y)
  ((mcrl2_mrg.par_left x y + mcrl2_mrg.par_left y x) + mcrl2_mrg.comm x y)
| par_left_atom {x a} : mcrl2_mrg_equiv (mcrl2_mrg.par_left (mcrl2_mrg.atom a) x)
  (mcrl2_mrg.seq (mcrl2_mrg.atom a) x)
| par_left_seq {x y a} : mcrl2_mrg_equiv
  (mcrl2_mrg.par_left (mcrl2_mrg.seq (mcrl2_mrg.atom a) y) x)
  (mcrl2_mrg.seq (mcrl2_mrg.atom a) (mcrl2_mrg.par x y))
| par_left_assoc {x y z} : mcrl2_mrg_equiv
  (mcrl2_mrg.par_left (mcrl2_mrg.alt x y ) z)
  (mcrl2_mrg.alt (mcrl2_mrg.par_left x z) (mcrl2_mrg.par_left y z))
| comm_succ {a b c} (h : γ a b = some c) : mcrl2_mrg_equiv
  (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.atom b))
  (mcrl2_mrg.atom c)
| comm_fail {a b} (h : γ a b = none) : mcrl2_mrg_equiv
  (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.atom b))
  (mcrl2_mrg.deadlock)
| comm_seql {a b x} : mcrl2_mrg_equiv
  (mcrl2_mrg.comm (mcrl2_mrg.seq (mcrl2_mrg.atom a) x) (mcrl2_mrg.atom b))
  (mcrl2_mrg.seq (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.atom b)) x)
| comm_seqr {a b x} : mcrl2_mrg_equiv
  (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.seq (mcrl2_mrg.atom b) x) )
  (mcrl2_mrg.seq (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.atom b)) x)
| comm_seq_two {a b x y} : mcrl2_mrg_equiv
  (mcrl2_mrg.comm
    (mcrl2_mrg.seq (mcrl2_mrg.atom a) x)
    (mcrl2_mrg.seq (mcrl2_mrg.atom b) y))
  (mcrl2_mrg.seq
    (mcrl2_mrg.comm (mcrl2_mrg.atom a) (mcrl2_mrg.atom b))
    (mcrl2_mrg.par x y))
| comm_distl {x y z} : mcrl2_mrg_equiv
  (mcrl2_mrg.comm (x + y) z)
  ((mcrl2_mrg.comm x z) + (mcrl2_mrg.comm y z))
| comm_distr {x y z} : mcrl2_mrg_equiv
  (mcrl2_mrg.comm x (y + z))
  ((mcrl2_mrg.comm x y) + (mcrl2_mrg.comm x z))


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

notation, basic datatypes and type classes
-/
prelude
import Init.Core

@[simp] theorem eqSelf (a : α) : (a = a) = True :=
  propext <| Iff.intro (fun _ => trivial) (fun _ => rfl)

theorem ofEqTrue (h : p = True) : p :=
  h ▸ trivial

theorem eqTrue (h : p) : p = True :=
  propext <| Iff.intro (fun _ => trivial) (fun _ => h)

theorem eqFalse (h : ¬ p) : p = False :=
  propext <| Iff.intro (fun h' => absurd h' h) (fun h' => False.elim h')

theorem eqFalse' (h : p → False) : p = False :=
  propext <| Iff.intro (fun h' => absurd h' h) (fun h' => False.elim h')

theorem eqTrueOfDecide {p : Prop} {s : Decidable p} (h : decide p = true) : p = True :=
  propext <| Iff.intro (fun h => trivial) (fun _ => ofDecideEqTrue h)

theorem eqFalseOfDecide {p : Prop} {s : Decidable p} (h : decide p = false) : p = False :=
  propext <| Iff.intro (fun h' => absurd h' (ofDecideEqFalse h)) (fun h => False.elim h)

theorem impCongr {p₁ p₂ : Sort u} {q₁ q₂ : Sort v} (h₁ : p₁ = p₂) (h₂ : q₁ = q₂) : (p₁ → q₁) = (p₂ → q₂) :=
  h₁ ▸ h₂ ▸ rfl

theorem impCongrCtx {p₁ p₂ q₁ q₂ : Prop} (h₁ : p₁ = p₂) (h₂ : p₂ → q₁ = q₂) : (p₁ → q₁) = (p₂ → q₂) :=
  propext <| Iff.intro
    (fun h hp₂ =>
      have : p₁ := h₁ ▸ hp₂
      have : q₁ := h this
      h₂ hp₂ ▸ this)
    (fun h hp₁ =>
      have hp₂ : p₂ := h₁ ▸ hp₁
      have : q₂ := h hp₂
      h₂ hp₂ ▸ this)

theorem forallCongr {α : Sort u} {p q : α → Prop} (h : ∀ a, (p a = q a)) : (∀ a, p a) = (∀ a, q a) :=
  have : p = q := funext h
  this ▸ rfl

@[congr]
theorem iteCongr {x y u v : α} {s : Decidable b} [Decidable c] (h₁ : b = c) (h₂ : c → x = u) (h₃ : ¬ c → y = v) : ite b x y = ite c u v := by
  cases Decidable.em c with
  | inl h => rw [ifPos h]; subst b; rw[ifPos h]; exact h₂ h
  | inr h => rw [ifNeg h]; subst b; rw[ifNeg h]; exact h₃ h

theorem Eq.mprProp {p q : Prop} (h₁ : p = q) (h₂ : q) : p :=
  h₁ ▸ h₂

theorem Eq.mprNot {p q : Prop} (h₁ : p = q) (h₂ : ¬q) : ¬p :=
  h₁ ▸ h₂

@[congr]
theorem diteCongr {s : Decidable b} [Decidable c]
        {x : b → α} {u : c → α} {y : ¬b → α} {v : ¬c → α}
        (h₁ : b = c)
        (h₂ : (h : c)  → x (Eq.mprProp h₁ h) = u h)
        (h₃ : (h : ¬c) → y (Eq.mprNot h₁ h)  = v h)
        : dite b x y = dite c u v := by
  cases Decidable.em c with
  | inl h => rw [difPos h]; subst b; rw [difPos h]; exact h₂ h
  | inr h => rw [difNeg h]; subst b; rw [difNeg h]; exact h₃ h

namespace Lean.Simp

@[simp] theorem Ne_Eq (a b : α) : (a ≠ b) = Not (a = b) := rfl
@[simp] theorem ite_True (a b : α) : (if True then a else b) = a := rfl
@[simp] theorem ite_False (a b : α) : (if False then a else b) = b := rfl
@[simp] theorem dite_True {α : Sort u} {t : True → α} {e : ¬ True → α} : (dite True t e) = t True.intro := rfl
@[simp] theorem dite_False {α : Sort u} {t : False → α} {e : ¬ False → α} : (dite False t e) = e notFalse := rfl
@[simp] theorem And_self (p : Prop) : (p ∧ p) = p := propext <| Iff.intro (fun h => h.1) (fun h => ⟨h, h⟩)
@[simp] theorem And_True (p : Prop) : (p ∧ True) = p := propext <| Iff.intro (fun h => h.1) (fun h => ⟨h, trivial⟩)
@[simp] theorem True_And (p : Prop) : (True ∧ p) = p := propext <| Iff.intro (fun h => h.2) (fun h => ⟨trivial, h⟩)
@[simp] theorem And_False (p : Prop) : (p ∧ False) = False := propext <| Iff.intro (fun h => h.2) (fun h => False.elim h)
@[simp] theorem False_And (p : Prop) : (False ∧ p) = False := propext <| Iff.intro (fun h => h.1) (fun h => False.elim h)
@[simp] theorem Or_self (p : Prop) : (p ∨ p) = p := propext <| Iff.intro (fun | Or.inl h => h | Or.inr h => h) (fun h => Or.inl h)
@[simp] theorem Or_True (p : Prop) : (p ∨ True) = True := propext <| Iff.intro (fun h => trivial) (fun h => Or.inr trivial)
@[simp] theorem True_Or (p : Prop) : (True ∨ p) = True := propext <| Iff.intro (fun h => trivial) (fun h => Or.inl trivial)
@[simp] theorem Or_False (p : Prop) : (p ∨ False) = p := propext <| Iff.intro (fun | Or.inl h => h | Or.inr h => False.elim h) (fun h => Or.inl h)
@[simp] theorem False_Or (p : Prop) : (False ∨ p) = p := propext <| Iff.intro (fun | Or.inr h => h | Or.inl h => False.elim h) (fun h => Or.inr h)
@[simp] theorem Iff_self (p : Prop) : (p ↔ p) = True := propext <| Iff.intro (fun h => trivial) (fun _ => Iff.intro id id)
@[simp] theorem Iff_True (p : Prop) : (p ↔ True) = p := propext <| Iff.intro (fun h => h.mpr trivial) (fun h => Iff.intro (fun _ => trivial) (fun _ => h))
@[simp] theorem True_Iff (p : Prop) : (True ↔ p) = p := propext <| Iff.intro (fun h => h.mp trivial) (fun h => Iff.intro (fun _ => h) (fun _ => trivial))
@[simp] theorem Iff_False (p : Prop) : (p ↔ False) = ¬p := propext <| Iff.intro (fun h hp => h.mp hp) (fun h => Iff.intro h False.elim)
@[simp] theorem False_Iff (p : Prop) : (False ↔ p) = ¬p := propext <| Iff.intro (fun h hp => h.mpr hp) (fun h => Iff.intro False.elim h)
@[simp] theorem False_arrow (p : Prop) : (False → p) = True := propext <| Iff.intro (fun _ => trivial) (by intros; trivial)
@[simp] theorem arrow_True (p : Prop) : (p → True) = True := propext <| Iff.intro (fun _ => trivial) (by intros; trivial)
@[simp] theorem True_arrow (p : Prop) : (True → p) = p := propext <| Iff.intro (fun h => h trivial) (by intros; trivial)

@[simp] theorem or_false (b : Bool) : (b || false) = b  := by cases b <;> rfl
@[simp] theorem or_true (b : Bool) : (b || true) = true := by cases b <;> rfl
@[simp] theorem false_or (b : Bool) : (false || b) = b  := by cases b <;> rfl
@[simp] theorem true_or (b : Bool) : (true || b) = true := by cases b <;> rfl
@[simp] theorem or_self (b : Bool) : (b || b) = b       := by cases b <;> rfl

@[simp] theorem and_false (b : Bool) : (b && false) = false := by cases b <;> rfl
@[simp] theorem and_true (b : Bool) : (b && true) = b       := by cases b <;> rfl
@[simp] theorem false_and (b : Bool) : (false && b) = false := by cases b <;> rfl
@[simp] theorem true_and (b : Bool) : (true && b) = b       := by cases b <;> rfl
@[simp] theorem and_self (b : Bool) : (b && b) = b          := by cases b <;> rfl

end Lean.Simp


import operations
import types

import category_theory.category.basic
import category_theory.core

open operations
open params
open types

open category_theory

namespace quarterround

variables [category (bitvec word_len)]

/-!
  # Quarterround

  The `quarterround` function, its pieces and the relation with the inverses.
-/

/-! ## Definitions -/

/-- z₁ = y₁ ⊕ ((y₀ + y₃) <<< 7) -/
def qr1 (a b c d : bitvec word_len) := b OP (OP_RHS a d 7)
/-- z₂ = y₂ ⊕ ((z₁ + y₀) <<< 9) -/
def qr2 (a b c d : bitvec word_len) := c OP (OP_RHS (qr1 a b c d) a 9)
/-- z₃ = y₃ ⊕ ((z₂ + z₁) <<< 13) -/
def qr3 (a b c d : bitvec word_len) := d OP (OP_RHS (qr2 a b c d) (qr1 a b c d) 13)
/-- z₀ = y₀ ⊕ ((z₃ + z₂) <<< 18) -/
def qr0 (a b c d : bitvec word_len) := a OP (OP_RHS (qr3 a b c d) (qr2 a b c d) 18)

/-- Given a sequence of 4 numbers `seq`, use the four equations (`qr0`, `qr1`, `qr2` and `qr3`) to get the
full quarterround output, which is a transformed 4 numbers sequence too. -/
@[simp] def quarterround (seq : vecType) : vecType :=
  (
    qr0 seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
    qr1 seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
    qr2 seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
    qr3 seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd
  )

/-! ## Quarterround zero lemmas -/

/-- `qr0` of 4 zeros is zero -/
@[simp] lemma qr0_zero : qr0 0 0 0 0 = 0 := by refl

/-- `qr1` of 4 zeros is zero -/
@[simp] lemma qr1_zero : qr1 0 0 0 0 = 0 := by refl

/-- `qr2` of 4 zeros is zero -/
@[simp] lemma qr2_zero : qr2 0 0 0 0 = 0 := by refl

/-- `qr3` of 4 zeros is zero -/
@[simp] lemma qr3_zero : qr3 0 0 0 0 = 0 := by refl

/-- `quarterround` of 4 zeros is a sequence of 4 zeros -/
@[simp] lemma quarterround_zero : quarterround (0, 0, 0, 0) = (0, 0, 0, 0) := by refl

/-! ## Inverse definitions -/

/-- y₀ = z₀ ⊕ ((z₃ + z₂) <<< 18) -/
def qr0_inv (a' b' c' d' : bitvec word_len) := a' OP (operation_rhs d' c' 18)
/-- y₃ = z₃ ⊕ ((z₂ + z₁) <<< 13) -/
def qr3_inv (a' b' c' d' : bitvec word_len) := d' OP (operation_rhs c' b' 13)
/-- y₂ = z₂ ⊕ ((z₁ + y₀) <<< 9) -/
def qr2_inv (a' b' c' d' : bitvec word_len) := c' OP (operation_rhs b' (qr0_inv a' b' c' d')  9)
/-- y₁ = z₁ ⊕ ((y₀ + y₃) <<< 7) -/
def qr1_inv (a' b' c' d' : bitvec word_len) := b' OP (operation_rhs (qr0_inv a' b' c' d') (qr3_inv a' b' c' d') 7)

/-- Put the 4 elements that forms a quarterround inverse all together. -/
@[simp] def quarterround_inv (seq : vecType) := (
  qr0_inv seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
  qr1_inv seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
  qr2_inv seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd,
  qr3_inv seq.fst seq.snd.fst seq.snd.snd.fst seq.snd.snd.snd
)

local notation `qr0⁻¹` := qr0_inv
local notation `qr1⁻¹` := qr1_inv
local notation `qr2⁻¹` := qr2_inv
local notation `qr3⁻¹` := qr3_inv
local notation `quarterround⁻¹` := quarterround_inv

/-! ## Inverse lemmas -/

/-- The `quarterround` operation is fully invertible. -/
lemma quarterround_is_inv (I : quarterround ≅ quarterround⁻¹) : I.hom ≫ I.inv = 𝟙 quarterround :=
  by rw [iso.hom_inv_id]

/-! ## Inverses of the `quarterround` and `quarterround_inv` individual pieces lemmas -/

/-- `qr0⁻¹` after `qr0` is `𝟙 qr0`. -/
lemma qr0_is_inv (I : qr0 ≅ qr0⁻¹) : I.hom ≫ I.inv = 𝟙 qr0 := by rw [iso.hom_inv_id]

/-- `qr1⁻¹` after `qr1` is `𝟙 qr1`. -/
lemma qr1_is_inv (I : qr1 ≅ qr1⁻¹) : I.hom ≫ I.inv = 𝟙 qr1 := by rw [iso.hom_inv_id]

/-- `qr2⁻¹` after `qr2` is `𝟙 qr2`. -/
lemma qr2_is_inv (I : qr2 ≅ qr2⁻¹) : I.hom ≫ I.inv = 𝟙 qr2 := by rw [iso.hom_inv_id]

/-- `qr3⁻¹` after `qr3` is `𝟙 qr3`. -/
lemma qr3_is_inv (I : qr3 ≅ qr3⁻¹) : I.hom ≫ I.inv = 𝟙 qr3 := by rw [iso.hom_inv_id]

/-- `qr0` after `qr0⁻¹` is `𝟙 qr0⁻¹`. -/
lemma qr0_inv_is_inv (I : qr0 ≅ qr0⁻¹) : I.inv ≫ I.hom = 𝟙 qr0⁻¹ := by rw [iso.inv_hom_id]

/-- `qr1` after `qr1⁻¹` is `𝟙 qr1⁻¹`. -/
lemma qr1_inv_is_inv (I : qr1 ≅ qr1⁻¹) : I.inv ≫ I.hom = 𝟙 qr1⁻¹ := by rw [iso.inv_hom_id]

/-- `qr2` after `qr2⁻¹` is `𝟙 qr2⁻¹`. -/
lemma qr2_inv_is_inv (I : qr2 ≅ qr2⁻¹) : I.inv ≫ I.hom = 𝟙 qr2⁻¹ := by rw [iso.inv_hom_id]

/-- `qr3` after `qr3⁻¹` is `𝟙 qr3⁻¹`. -/
lemma qr3_inv_is_inv (I : qr3 ≅ qr3⁻¹) : I.inv ≫ I.hom = 𝟙 qr3⁻¹ := by rw [iso.inv_hom_id]

/-- The inidivudal pieces of the `quarterround` function are all invertible. -/
lemma qr_pieces_are_all_invertible (I0 : qr0 ≅ qr0⁻¹) (I1 : qr1 ≅ qr1⁻¹) (I2 : qr2 ≅ qr2⁻¹) (I3 : qr3 ≅ qr3⁻¹) :
  I0.hom ≫ I0.inv = 𝟙 qr0 ∧ I1.hom ≫ I1.inv = 𝟙 qr1 ∧ I2.hom ≫ I2.inv = 𝟙 qr2 ∧ I3.hom ≫ I3.inv = 𝟙 qr3 :=
begin
  simp only [iso.hom_inv_id, eq_self_iff_true, and_self],
end

end quarterround


import data.fintype.basic
import data.int.interval
import topology.bases
import topology.compact_open
import .circuit
import .list_pi

open set topological_space

@[protect_proj] structure profinite : Type 1 :=
( ι : Type )
[ dec_eq : decidable_eq ι ]
( X : Type )
[ top_inst : topological_space X ]
( proj : ι → X → bool)
( continuous_swap_proj : continuous (function.swap proj) )
( inv : (ι → bool) → X )
( continuous_inv : continuous inv )
( is_inv : ∀ x y, function.swap proj x = y ↔ x = inv y )

attribute [instance] profinite.top_inst profinite.dec_eq

namespace profinite

variables {X : profinite} {i : X.ι}

instance : has_coe_to_sort profinite Type := ⟨profinite.X⟩

@[simp] lemma proj_inv (x : X.ι → bool) : X.proj i (X.inv x) = x i :=
begin
  have := X.is_inv (X.inv x) x,
  simp [function.swap, function.funext_iff, *] at *
end

@[simp] lemma inv_proj (x : X) : X.inv (λ i, X.proj i x) = x :=
begin
  have := (X.is_inv x (λ i, X.proj i x)).symm,
  simp [function.swap, function.funext_iff, eq_comm, *] at *
end

lemma closed_embedding (X : profinite) : closed_embedding (function.swap X.proj) :=
closed_embedding_of_continuous_injective_closed
  X.continuous_swap_proj
  (λ x y hxy, begin
    rw [X.is_inv] at hxy,
    rw [hxy, eq_comm, ← X.is_inv]
  end)
  begin
    intros s hs,
    have : is_closed (X.inv ⁻¹' s) := continuous_iff_is_closed.1 X.continuous_inv _ hs,
    convert this,
    simp [set.ext_iff],
    intro x,
    split,
    { rintro ⟨y, hy, rfl⟩,
      convert hy,
      rw [eq_comm, ← X.is_inv] },
    { intro hx,
      use X.inv x,
      use hx,
      rw [X.is_inv] }
  end

attribute [continuity] profinite.continuous_inv

instance : compact_space X := X.closed_embedding.compact_space
instance : t2_space X := X.closed_embedding.t2_space
instance : totally_disconnected_space X :=
⟨is_totally_disconnected_of_image
  X.closed_embedding.continuous.continuous_on
  X.closed_embedding.inj $
  is_totally_disconnected_of_totally_disconnected_space _⟩

@[continuity] lemma continuous_proj (i : X.ι) : continuous (X.proj i) :=
show continuous ((λ x : Π i : X.ι, bool, x i) ∘ (λ (x : X) (j : X.ι), X.proj j x)),
from (continuous_apply i).comp X.closed_embedding.continuous

lemma continuous_iff_proj {Y : Type*} [topological_space Y] (f : Y → X) :
  continuous f ↔ ∀ i, continuous (λ y, X.proj i (f y)) :=
by simp only [X.closed_embedding.continuous_iff, continuous_pi_iff]

lemma is_open_iff_pi (U : set X) : is_open U ↔ ∃ (V : set (X.ι → bool)),
  is_open V ∧ (function.swap X.proj ⁻¹' V) = U :=
X.closed_embedding.is_open_iff

lemma is_closed_iff_pi (F : set X) : is_closed F ↔ ∃ (V : set (X.ι → bool)),
  is_closed V ∧ (function.swap X.proj ⁻¹' V) = F :=
X.closed_embedding.is_closed_iff

def prod (X Y : profinite) : profinite :=
{ ι := X.ι ⊕ Y.ι,
  X := X × Y,
  proj := sum.elim (λ i xy, X.proj i xy.1) (λ i xy, Y.proj i xy.2),
  continuous_swap_proj := begin
      dsimp [function.swap],
      continuity,
      cases i,
      { dsimp,
        continuity },
      { dsimp,
        continuity }
    end,
  inv := λ x, (X.inv (x ∘ sum.inl), Y.inv (x ∘ sum.inr)),
  continuous_inv := begin
      continuity,

     end,
  is_inv := begin
    rintros ⟨x, y⟩ z,
    simp [← X.is_inv, ← Y.is_inv, function.swap, prod.ext_iff, function.funext_iff]
  end }

instance {X Y : profinite} [fintype X.ι] [fintype Y.ι] : fintype (X.prod Y).ι :=
by dsimp [profinite.prod]; apply_instance

instance {X Y : profinite} [fintype X.X] [fintype Y.X] : fintype (X.prod Y).X :=
by dsimp [profinite.prod]; apply_instance

instance {X Y : profinite} [has_repr X.ι] [has_repr Y.ι] : has_repr (X.prod Y).ι :=
by dsimp [profinite.prod]; apply_instance

instance {X Y : profinite} [has_repr X.X] [has_repr Y.X] : has_repr (X.prod Y).X :=
by dsimp [profinite.prod]; apply_instance

def boolp : profinite :=
{ ι := unit,
  X := bool,
  proj := λ _, id,
  continuous_swap_proj := by continuity,
  inv := λ i, i (),
  continuous_inv := by continuity,
  is_inv := dec_trivial}

instance Safsasg: fintype (boolp.ι) := by dsimp [boolp]; apply_instance
instance aagsga : fintype (boolp.X) := by dsimp [boolp]; apply_instance

instance agdgs : has_repr (boolp.ι) := by dsimp [boolp]; apply_instance
instance agdgsa : has_repr (boolp.X) := by dsimp [boolp]; apply_instance

def twoadic : profinite :=
{ ι := ℕ,
  X := ℕ → bool,
  proj := function.swap id,
  continuous_swap_proj := continuous_id,
  continuous_inv := by continuity,
  inv := id,
  is_inv := by simp [function.swap] }

instance sgda : has_repr twoadic.ι := by dsimp [twoadic]; apply_instance

open circuit

def circuit.to_set (c : circuit X.ι) : set X :=
{ x | c.eval (λ i, X.proj i x) }

instance (c : circuit X.ι) : decidable_pred (circuit.to_set c) :=
by dsimp [circuit.to_set]; apply_instance

structure map (X Y : profinite) : Type :=
( to_fun : X → Y )
( preimage : circuit Y.ι → circuit X.ι )
( continuous' : ∀ (x : X) (C : circuit Y.ι),
  to_fun x ∈ C.to_set ↔ x ∈ (preimage C).to_set )

instance (X Y : profinite) : has_coe_to_fun (map X Y) (λ _, X → Y) :=
⟨map.to_fun⟩

theorem map.continuous {Y : profinite}: ∀ (f : map X Y) (x : X) (C : circuit Y.ι),
  f x ∈ C.to_set ↔ x ∈ (f.preimage C).to_set :=
map.continuous'

@[simp] theorem eval_preimage {Y : profinite} (f : map X Y) (x : X.ι → bool) (C : circuit Y.ι) :
  (f.preimage C).eval x = C.eval (λ i, Y.proj i (f (X.inv x))) :=
begin
  rw [← bool.coe_bool_iff],
  refine ((f.continuous (X.inv x) C).trans _).symm,
  simp [circuit.to_set],
end

def map.id (X : profinite) : map X X :=
{ to_fun := id,
  preimage := λ C, C,
  continuous' := λ x C, by simp }

def map.comp {X Y Z : profinite} (f : map X Y) (g : map Y Z) : map X Z :=
{ to_fun := g ∘ f,
  preimage := λ C, f.preimage (g.preimage C),
  continuous' := λ x C, by simp [f.continuous, g.continuous] }

def projm (X : profinite) (i : X.ι) : map X boolp :=
{ to_fun := X.proj i,
  preimage := λ C, C.map (λ _, i),
  continuous' := λ x C, by simp [circuit.to_set, eval_map]; refl }

def fstm {X Y : profinite} : (X.prod Y).map X :=
{ to_fun := prod.fst,
  preimage := λ C, C.map sum.inl,
  continuous' := λ x C, begin
    delta profinite.prod circuit.to_set,
    simp [eval_map],
  end }

def sndm {X Y : profinite} : (X.prod Y).map Y :=
{ to_fun := prod.snd,
  preimage := λ C, C.map sum.inr,
  continuous' := λ x C, begin
    delta profinite.prod circuit.to_set,
    simp [eval_map],
  end }

def reindex {X Y : profinite} (e : Y.ι → X.ι) : map X Y :=
{ to_fun := λ x, Y.inv (λ i, X.proj (e i) x),
  preimage := λ C, C.map e,
  continuous' := λ x C, by simp [eval_map, circuit.to_set] }

def prod_mk_reindex {X Y Z : profinite} (e₁ : Y.ι → X.ι)
  (e₂ : Z.ι → X.ι) : map X (Y.prod Z) :=
{ to_fun := λ x, (Y.inv (λ i, X.proj (e₁ i) x), Z.inv (λ i, X.proj (e₂ i) x)),
  preimage := λ C, C.map (sum.elim e₁ e₂),
  continuous' := λ x C, begin
    delta profinite.prod circuit.to_set,
    simp [eval_map, circuit.to_set],
    rw [iff_iff_eq],
    congr' 2,
    ext i,
    cases i with i i;
    simp,
  end }

def diag {X : profinite} : X.map (X.prod X) :=
prod_mk_reindex id id

def fst {Y : profinite} (C : circuit (X.prod Y).ι) : circuit X.ι :=
circuit.bOr (C.sum_vars_right.pi (λ _, [tt, ff]))
  (λ x, circuit.assign_vars C
    (λ i, sum.rec (λ i _, sum.inl i) (λ i hi, sum.inr (x i (by simp [hi]))) i))

lemma eval_fst {Y : profinite} (C : circuit (X.prod Y).ι) (x : X.ι → bool) :
  (fst C).eval x ↔ ∃ y, C.eval (sum.elim x y) :=
begin
  dsimp [fst],
  simp only [eval_assign_vars, list.mem_pi, or_iff_not_imp_left, eval_bOr,
    list.mem_cons_iff, list.mem_singleton,
    eq_ff_eq_not_eq_tt, imp_self, implies_true_iff, exists_true_left],
  dsimp [set_of, set.mem_def, profinite.prod],
  split,
  { rintro ⟨a, ha⟩,
    use [λ i, if hi : i ∈ C.sum_vars_right then a i hi else tt],
    rw [eval_eq_evalv],
    convert ha,
    ext i hi,
    cases i with i i; simp * },
  { rintro ⟨a, ha⟩,
    use [λ i _, a i],
    rw [eval_eq_evalv] at ha,
    convert ha,
    ext i hi,
    cases i with i i; simp * }
end

lemma mem_fst {Y : profinite} (C : circuit (X.prod Y).ι) (x : X) :
  x ∈ (fst C).to_set ↔ ∃ y, (x, y) ∈ C.to_set :=
begin
  dsimp [circuit.to_set],
  simp only [eval_fst],
  dsimp [set_of, set.mem_def, profinite.prod],
  split,
  { rintros ⟨a, ha⟩,
    refine ⟨Y.inv a, _⟩,
    convert ha,
    ext i hi,
    cases i with i i; simp * },
  { rintro ⟨y, hy⟩,
    use λ i, Y.proj i y,
    convert hy,
    ext i hi,
    cases i with i i; simp * }
end

def snd {Y : profinite} (C : circuit (X.prod Y).ι) : circuit Y.ι :=
circuit.bOr (C.sum_vars_left.pi (λ _, [tt, ff]))
  (λ x, circuit.assign_vars C
    (λ i, sum.rec (λ i hi, sum.inr (x i (by simp [hi]))) (λ i _, sum.inl i) i))

lemma eval_snd {Y : profinite} (C : circuit (X.prod Y).ι) (y : Y.ι → bool) :
  (snd C).eval y ↔ ∃ x, C.eval (sum.elim x y) :=
begin
  dsimp [snd],
  simp only [eval_assign_vars, list.mem_pi, or_iff_not_imp_left, eval_bOr,
    list.mem_cons_iff, list.mem_singleton,
    eq_ff_eq_not_eq_tt, imp_self, implies_true_iff, exists_true_left],
  dsimp [set_of, set.mem_def, profinite.prod],
  split,
  { rintro ⟨a, ha⟩,
    use [λ i, if hi : i ∈ C.sum_vars_left then a i hi else tt],
    rw [eval_eq_evalv],
    convert ha,
    ext i hi,
    cases i with i i; simp * },
  { rintro ⟨a, ha⟩,
    use [λ i _, a i],
    rw [eval_eq_evalv] at ha,
    convert ha,
    ext i hi,
    cases i with i i; simp * }
end

lemma mem_snd {Y : profinite} (C : circuit (X.prod Y).ι) (y : Y) :
  y ∈ (snd C).to_set ↔ ∃ x, (x, y) ∈ C.to_set :=
begin
  dsimp [circuit.to_set],
  simp only [eval_snd],
  dsimp [set_of, set.mem_def, profinite.prod],
  split,
  { rintros ⟨a, ha⟩,
    refine ⟨X.inv a, _⟩,
    convert ha,
    ext i hi,
    cases i with i i; simp * },
  { rintro ⟨x, hx⟩,
    use λ i, X.proj i x,
    convert hx,
    ext i hi,
    cases i with i i; simp * }
end

def prod_mk {X Y Z : profinite} (f : X.map Y) (g : X.map Z) : X.map (Y.prod Z) :=
{ to_fun := λ x, (f x, g x),
  preimage := λ C, C.bind (sum.elim (λ i, f.preimage (var i)) (λ i, g.preimage (var i))),
  continuous' := begin
    intros x C,
    simp [circuit.to_set, circuit.eval_bind],
    rw [iff_iff_eq],
    congr' 2,
    funext i,
    cases i with i i,
    { dsimp [profinite.prod],
      rw [eval_preimage f],
      simp },
    { dsimp [profinite.prod],
      rw [eval_preimage g],
      simp }
  end }

def prod_mapm {W X Y Z : profinite} (f : W.map Y) (g : X.map Z) : (W.prod X).map (Y.prod Z) :=
prod_mk (fstm.comp f) (sndm.comp g)

def unitp : profinite :=
{ ι := empty,
  X := unit,
  proj := empty.elim,
  continuous_swap_proj := by continuity,
  continuous_inv := by continuity,
  inv := λ _, (),
  is_inv := dec_trivial }

instance : has_repr empty := ⟨empty.elim⟩
instance unitp.finι : fintype unitp.ι := by dsimp [unitp]; apply_instance
instance unitp.finX : fintype unitp.X := by dsimp [unitp]; apply_instance
instance afas : has_repr unitp.ι := by dsimp [unitp]; apply_instance
instance ads : has_repr unitp.X := by dsimp [unitp]; apply_instance

end profinite

open profinite

structure propagate_struc (input : profinite) (state : profinite) : Type 1 :=
( init : state )
( transition : (state.prod input).map state )
( output : (state.prod input).map boolp )

variables {input state : profinite}
  (p : propagate_struc input state)
  {p₁ p₂ : propagate_struc input state}

namespace propagate_struc

@[simp] def nth_state (x : ℕ → input) : ℕ → state
| 0     := p.init
| (n+1) := p.transition (nth_state n, x n)

@[simp] def nth_output (x : ℕ → input) (n : ℕ) : bool :=
p.output (nth_state p x n, x n)

lemma nth_state_eq_of_nth_state_eq
  {m n : ℕ}
  {x₁ x₂ : ℕ → input} : ∀ (i : ℕ)
  (hs : p₁.nth_state x₁ m = p₂.nth_state x₂ n)
  (hc : ∀ s, p₁.transition s = p₂.transition s)
  (hx : ∀ (j), j ≤ i → x₁ (m + j) = x₂ (n + j)),
  p₁.nth_state x₁ (m + i) = p₂.nth_state x₂ (n + i)
| 0 hs ht hx := hs
| (i+1) hs hc hx := begin
  rw [← add_assoc, ← add_assoc, nth_state, nth_state,
    nth_state_eq_of_nth_state_eq i hs hc (λ j hj, hx j (nat.le_succ_of_le hj)), hc,
    hx _ (nat.le_succ _)],
end

lemma nth_output_eq_of_nth_state_eq
  {m n : ℕ}
  {x₁ x₂ : ℕ → input} (i : ℕ)
  (hs : p₁.nth_state x₁ m = p₂.nth_state x₂ n)
  (hc : ∀ s, p₁.transition s = p₂.transition s)
  (ho : ∀ s, p₁.output s = p₂.output s)
  (hx : ∀ (j), j ≤ i → x₁ (m + j) = x₂ (n + j)) :
  p₁.nth_output x₁ (m + i) = p₂.nth_output x₂ (n + i) :=
begin
  have := nth_state_eq_of_nth_state_eq i (by simpa using hs) hc hx,
  rw [nth_output, nth_output, ho, this, hx _ (le_refl _)]
end

inductive result : Type
| false_after (n : ℕ) : result
| true_for_n (n : ℕ) : result
| true_forall : result

instance : has_repr result :=
⟨λ r, match r with
| result.false_after n := "false after " ++ repr n
| result.true_for_n n := "true for " ++ repr n
| result.true_forall := "true forall"
end⟩

def decide_if_zeros_aux [has_repr state.ι] : Π (n : ℕ), result × circuit state.ι
| 0 := (result.true_for_n 0, fst
  (p.output.preimage (circuit.single (λ (i : unit) (hi : i ∈ [()]), tt))))
| (n+1) :=
  match decide_if_zeros_aux n with
  | (result.true_for_n m, s) :=
    let s' := fst (p.transition.preimage s) in
    if p.init ∈ s.to_set then (result.false_after (n+1), s')
    else if s' ≤ s then (result.true_forall, s)
    else (result.true_for_n (n+1), s.or s')
  | x := x
  end

def decide_if_zeros [has_repr state.ι] (n : ℕ) : result :=
(decide_if_zeros_aux p n).1

end propagate_struc


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.Classes
import LeanColls.List.Basic

namespace LeanColls

/-! Definition of toList in terms of a fold.

Used to define correctness for [Foldable] and [Foldable']
-/
def canonicalToList (fold : {β : Type w} → (β → τ → β) → β → β) : List τ :=
  fold (λ acc x => acc ++ [x]) []

namespace Foldable

class Correct (C) (τ : outParam _) extends Foldable C τ where
  foldCorrect : ∀ {β} (c : C) (f : β → τ → β) acc,
    fold c f acc = (
      canonicalToList (fold c)
      |>.foldl f acc)

theorem fold_pair [F : Foldable.Correct C τ]
  (f₁ : β₁ → τ → β₁) (acc₁ : β₁) (f₂ : β₂ → τ → β₂) (acc₂ : β₂) (c : C)
  : F.fold c (λ (acc₁,acc₂) x => (f₁ acc₁ x, f₂ acc₂ x)) (acc₁, acc₂)
    = (F.fold c (λ acc₁ x => f₁ acc₁ x) acc₁,
       F.fold c (λ acc₂ x => f₂ acc₂ x) acc₂)
  := by
  let list := canonicalToList (F.fold c)
  suffices
    List.foldl (λ (acc₁,acc₂) x => (f₁ acc₁ x, f₂ acc₂ x)) (acc₁, acc₂) list
      = (List.foldl (λ acc₁ x => f₁ acc₁ x) acc₁ list,
         List.foldl (λ acc₂ x => f₂ acc₂ x) acc₂ list)
         by
    simp at this
    simp [←F.foldCorrect] at this
    exact this
  induction list generalizing acc₁ acc₂ with
  | nil =>
    simp [List.foldl]
  | cons x xs ih =>
    simp
    apply ih

end Foldable

namespace Foldable'

class Correct (C) (τ : outParam _) (M : outParam (Membership τ C))
  extends Foldable.Correct C τ, Foldable' C τ M where
  memCorrect : ∀ x (c : C), x ∈ c ↔ x ∈ canonicalToList (fold c)
  fold'Correct : ∀ {β} (c : C) (f : β → (x : τ) → x ∈ c → β) acc,
    fold' c f acc = (
      canonicalToList (fold c)
      |>.foldl' (λ acc x h => f acc x ((memCorrect x c).mpr h)) acc)

theorem fold_eq_fold' [M : Membership τ C] [F : Foldable'.Correct C τ M]
  (c : C) (f : β → τ → β) (acc : β)
  : F.fold c f acc = F.fold' c (λ acc x _ => f acc x) acc
  := by
  rw [F.foldCorrect]
  rw [F.fold'Correct]
  simp [canonicalToList, List.foldl_eq_foldl']

theorem fold'_append_singleton_eq_map [M : Membership τ C] [Foldable'.Correct C τ M]
  (c : C) (f : (x : τ) → x ∈ c → τ')
  : Foldable'.Correct.fold' c (λ acc x h => acc ++ [f x h]) []
    = (canonicalToList (Foldable.fold c)
      |>.map' (fun x h => f x ((Foldable'.Correct.memCorrect _ _).mpr h)))
  := by
  rw [Correct.fold'Correct]
  rw [List.foldl'_eq_subtypeByMem_foldl]
  rw [List.map', List.foldl_eq_map]

theorem fold_canonicalToList_fold'_eq_fold' [Foldable'.Correct C τ M]
  (c : C) (f' : (x : τ) → M.mem x c → τ') (f : β → τ' → β) (acc)
  : List.foldl f acc
    (canonicalToList (fun f init =>
      Foldable'.Correct.fold' c (fun acc x h => f acc (f' x h)) init
      )) = Foldable'.Correct.fold' c (fun acc x h => f acc (f' x h)) acc
  := by
  simp [canonicalToList]
  rw [fold'_append_singleton_eq_map]
  rw [List.map', List.foldl_map,
      Foldable'.Correct.fold'Correct,
      List.foldl'_eq_subtypeByMem_foldl]

theorem canonicalToList_fold'_eq_map' [Foldable'.Correct C τ M]
  (c : C) (f' : (x : τ) → M.mem x c → τ')
  : canonicalToList (fun f init =>
      Foldable'.Correct.fold' c (fun acc x h => f acc (f' x h)) init
      ) =
    (canonicalToList (Foldable.fold c)).map' (fun x h =>
      f' x ((Foldable'.Correct.memCorrect _ _).mpr h))
  := by
  conv =>
    lhs
    simp [canonicalToList]
    rw [Correct.fold'Correct]
    rw [List.foldl'_eq_subtypeByMem_foldl]
    rw [List.foldl_eq_map]


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import ring_theory.ring_hom_properties

/-!

# The meta properties of finite ring homomorphisms.

-/

namespace ring_hom

open_locale tensor_product

open tensor_product algebra.tensor_product

lemma finite_stable_under_composition :
  stable_under_composition @finite :=
by { introv R hf hg, exactI hg.comp hf }

lemma finite_respects_iso :
  respects_iso @finite :=
begin
  apply finite_stable_under_composition.respects_iso,
  introsI,
  exact finite.of_surjective _ e.to_equiv.surjective,
end

lemma finite_stable_under_base_change :
  stable_under_base_change @finite :=
begin
  refine stable_under_base_change.mk _ finite_respects_iso _,
  classical,
  introv h,
  resetI,
  replace h : module.finite R T := by { convert h, ext, rw algebra.smul_def, refl },
  suffices : module.finite S (S ⊗[R] T),
  { change module.finite _ _, convert this, ext, rw algebra.smul_def, refl },
  exactI infer_instance
end

end ring_hom