/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.big_operators.basic
import algebra.big_operators.pi
import category_theory.limits.shapes.biproducts
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import data.matrix.dmatrix

/-!
# Matrices over a category.

When `C` is a preadditive category, `Mat_ C` is the preadditive category
whose objects are finite tuples of objects in `C`, and
whose morphisms are matrices of morphisms from `C`.

There is a functor `Mat_.embedding : C ⥤ Mat_ C` sending morphisms to one-by-one matrices.

`Mat_ C` has finite biproducts.

## The additive envelope

We show that this construction is the "additive envelope" of `C`,
in the sense that any additive functor `F : C ⥤ D` to a category `D` with biproducts
lifts to a functor `Mat_.lift F : Mat_ C ⥤ D`,
Moreover, this functor is unique (up to natural isomorphisms) amongst functors `L : Mat_ C ⥤ D`
such that `embedding C ⋙ L ≅ F`.
(As we don't have 2-category theory, we can't explicitly state that `Mat_ C` is
the initial object in the 2-category of categories under `C` which have biproducts.)

As a consequence, when `C` already has finite biproducts we have `Mat_ C ≌ C`.

## Future work

We should provide a more convenient `Mat R`, when `R` is a ring,
as a category with objects `n : FinType`,
and whose morphisms are matrices with components in `R`.

Ideally this would conveniently interact with both `Mat_` and `matrix`.

-/

open category_theory category_theory.preadditive
open_locale big_operators
noncomputable theory

namespace category_theory

universes w v₁ v₂ u₁ u₂
variables (C : Type u₁) [category.{v₁} C] [preadditive C]

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ : Type (max (v₁+1) u₁) :=
(ι : Type v₁)
[F : fintype ι]
[D : decidable_eq ι]
(X : ι → C)

attribute [instance] Mat_.F Mat_.D

namespace Mat_

variables {C}

/-- A morphism in `Mat_ C` is a dependently typed matrix of morphisms. -/
@[nolint has_inhabited_instance]
def hom (M N : Mat_ C) : Type v₁ := dmatrix M.ι N.ι (λ i j, M.X i ⟶ N.X j)

namespace hom

/-- The identity matrix consists of identity morphisms on the diagonal, and zeros elsewhere. -/
def id (M : Mat_ C) : hom M M := λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0

/-- Composition of matrices using matrix multiplication. -/
def comp {M N K : Mat_ C} (f : hom M N) (g : hom N K) : hom M K :=
λ i k, ∑ j : N.ι, f i j ≫ g j k

end hom

section
local attribute [simp] hom.id hom.comp

instance : category.{v₁} (Mat_ C) :=
{ hom := hom,
  id := hom.id,
  comp := λ M N K f g, f.comp g,
  id_comp' := λ M N f, by simp [dite_comp],
  comp_id' := λ M N f, by simp [comp_dite],
  assoc' := λ M N K L f g h, begin
    ext i k,
    simp_rw [hom.comp, sum_comp, comp_sum, category.assoc],
    rw finset.sum_comm,
  end, }.

lemma id_def (M : Mat_ C) :
  (𝟙 M : hom M M) = λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

lemma id_apply (M : Mat_ C) (i j : M.ι) :
  (𝟙 M : hom M M) i j = if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat_ C) (i : M.ι) :
  (𝟙 M : hom M M) i i = 𝟙 _ :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat_ C) (i j : M.ι) (h : i ≠ j) :
  (𝟙 M : hom M M) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N.ι, f i j ≫ g j k := rfl

@[simp] lemma comp_apply {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N.ι, f i j ≫ g j k := rfl

instance (M N : Mat_ C) : inhabited (M ⟶ N) := ⟨λ i j, (0 : M.X i ⟶ N.X j)⟩

end

instance : preadditive (Mat_ C) :=
{ hom_group := λ M N, by { change add_comm_group (dmatrix M.ι N.ι _), apply_instance, },
  add_comp' := λ M N K f f' g, by { ext, simp [finset.sum_add_distrib], },
  comp_add' := λ M N K f g g', by { ext, simp [finset.sum_add_distrib], }, }

@[simp] lemma add_apply {M N : Mat_ C} (f g : M ⟶ N) (i j) : (f + g) i j = f i j + g i j := rfl

open category_theory.limits

/--
We now prove that `Mat_ C` has finite biproducts.

Be warned, however, that `Mat_ C` is not necessarily Krull-Schmidt,
and so the internal indexing of a biproduct may have nothing to do with the external indexing,
even though the construction we give uses a sigma type.
See however `iso_biproduct_embedding`.
-/
instance has_finite_biproducts : has_finite_biproducts (Mat_ C) :=
{ has_biproducts_of_shape := λ J 𝒟 ℱ, by exactI
  { has_biproduct := λ f,
    has_biproduct_of_total
    { X := ⟨Σ j : J, (f j).ι, λ p, (f p.1).X p.2⟩,
      π := λ j x y,
      begin
        dsimp at x ⊢,
        refine if h : x.1 = j then _ else 0,
        refine if h' : (@eq.rec J x.1 (λ j, (f j).ι) x.2 _ h) = y then _ else 0,
        apply eq_to_hom,
        substs h h', -- Notice we were careful not to use `subst` until we had a goal in `Prop`.
      end,
      ι := λ j x y,
      begin
        dsimp at y ⊢,
        refine if h : y.1 = j then _ else 0,
        refine if h' : (@eq.rec J y.1 (λ j, (f j).ι) y.2 _ h) = x then _ else 0,
        apply eq_to_hom,
        substs h h',
      end,
      ι_π := λ j j',
      begin
        ext x y,
        dsimp,
        simp_rw [dite_comp, comp_dite],
        simp only [if_t_t, dite_eq_ite, dif_ctx_congr, limits.comp_zero, limits.zero_comp,
          eq_to_hom_trans, finset.sum_congr],
        erw finset.sum_sigma,
        dsimp,
        simp only [if_congr, if_true, dif_ctx_congr, finset.sum_dite_irrel, finset.mem_univ,
          finset.sum_const_zero, finset.sum_congr, finset.sum_dite_eq'],
        split_ifs with h h',
        { substs h h',
          simp only [category_theory.eq_to_hom_refl, category_theory.Mat_.id_apply_self], },
        { subst h,
          simp only [id_apply_of_ne _ _ _ h', category_theory.eq_to_hom_refl], },
        { refl, },
      end, }
    begin
      dsimp,
      funext i₁,
      dsimp at i₁ ⊢,
      rcases i₁ with ⟨j₁, i₁⟩,
      -- I'm not sure why we can't just `simp` by `finset.sum_apply`: something doesn't quite match
      convert finset.sum_apply _ _ _ using 1,
      { refl, },
      { apply heq_of_eq,
        symmetry,
        funext i₂,
        rcases i₂ with ⟨j₂, i₂⟩,
        simp only [comp_apply, dite_comp, comp_dite,
          if_t_t, dite_eq_ite, if_congr, if_true, dif_ctx_congr,
          finset.sum_dite_irrel, finset.sum_dite_eq, finset.mem_univ, finset.sum_const_zero,
          finset.sum_congr, finset.sum_dite_eq, finset.sum_apply,
          limits.comp_zero, limits.zero_comp, eq_to_hom_trans, Mat_.id_apply],
        by_cases h : j₁ = j₂,
        { subst h, simp, },
        { simp [h], }, },
    end }}.

end Mat_

namespace functor
variables {C} {D : Type*} [category.{v₁} D] [preadditive D]

local attribute [simp] Mat_.id_apply

/--
A functor induces a functor of matrix categories.
-/
@[simps]
def map_Mat_ (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ Mat_ D :=
{ obj := λ M, ⟨M.ι, λ i, F.obj (M.X i)⟩,
  map := λ M N f i j, F.map (f i j),
  map_comp' := λ M N K f g, by { ext i k, simp,}, }

/--
The identity functor induces the identity functor on matrix categories.
-/
@[simps]
def map_Mat_id : (𝟭 C).map_Mat_ ≅ 𝟭 (Mat_ C) :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

/--
Composite functors induce composite functors on matrix categories.
-/
@[simps]
def map_Mat_comp {E : Type*} [category.{v₁} E] [preadditive E]
  (F : C ⥤ D) [functor.additive F] (G : D ⥤ E) [functor.additive G] :
  (F ⋙ G).map_Mat_ ≅ F.map_Mat_ ⋙ G.map_Mat_ :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

end functor

namespace Mat_

variables (C)

/-- The embedding of `C` into `Mat_ C` as one-by-one matrices.
(We index the summands by `punit`.) -/
@[simps]
def embedding : C ⥤ Mat_ C :=
{ obj := λ X, ⟨punit, λ _, X⟩,
  map := λ X Y f, λ _ _, f,
  map_id' := λ X, by { ext ⟨⟩ ⟨⟩, simp, },
  map_comp' := λ X Y Z f g, by { ext ⟨⟩ ⟨⟩, simp, }, }

namespace embedding

instance : faithful (embedding C) :=
{ map_injective' := λ X Y f g h, congr_fun (congr_fun h punit.star) punit.star, }

instance : full (embedding C) :=
{ preimage := λ X Y f, f punit.star punit.star, }

instance : functor.additive (embedding C) := {}

end embedding

instance [inhabited C] : inhabited (Mat_ C) := ⟨(embedding C).obj (default C)⟩

open category_theory.limits

variables {C}

/--
Every object in `Mat_ C` is isomorphic to the biproduct of its summands.
-/
@[simps]
def iso_biproduct_embedding (M : Mat_ C) : M ≅ ⨁ (λ i, (embedding C).obj (M.X i)) :=
{ hom := biproduct.lift (λ i j k, if h : j = i then eq_to_hom (congr_arg M.X h) else 0),
  inv := biproduct.desc (λ i j k, if h : i = k then eq_to_hom (congr_arg M.X h) else 0),
  hom_inv_id' :=
  begin
    simp only [biproduct.lift_desc],
    funext i,
    dsimp,
    convert finset.sum_apply _ _ _,
    { dsimp, refl, },
    { apply heq_of_eq,
      symmetry,
      funext j,
      simp only [finset.sum_apply],
      dsimp,
      simp [dite_comp, comp_dite, Mat_.id_apply], }
  end,
  inv_hom_id' :=
  begin
    apply biproduct.hom_ext,
    intro i,
    apply biproduct.hom_ext',
    intro j,
    simp only [category.id_comp, category.assoc,
      biproduct.lift_π, biproduct.ι_desc_assoc, biproduct.ι_π],
    ext ⟨⟩ ⟨⟩,
    simp [dite_comp, comp_dite],
    split_ifs,
    { subst h, simp, },
    { simp [h], },
  end, }.

variables {D : Type u₁} [category.{v₁} D] [preadditive D]

/-- Every `M` is a direct sum of objects from `C`, and `F` preserves biproducts. -/
@[simps]
def additive_obj_iso_biproduct (F : Mat_ C ⥤ D) [functor.additive F] (M : Mat_ C) :
  F.obj M ≅ ⨁ (λ i, F.obj ((embedding C).obj (M.X i))) :=
(F.map_iso (iso_biproduct_embedding M)) ≪≫ (F.map_biproduct _)

variables [has_finite_biproducts D]

@[reassoc] lemma additive_obj_iso_biproduct_naturality (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  F.map f ≫ (additive_obj_iso_biproduct F N).hom =
    (additive_obj_iso_biproduct F M).hom ≫
      biproduct.matrix (λ i j, F.map ((embedding C).map (f i j))) :=
begin
  -- This is disappointingly tedious.
  ext,
  dsimp [embedding],
  simp only [←F.map_comp, biproduct.lift_π, biproduct.matrix_π, category.assoc],
  simp only [←F.map_comp, ←F.map_sum, biproduct.lift_desc, biproduct.lift_π_assoc, comp_sum],
  simp only [comp_def, comp_dite, comp_zero, finset.sum_dite_eq', finset.mem_univ, if_true],
  dsimp,
  simp only [finset.sum_singleton, dite_comp, zero_comp],
  congr,
  symmetry,
  convert finset.sum_fn _ _, -- It's hard to use this as a simp lemma!
  simp only [finset.sum_fn, finset.sum_dite_eq],
  ext,
  simp,
end

@[reassoc] lemma additive_obj_iso_biproduct_naturality' (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  (additive_obj_iso_biproduct F M).inv ≫ F.map f =
    biproduct.matrix (λ i j, F.map ((embedding C).map (f i j)) : _) ≫
      (additive_obj_iso_biproduct F N).inv :=
by rw [iso.inv_comp_eq, ←category.assoc, iso.eq_comp_inv, additive_obj_iso_biproduct_naturality]

/-- Any additive functor `C ⥤ D` to a category `D` with finite biproducts extends to
a functor `Mat_ C ⥤ D`. -/
@[simps]
def lift (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.X i)),
  map := λ X Y f, biproduct.matrix (λ i j, F.map (f i j)),
  map_id' := λ X, begin
    ext i j,
    by_cases h : i = j,
    { subst h, simp, },
    { simp [h, Mat_.id_apply], },
  end,
  map_comp' := λ X Y Z f g, by { ext i j, simp, }, }.

instance lift_additive (F : C ⥤ D) [functor.additive F] : functor.additive (lift F) := {}

/-- An additive functor `C ⥤ D` factors through its lift to `Mat_ C ⥤ D`. -/
@[simps]
def embedding_lift_iso (F : C ⥤ D) [functor.additive F] : embedding C ⋙ lift F ≅ F :=
nat_iso.of_components (λ X,
  { hom := biproduct.desc (λ P, 𝟙 (F.obj X)),
    inv := biproduct.lift (λ P, 𝟙 (F.obj X)), })
(λ X Y f, begin
  dsimp,
  ext,
  simp only [category.id_comp, biproduct.ι_desc_assoc],
  erw biproduct.ι_matrix_assoc, -- Not sure why this doesn't fire via `simp`.
  simp,
end).

/--
`Mat_.lift F` is the unique additive functor `L : Mat_ C ⥤ D` such that `F ≅ embedding C ⋙ L`.
-/
def lift_unique (F : C ⥤ D) [functor.additive F] (L : Mat_ C ⥤ D) [functor.additive L]
  (α : embedding C ⋙ L ≅ F) :
  L ≅ lift F :=
nat_iso.of_components
  (λ M, (additive_obj_iso_biproduct L M) ≪≫
    (biproduct.map_iso (λ i, α.app (M.X i))) ≪≫
    (biproduct.map_iso (λ i, (embedding_lift_iso F).symm.app (M.X i))) ≪≫
    (additive_obj_iso_biproduct (lift F) M).symm)
(λ M N f, begin
  dsimp only [iso.trans_hom, iso.symm_hom, biproduct.map_iso_hom],
  simp only [additive_obj_iso_biproduct_naturality_assoc],
  simp only [biproduct.matrix_map_assoc, category.assoc],
  simp only [additive_obj_iso_biproduct_naturality'],
  simp only [biproduct.map_matrix_assoc, category.assoc],
  congr,
  ext j k ⟨⟩,
  dsimp, simp,
  convert α.hom.naturality (f j k),
  erw [biproduct.matrix_π],
  simp,
end).

-- TODO is there some uniqueness statement for the natural isomorphism in `lift_unique`?

/-- Two additive functors `Mat_ C ⥤ D` are naturally isomorphic if
their precompositions with `embedding C` are naturally isomorphic as functors `C ⥤ D`. -/
@[ext]
def ext {F G : Mat_ C ⥤ D} [functor.additive F] [functor.additive G]
  (α : embedding C ⋙ F ≅ embedding C ⋙ G) : F ≅ G :=
(lift_unique (embedding C ⋙ G) _ α) ≪≫ (lift_unique _ _ (iso.refl _)).symm

/--
Natural isomorphism needed in the construction of `equivalence_self_of_has_finite_biproducts`.
-/
def equivalence_self_of_has_finite_biproducts_aux [has_finite_biproducts C] :
  embedding C ⋙ 𝟭 (Mat_ C) ≅ embedding C ⋙ lift (𝟭 C) ⋙ embedding C :=
functor.right_unitor _ ≪≫
  (functor.left_unitor _).symm ≪≫
  (iso_whisker_right (embedding_lift_iso _).symm _) ≪≫
  functor.associator _ _ _

/--
A preadditive category that already has finite biproducts is equivalent to its additive envelope.

Note that we only prove this for a large category;
otherwise there are universe issues that I haven't attempted to sort out.
-/
def equivalence_self_of_has_finite_biproducts
  (C : Type (u₁+1)) [large_category C] [preadditive C] [has_finite_biproducts C] :
  Mat_ C ≌ C :=
equivalence.mk -- I suspect this is already an adjoint equivalence, but it seems painful to verify.
  (lift (𝟭 C))
  (embedding C)
  (ext equivalence_self_of_has_finite_biproducts_aux)
  (embedding_lift_iso (𝟭 C))

@[simp] lemma equivalence_self_of_has_finite_biproducts_functor
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).functor = lift (𝟭 C) :=
rfl

@[simp] lemma equivalence_self_of_has_finite_biproducts_inverse
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).inverse = embedding C :=
rfl

end Mat_

end category_theory


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Algebra.Polynomial.Polynomial
import Algdata.Data.Nat.Pow

inductive Vars : Type
| X : Vars
| Y : Vars
| Z : Vars
  deriving DecidableEq

instance : Repr Vars where
  reprPrec x _ := match x with | Vars.X => "X" | Vars.Y => "Y" | Vars.Z => "Z"

instance instLinearLTVars : LinearLT Vars where
  lt x y := match x, y with
    | Vars.X, Vars.Y => True
    | Vars.X, Vars.Z => True
    | Vars.Y, Vars.Z => True
    | _, _ => False
  trans {x} {y} {z} hxy hyz := by
    cases x <;> cases y <;> cases z <;> try {exact False.elim hxy} <;> try {exact False.elim hyz}
    exact True.intro
  irrefl x := by cases x <;> exact not_false
  trichot x y := by cases x <;> cases y <;> simp

instance instDecidableRelLTVars : DecidableRel (r:=LT.lt (α:=Vars)) := by
  intro x y
  cases x <;> cases y <;> try {exact isTrue (True.intro)} <;> try {exact isFalse not_false}

#print axioms instLinearLTVars

open Vars

#eval 3⊙[(X,2), (Y,4)]⊙[('A',3)] + 4⊙[(X,1)]⊙[('B',1)] + 1 + 0 + 4⊙[(X,2),(Y,4)]⊙[('B',3)]

#eval Nat.gpow  (3⊙[(X,1),(Z,1)] + 2⊙[(Y,2)] + 1⊙[(Y,1),(Z,1)]) 10
#eval Nat.sqPow (3⊙[(X,1),(Z,1)] + 2⊙[(Y,2)] + 1⊙[(Y,1),(Z,1)]) 10

def powpoly : Nat → Polynomial Int String MonomialOrder.deglex
| 0 => 3
| 1 => 1⊙[("e₁", 1)]
| 2 => 1⊙[("e₁",2)] + (-2)⊙[("e₂",1)]
| (n+3) => 1⊙[("e₁",1)] * powpoly (n+2) + (-1)⊙[("e₂",1)] * powpoly (n+1) + 1⊙[("e₃",1)] * powpoly n

#eval powpoly 5
#eval powpoly 15

def powpoly' : Nat → Polynomial Int Vars MonomialOrder.deglex :=
  λ n => 1⊙[(X,n)] + 1⊙[(Y,n)] + 1⊙[(Z,n)]

#eval List.map powpoly' $ List.ofFn (n:=15) Fin.val

def e_eval : String → Polynomial Int Vars MonomialOrder.deglex
| "e₁" => 1⊙[(X,1)] + 1⊙[(Y,1)] + 1⊙[(Z,1)]
| "e₂" => 1⊙[(X,1), (Y,1)] + 1⊙[(Y,1), (Z,1)] + 1⊙[(X,1), (Z,1)]
| "e₃" => 1⊙[(X,1), (Y,1), (Z,1)]
| _ => 0

instance (o : MonomialOrder Vars) : HPow (Polynomial Int Vars o) Nat (Polynomial Int Vars o) where
  hPow := Nat.sqPow

#eval List.map (λ n => (powpoly n).elim Polynomial.scalar e_eval) $ List.ofFn (n:=12) Fin.val

example : (powpoly 3).elim Polynomial.scalar e_eval = powpoly' 3 := by
  dsimp only [powpoly]
  dsimp only [powpoly']
  dsimp only [Polynomial.elim]
  rfl

example : (powpoly 4).elim Polynomial.scalar e_eval = powpoly' 4 := by
  dsimp only [powpoly]
  dsimp only [powpoly']
  dsimp only [Polynomial.elim]
  rfl

example : (powpoly 5).elim Polynomial.scalar e_eval = powpoly' 5 := by
  dsimp only [powpoly]
  dsimp only [powpoly']
  dsimp only [Polynomial.elim]
  rfl


import tactic

namespace AutomatonVerification

inductive state : Type
| q0
| q1
| q2
| q3

open state

inductive char : Type
| c0
| c1

open char

notation `Σ` := char

notation `Σ*` := list Σ

@[simp] def δ : state → Σ → list state
| q0 c0 := [q0]
| q1 c0 := [q2]
| q2 c0 := [q3]
| q3 c0 := []
| q0 c1 := [q0, q1]
| q1 c1 := [q2]
| q2 c1 := [q3]
| q3 c1 := []

@[simp] def δδ : state → Σ* → list state
| q [] := [q]
| q (c :: w') := (δ q c).bind (fun q', δδ q' w')

lemma δδ_correct_1 : ∀ (w : Σ*) (a b : Σ), q3 ∈ δδ q0 (w ++ [c1, a, b]) :=
  begin
    intros,
    induction w with c w', {
      rcases ⟨a, b⟩ with ⟨_ | _, _ | _⟩,
      all_goals { simp, },
    },
    cases c,
    all_goals { simp, tauto, },
  end

lemma q1_to_q3_2_inputs : ∀ w : Σ*, q3 ∈ δδ q1 w → ∃ a b, w = [a, b] :=
  begin
    intros w h,
    rcases w with _ | ⟨_ | _, _ | ⟨_ | _, _ | ⟨_ | _ , w⟩⟩⟩,
    all_goals { simp at *, },
    all_goals { tauto, },
  end

lemma δδ_correct_2 : ∀ w : Σ*, q3 ∈ δδ q0 w → ∃ w' a b, w = w' ++ [c1, a, b] :=
  begin
    intros w h,
    induction w with c w ih1, {
      simp at h,
      tauto,
    },
    cases c, {
      simp at h,
      rcases ih1 h with ⟨w', a, b, rfl⟩,
      existsi [c0 :: w', a, b],
      simp,
    },
    simp at h,
    cases h, {
      rcases ih1 h with ⟨w', a, b, rfl⟩,
      existsi [c1 :: w', a, b],
      simp,
    },
    rcases q1_to_q3_2_inputs w h with ⟨a, b, rfl⟩,
    existsi [[], a, b],
    simp,
  end

theorem δδ_correct
: ∀ w : Σ*, q3 ∈ δδ q0 w ↔ ∃ (w' : Σ*) (a b : Σ), w = w' ++ [c1, a, b] :=
  begin
    intros,
    split, {
      apply δδ_correct_2,
    },
    intros h,
    rcases h with ⟨x, a, b, rfl⟩,
    apply δδ_correct_1,
  end

end AutomatonVerification


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann

! This file was ported from Lean 3 source module data.rat.floor
! leanprover-community/mathlib commit e1bccd6e40ae78370f01659715d3c948716e3b7e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Floor
import Mathlib.Algebra.EuclideanDomain.Instances
import Mathlib.Data.Rat.Cast
import Mathlib.Tactic.FieldSimp
import Mathlib.Tactic.Set

/-!
# Floor Function for Rational Numbers

## Summary

We define the `FloorRing` instance on `ℚ`. Some technical lemmas relating `floor` to integer
division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

open Int

namespace Rat

variable {α : Type _} [LinearOrderedField α] [FloorRing α]

protected theorem floor_def' (a : ℚ) : a.floor = a.num / a.den := by
  rw [Rat.floor]
  split
  . next h => simp [h]
  . next => rfl

protected theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ Rat.floor r ↔ (z : ℚ) ≤ r
  | ⟨n, d, h, c⟩ => by
    simp [Rat.floor_def']
    rw [num_den']
    have h' := Int.ofNat_lt.2 (Nat.pos_of_ne_zero h)
    conv =>
      rhs
      rw [coe_int_eq_divInt, Rat.le_def zero_lt_one h', mul_one]
    exact Int.le_ediv_iff_mul_le h'
#align rat.le_floor Rat.le_floor

instance : FloorRing ℚ :=
  (FloorRing.ofFloor ℚ Rat.floor) fun _ _ => Rat.le_floor.symm

protected theorem floor_def {q : ℚ} : ⌊q⌋ = q.num / q.den := Rat.floor_def' q
#align rat.floor_def Rat.floor_def

theorem floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : ⌊(↑n : ℚ) / (↑d : ℚ)⌋ = n / (↑d : ℤ) := by
  rw [Rat.floor_def]
  obtain rfl | hd := @eq_zero_or_pos _ _ d
  · simp
  set q := (n : ℚ) / d with q_eq
  obtain ⟨c, n_eq_c_mul_num, d_eq_c_mul_denom⟩ : ∃ c, n = c * q.num ∧ (d : ℤ) = c * q.den :=
    by
    rw [q_eq]
    exact_mod_cast @Rat.exists_eq_mul_div_num_and_eq_mul_div_den n d (by exact_mod_cast hd.ne')
  rw [n_eq_c_mul_num, d_eq_c_mul_denom]
  refine' (Int.mul_ediv_mul_of_pos _ _ <| pos_of_mul_pos_left _ <| Int.coe_nat_nonneg q.den).symm
  rwa [← d_eq_c_mul_denom, Int.coe_nat_pos]
#align rat.floor_int_div_nat_eq_div Rat.floor_int_div_nat_eq_div

@[simp, norm_cast]
theorem floor_cast (x : ℚ) : ⌊(x : α)⌋ = ⌊x⌋ :=
  floor_eq_iff.2 (by exact_mod_cast floor_eq_iff.1 (Eq.refl ⌊x⌋))
#align rat.floor_cast Rat.floor_cast

@[simp, norm_cast]
theorem ceil_cast (x : ℚ) : ⌈(x : α)⌉ = ⌈x⌉ := by
  rw [← neg_inj, ← floor_neg, ← floor_neg, ← Rat.cast_neg, Rat.floor_cast]
#align rat.ceil_cast Rat.ceil_cast

@[simp, norm_cast]
theorem round_cast (x : ℚ) : round (x : α) = round x := by
  -- Porting note: `simp` worked rather than `simp [H]` in mathlib3
  have H : ((2 : ℚ) : α) = (2 : α) := Rat.cast_coe_nat 2
  have : ((x + 1 / 2 : ℚ) : α) = x + 1 / 2 := by simp [H]
  rw [round_eq, round_eq, ← this, floor_cast]
#align rat.round_cast Rat.round_cast

@[simp, norm_cast]
theorem cast_fract (x : ℚ) : (↑(fract x) : α) = fract (x : α) := by
  simp only [fract, cast_sub, cast_coe_int, floor_cast]
#align rat.cast_fract Rat.cast_fract

end Rat

theorem Int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % d = n - d * ⌊(n : ℚ) / d⌋ := by
  rw [eq_sub_of_add_eq <| Int.emod_add_ediv n d, Rat.floor_int_div_nat_eq_div]
#align int.mod_nat_eq_sub_mul_floor_rat_div Int.mod_nat_eq_sub_mul_floor_rat_div

theorem Nat.coprime_sub_mul_floor_rat_div_of_coprime {n d : ℕ} (n_coprime_d : n.coprime d) :
    ((n : ℤ) - d * ⌊(n : ℚ) / d⌋).natAbs.coprime d := by
  have : (n : ℤ) % d = n - d * ⌊(n : ℚ) / d⌋ := Int.mod_nat_eq_sub_mul_floor_rat_div
  rw [← this]
  have : d.coprime n := n_coprime_d.symm
  rwa [Nat.coprime, Nat.gcd_rec] at this
#align nat.coprime_sub_mul_floor_rat_div_of_coprime Nat.coprime_sub_mul_floor_rat_div_of_coprime

namespace Rat

theorem num_lt_succ_floor_mul_den (q : ℚ) : q.num < (⌊q⌋ + 1) * q.den := by
  suffices (q.num : ℚ) < (⌊q⌋ + 1) * q.den by exact_mod_cast this
  suffices (q.num : ℚ) < (q - fract q + 1) * q.den by
    have : (⌊q⌋ : ℚ) = q - fract q := eq_sub_of_add_eq <| floor_add_fract q
    rwa [this]
  suffices (q.num : ℚ) < q.num + (1 - fract q) * q.den by
    have : (q - fract q + 1) * q.den = q.num + (1 - fract q) * q.den
    calc
      (q - fract q + 1) * q.den = (q + (1 - fract q)) * q.den := by ring
      _ = q * q.den + (1 - fract q) * q.den := by rw [add_mul]
      _ = q.num + (1 - fract q) * q.den := by simp

    rwa [this]
  suffices 0 < (1 - fract q) * q.den by
    rw [← sub_lt_iff_lt_add']
    simpa
  have : 0 < 1 - fract q := by
    have : fract q < 1 := fract_lt_one q
    have : 0 + fract q < 1 := by simp [this]
    rwa [lt_sub_iff_add_lt]
  exact mul_pos this (by exact_mod_cast q.pos)
#align rat.num_lt_succ_floor_mul_denom Rat.num_lt_succ_floor_mul_den

theorem fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q) : (fract q⁻¹).num < q.num := by
  -- we know that the numerator must be positive
  have q_num_pos : 0 < q.num := Rat.num_pos_iff_pos.mpr q_pos
  -- we will work with the absolute value of the numerator, which is equal to the numerator
  have q_num_abs_eq_q_num : (q.num.natAbs : ℤ) = q.num := Int.natAbs_of_nonneg q_num_pos.le
  set q_inv := (q.den : ℚ) / q.num with q_inv_def
  have q_inv_eq : q⁻¹ = q_inv := Rat.inv_def''
  suffices (q_inv - ⌊q_inv⌋).num < q.num by rwa [q_inv_eq]
  suffices ((q.den - q.num * ⌊q_inv⌋ : ℚ) / q.num).num < q.num by
    field_simp [this, ne_of_gt q_num_pos]
  suffices (q.den : ℤ) - q.num * ⌊q_inv⌋ < q.num by
    -- use that `q.num` and `q.den` are coprime to show that the numerator stays unreduced
    have : ((q.den - q.num * ⌊q_inv⌋ : ℚ) / q.num).num = q.den - q.num * ⌊q_inv⌋ := by
      suffices ((q.den : ℤ) - q.num * ⌊q_inv⌋).natAbs.coprime q.num.natAbs by
        exact_mod_cast Rat.num_div_eq_of_coprime q_num_pos this
      have tmp := Nat.coprime_sub_mul_floor_rat_div_of_coprime q.reduced.symm
      simpa only [Nat.cast_natAbs, abs_of_nonneg q_num_pos.le] using tmp
    rwa [this]
  -- to show the claim, start with the following inequality
  have q_inv_num_denom_ineq : q⁻¹.num - ⌊q⁻¹⌋ * q⁻¹.den < q⁻¹.den := by
    have : q⁻¹.num < (⌊q⁻¹⌋ + 1) * q⁻¹.den := Rat.num_lt_succ_floor_mul_den q⁻¹
    have : q⁻¹.num < ⌊q⁻¹⌋ * q⁻¹.den + q⁻¹.den := by rwa [right_distrib, one_mul] at this
    rwa [← sub_lt_iff_lt_add'] at this
  -- use that `q.num` and `q.den` are coprime to show that q_inv is the unreduced reciprocal
  -- of `q`
  have : q_inv.num = q.den ∧ q_inv.den = q.num.natAbs := by
    have coprime_q_denom_q_num : q.den.coprime q.num.natAbs := q.reduced.symm
    have : Int.natAbs q.den = q.den := by simp
    rw [← this] at coprime_q_denom_q_num
    rw [q_inv_def]
    constructor
    · exact_mod_cast Rat.num_div_eq_of_coprime q_num_pos coprime_q_denom_q_num
    · suffices (((q.den : ℚ) / q.num).den : ℤ) = q.num.natAbs by exact_mod_cast this
      rw [q_num_abs_eq_q_num]
      exact_mod_cast Rat.den_div_eq_of_coprime q_num_pos coprime_q_denom_q_num
  rwa [q_inv_eq, this.left, this.right, q_num_abs_eq_q_num, mul_comm] at q_inv_num_denom_ineq
#align rat.fract_inv_num_lt_num_of_pos Rat.fract_inv_num_lt_num_of_pos

end Rat


import linear_algebra.tensor_product

variables {A R : Type*} [add_comm_group A] [comm_ring R]

open_locale tensor_product

variable (R)
def add_monoid_hom.base_change (M : Type*) [add_comm_group M] [module R M]
  (f : A →+ M) : (R ⊗[ℤ] A) →ₗ[R] M :=
let E : R →ₗ[ℤ] A →ₗ[ℤ] M :=
{ to_fun := λ r, r • f.to_int_linear_map,
  map_add' := begin
    intros r s, simp [add_smul],
  end,
  map_smul' := begin
    intros r x,
    simp [mul_smul],
    refine (zsmul_eq_smul_cast R r (x • add_monoid_hom.to_int_linear_map f)).symm,
  end } in
let EE := tensor_product.lift E in
{ to_fun := EE,
  map_add' := λ x y, EE.map_add _ _,
  map_smul' := begin
    intros r x,
    apply x.induction_on,
    { simp },
    { intros t a,
      dsimp,
      dsimp [EE], simp,
      have : r • t ⊗ₜ[ℤ] a = (r * t) ⊗ₜ[ℤ] a, by refl,
      simp [this, mul_smul] },
    { intros x y hx hy,
      simp [smul_add, hx, hy, EE.map_add] }
  end }

.

variables {R}

@[simp]
lemma add_monoid_hom.base_change_apply_tmul {M : Type*} [add_comm_group M] [module R M]
  (f : A →+ M) (r : R) (a : A) : f.base_change R M (r ⊗ₜ[ℤ] a)= r • f a :=
by { dsimp [add_monoid_hom.base_change], simp }

variable (R)
@[simps]
def to_base_change : A →+ R ⊗[ℤ] A :=
{ to_fun := λ a, 1 ⊗ₜ[ℤ] a,
  map_zero' := tensor_product.tmul_zero _ _,
  map_add' := tensor_product.tmul_add _ }

def base_change_equiv :
  (A →+ R) ≃ₗ[R] ((R ⊗[ℤ] A) →ₗ[R] R) :=
{ to_fun := λ f, f.base_change _ _,
  map_add' := begin
    intros f g, ext x,
    apply x.induction_on,
    { simp },
    { intros x y, simp [mul_add], },
    { intros r a h1 h2, simp only [linear_map.map_add, h1, h2] }
  end,
  map_smul' := begin
    intros r x, ext e,
    apply e.induction_on,
    { simp },
    { intros x y, simp, rw [← mul_assoc, mul_comm x, mul_assoc] },
    { intros r a h1 h2, simp only [linear_map.map_add, h1, h2] }
  end,
  inv_fun := λ f, f.to_add_monoid_hom.comp (to_base_change _),
  left_inv := λ f, by { ext, simp, },
  right_inv := λ f, begin
    ext x,
    apply x.induction_on,
    { simp, },
    { intros u v, simp, rw [← smul_eq_mul, ← f.map_smul], congr' 1,
      change ((u * 1) ⊗ₜ[ℤ] v) = _, rw mul_one, },
    { intros r a h1 h2, simp only [h1, h2, linear_map.map_add], },
  end }


inductive lev : Type
| univ_var : ℕ → lev
| zero : lev
| S : lev → lev
| max : lev → lev → lev
| imax : lev → lev → lev

namespace lev
instance : has_zero lev := ⟨lev.zero⟩

def subst : lev → ℕ → lev → lev
| (univ_var u) v l := if u = v then l else univ_var u
| 0 v l := 0
| (S l1) v l := S (subst l1 v l)
| (max l1 l2) v l := max (subst l1 v l) (subst l2 v l)
| (imax l1 l2) v l := imax (subst l1 v l) (subst l2 v l)

inductive le_add : lev → lev → ℤ → Prop
| nonneg_of_add_nonneg {l n} : 0 ≤ n → le_add 0 l n
| le_add_of_nonneg_right {l n} : 0 ≤ n → le_add l l n
| succ_le {l l' n} : le_add l l' (n - 1) → le_add (S l) l' n
| le_succ {l l' n} : le_add l l' (n + 1) → le_add l (S l') n
| le_max {l l1 l2 n} : le_add l l1 n → le_add l (max l1 l2) n
| le_max' {l l1 l2 n} : le_add l l2 n → le_add l (max l1 l2) n
| max_le {l l1 l2 n} : le_add l1 l n → le_add l2 l n → le_add (max l1 l2) l n
| imax_zero_le {l l1 n} : le_add 0 l n → le_add (imax l1 0) l n
| imax_succ_le {l l1 l2 n} : le_add (max l1 (S l2)) l n → le_add (imax l1 (S l2)) l n
| imax_imax_le {l l1 l2 l3 n} : le_add (max (imax l1 l3) (imax l2 l3)) l n → le_add (imax l1 (imax l2 l3)) l n
| le_imax_imax {l l1 l2 l3 n} : le_add l (max (imax l1 l3) (imax l2 l3)) n → le_add l (imax l1 (imax l2 l3)) n
| imax_imax_le' {l l1 l2 l3 n} : le_add (max (imax l1 l2) (imax l1 l3)) l n → le_add (imax l1 (imax l2 l3)) l n
| le_imax_imax' {l l1 l2 l3 n} : le_add l (max (imax l1 l2) (imax l1 l3)) n → le_add l (imax l1 (imax l2 l3)) n
| le_by_cases {l l' n u} : le_add (subst l u 0) (subst l' u 0) n →
  le_add (subst l u (S (univ_var u))) (subst l' u (S (univ_var u))) n → le_add l l' n

notation l ≤ l' + n := le_add l l' n
notation l ≤ l' := le_add l l' 0

inductive lev_def_eq : lev → lev → Prop
| anti_symm (l l') : (l : lev) ≤ l' → l' ≤ l → lev_def_eq l l'
end lev

inductive exp : Type
| sort : lev → exp
| var : ℕ → exp
| app : exp → exp → exp
| lam : exp → exp → exp
| pi : exp → exp → exp

namespace exp
def liftn : ℕ → exp → exp
| _ e@(sort _) := e
| n e@(var m) := if m < n then e else var (m + 1)
| n (app e1 e2) := app (liftn n e1) (liftn n e2)
| n (lam A e) := lam (liftn n A) (liftn (n + 1) e)
| n (pi A e) := pi (liftn n A) (liftn (n + 1) e)

def lift : exp → exp := liftn 0

def substn (a : exp) : ℕ → exp → exp
| _ e@(sort _) := e
| n e@(var m) := if m < n then e else if m = n then lift^[n] a else exp.var (m - 1)
| n (app e₁ e₂) := app (substn n e₁) (substn n e₂)
| n (lam A e) := lam (substn n A) (substn (n + 1) e)
| n (pi A e) := pi (substn n A) (substn (n + 1) e)

def subst (e a : exp) : exp := exp.substn a 0 e
end exp

def context := list exp

open lev exp

mutual inductive has_type, def_eq
with has_type : context → exp → exp → Prop
| const {Γ α β e l} : has_type Γ α (sort l) → has_type Γ e β → has_type (α :: Γ) e β
| var {Γ α l} : has_type Γ α (sort l) → has_type (α :: Γ) (var 0) (lift α)
| univ {l} : has_type [] (sort l) (sort (S l))
| app {Γ α β e1 e2} : has_type Γ e1 (pi α β) → has_type Γ e2 α → has_type Γ (app e1 e2) (subst β e2)
| lam {Γ α β e} : has_type (α :: Γ) e β → has_type Γ (lam α e) (pi α β)
| pi {Γ α β l1 l2} : has_type Γ α (sort l1) → has_type (α :: Γ) β (sort l2) → has_type Γ (pi α β) (sort (imax l1 l2))
| def_eq_subst {Γ α β e} : has_type Γ e α → def_eq Γ α β → has_type Γ e β
with def_eq : context → exp → exp → Prop
| refl {Γ α e} : has_type Γ e α → def_eq Γ e e
| symm {Γ e e'} : def_eq Γ e e' → def_eq Γ e' e
| trans {Γ e1 e2 e3} : def_eq Γ e1 e2 → def_eq Γ e2 e3 → def_eq Γ e1 e3
| sort_def_eq {Γ l1 l2} : lev_def_eq l1 l2 → def_eq Γ (sort l1) (sort l2)
| app_subst {Γ α β e1 e1' e2 e2'} : def_eq Γ e1 e1' → has_type Γ e1 (pi α β) → has_type Γ e1' (pi α β) →
  def_eq Γ e2 e2' → has_type Γ e2 α → has_type Γ e2' α → def_eq Γ (app e1 e2) (app e1' e2')
| lam_subst {Γ α α' e e'} : def_eq Γ α α' → def_eq (α :: Γ) e e' → def_eq Γ (lam α e) (lam α' e')
| pi_subst {Γ α α' β β'} : def_eq Γ α α' → def_eq (α :: Γ) β β' → def_eq Γ (pi α β) (pi α' β')
| β_reduc {Γ α β e e'} : has_type (α :: Γ) e β → has_type Γ e' α → def_eq Γ (app (lam α e) e') (subst e e')
| η_reduc {Γ α β e} : has_type Γ e (pi α β) → def_eq Γ (lam α (app e (var 0))) e
| proof_irrel {Γ p h h'} : has_type Γ p (sort 0) → has_type Γ h p → has_type Γ h' p → def_eq Γ h h'

inductive is_type (Γ : context) : exp → Prop
| mk {Γ α l} : has_type Γ α (sort l) → is_type α

inductive context.ok : context → Prop
| nil : context.ok []
| cons {Γ α} : context.ok Γ → is_type Γ α → context.ok (α :: Γ)

lemma context_ok_of_has_type {Γ e α} (h : has_type Γ e α) : context.ok Γ :=
begin
  induction h,
  repeat {constructor, assumption},
  exact context.ok.nil,
  repeat {assumption},
  cases h_x,
  assumption,
end


import SciLean.Core.FunctionProperties

namespace SciLean

--------------------------------------------------------------------------------
-- Core bootstrapping theorems
--------------------------------------------------------------------------------

instance IsLin_is_IsSmooth {X Y : Type} {Xs Y' : Type} [Vec Xs] [Vec Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] [inst : IsLinN n f]
  : IsSmoothN n f := ⟨sorry_proof⟩

instance {X Y} [Vec X] [Vec Y] (f : X → Y) [inst : IsSmoothN 1 f] : IsSmooth f := by
  induction inst
  apply IsSmooth.mk

@[simp ↓, diff]
theorem diff_of_linear {X Y} [Vec X] [Vec Y] (f : X → Y) [IsLin f]
  : ∂ f = λ _ dx => f dx := sorry_proof

@[simp ↓, diff]
theorem diff_of_linear_2 {X Y Z} [Vec X] [Vec Y] [Vec Z] (f : X → Y → Z) [IsLinN 2 f]
  : ∂ (uncurryN 2 f) = λ _ (dx,dy) => f dx dy := sorry_proof

--------------------------------------------------------------------------------
-- Prod.fst - (·.1)
--------------------------------------------------------------------------------

function_properties Prod.fst {X Y} [Vec X] [Vec Y] (xy : X×Y) : X
argument xy
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dxy.1 by symdiff

function_properties Prod.fst {X Y} [SemiHilbert X] [SemiHilbert Y] (xy : X×Y) : X
argument xy
  hasAdjoint := sorry_proof,
  abbrev † := ⟨xy',0⟩ by sorry_proof,
  hasAdjDiff := by apply HasAdjDiffN.mk'; symdiff; infer_instance,
  abbrev ∂† ℛ := (dxy', 0) by unfold adjointDifferential; symdiff; symdiff
  -- abbrev ℛ := (xy.1, λ dxy' => (dxy',0)) by symdiff

--------------------------------------------------------------------------------
-- Prod.snd - (·.2)
--------------------------------------------------------------------------------

function_properties Prod.snd {X Y} [Vec X] [Vec Y] (xy : X×Y) : Y
argument xy
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dxy.2 by symdiff -- ,
  -- abbrev 𝒯 := (xy.2, dxy.2) by symdiff

function_properties Prod.snd {X Y} [SemiHilbert X] [SemiHilbert Y] (xy : X×Y) : Y
argument xy
  hasAdjoint := sorry_proof,
  abbrev † := ⟨0, xy'⟩ by sorry_proof,
  hasAdjDiff := by apply HasAdjDiffN.mk'; symdiff; infer_instance,
  abbrev ∂† := (0, dxy') by unfold adjointDifferential; symdiff; symdiff,
  abbrev ℛ := (xy.2, λ dxy' => (0,dxy')) by symdiff

--------------------------------------------------------------------------------
-- Prod.mk
--------------------------------------------------------------------------------

function_properties Prod.mk {X Y} [Vec X] [Vec Y] (x : X) (y : Y) : X×Y
argument (x,y)
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := (dx, dy) by symdiff
argument x
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := (dx,0) by sorry_proof-- ,
  -- abbrev 𝒯 := ((x,y), (dx,0)) by symdiff
argument y
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := (0,dy) by sorry_proof -- ,
  -- abbrev 𝒯 := ((x,y), (0,dy)) by symdiff

function_properties Prod.mk {X Y} [SemiHilbert X] [SemiHilbert Y] (x : X) (y : Y) : X×Y
argument (x,y)
  hasAdjoint := sorry_proof,
  abbrev † := xy' by sorry_proof,
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dxy' by unfold adjointDifferential; symdiff; symdiff; simp; symdiff; admit
argument x
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dx'.1 by sorry_proof
argument y
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dy'.2 by sorry_proof

--------------------------------------------------------------------------------
-- Neg.neg - (-·)
--------------------------------------------------------------------------------

function_properties Neg.neg {X} [Vec X] (x : X) : X
argument x
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := - dx by symdiff-- ,
  -- abbrev 𝒯 := (-x, -dx) by symdiff

function_properties Neg.neg {X} [SemiHilbert X] (x : X) : X
argument x
  hasAdjoint := sorry_proof,
  abbrev † := - x' by sorry_proof,
  hasAdjDiff,
  abbrev ∂† ℛ := - dx' by unfold adjointDifferential; symdiff; symdiff

--------------------------------------------------------------------------------
-- HAdd.hAdd - (·+·)
--------------------------------------------------------------------------------

function_properties HAdd.hAdd {X} [Vec X]  (x y : X) : X
argument (x,y)
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx + dy by symdiff-- ,
  -- abbrev 𝒯 := (x+y, dx+dy) by symdiff
argument x
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx by sorry_proof-- ,
  -- abbrev 𝒯 := (x+y, dx) by symdiff
argument y
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dy by sorry_proof-- ,
  -- abbrev 𝒯 := (x+y, dy) by symdiff

function_properties HAdd.hAdd {X} [SemiHilbert X] (x y : X) : X
argument (x,y)
  hasAdjoint := sorry_proof,
  abbrev † := (xy',xy') by sorry_proof,
  hasAdjDiff := sorry_proof, -- by apply HasAdjDiffN.mk'; symdiff; (try infer_instance); sorry_proof,
  abbrev ∂† ℛ := (dxy', dxy') by unfold adjointDifferential; symdiff; symdiff; admit
argument x
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dx' by sorry_proof
argument y
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dy' by sorry_proof

--------------------------------------------------------------------------------
-- HSub.hSub - (·-·)
--------------------------------------------------------------------------------

function_properties HSub.hSub {X} [Vec X]  (x y : X) : X
argument (x,y)
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx - dy by symdiff-- ,
  -- abbrev 𝒯 := (x-y, dx-dy) by symdiff
argument x
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx by sorry_proof-- ,
  -- abbrev 𝒯 := (x-y, dx) by symdiff
argument y
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := -dy by sorry_proof-- ,
  -- abbrev 𝒯 := (x-y,-dy) by symdiff

function_properties HSub.hSub {X} [SemiHilbert X] (x y : X) : X
argument (x,y)
  hasAdjoint := sorry_proof,
  hasAdjDiff := sorry_proof, -- by apply HasAdjDiffN.mk'; symdiff; sorry_proof,
  abbrev † := (xy',-xy') by sorry_proof,
  abbrev ∂† ℛ := (dxy', -dxy') by unfold adjointDifferential; symdiff; symdiff; admit
argument x
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := dx' by sorry_proof
argument y
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := -dy' by sorry_proof

--------------------------------------------------------------------------------
-- HMul.hMul - (·*·)
--------------------------------------------------------------------------------

function_properties SMul.smul {X} [Vec X] (x : ℝ) (y : X) : X
argument (x,y)
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx•y + x•dy by sorry_proof
argument x
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := dx•y by sorry_proof
argument y
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := x•dy by sorry_proof

function_properties SMul.smul {X} [SemiHilbert X] (x : ℝ) (y : X) : X
argument y
  hasAdjoint := sorry_proof,
  abbrev † := x•y' by sorry_proof,
  hasAdjDiff,
  abbrev ∂† ℛ := x•dy' by unfold adjointDifferential; symdiff; symdiff

function_properties SMul.smul {X} [Hilbert X] (x : ℝ) (y : X) : X
argument x
  hasAdjoint := sorry_proof,
  abbrev † := ⟪x',y⟫ by sorry_proof,
  hasAdjDiff := by sorry_proof, -- apply HasAdjDiffN.mk'; symdiff; infer_instance,
  abbrev ∂† ℛ := ⟪dx',y⟫ by unfold adjointDifferential; sorry_proof -- symdiff; symdiff
argument (x,y)
  hasAdjDiff := sorry_proof, --  by apply HasAdjDiffN.mk'; symdiff; sorry_proof,
  abbrev ∂† ℛ := (⟪dxy',y⟫, x•dxy') by unfold adjointDifferential; symdiff; sorry_proof

--------------------------------------------------------------------------------
-- Inner.innet - ⟪·,·⟫
--------------------------------------------------------------------------------

function_properties Inner.inner {X} [Hilbert X] (x y : X) : ℝ
argument (x,y)
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := ⟪dx,y⟫ + ⟪x,dy⟫ by sorry_proof,
  hasAdjDiff := sorry_proof, -- by apply HasAdjDiffN.mk'; symdiff; sorry_proof,
  abbrev ∂† ℛ := (dxy'•x, dxy'•y) by sorry_proof
argument x ..
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := ⟪dx,y⟫ by symdiff
argument x
  hasAdjoint := sorry_proof,
  abbrev † := x'•y by sorry_proof
argument y
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := ⟪x,dy⟫ by symdiff,
  hasAdjoint := sorry_proof,
  abbrev † := y'•x by sorry_proof

--------------------------------------------------------------------------------
-- Inner.normSqr - ∥·∥²
--------------------------------------------------------------------------------

function_properties Inner.normSqr {X} [Hilbert X] (x : X) : ℝ
argument x
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := 2*⟪dx,x⟫ by sorry_proof,
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := (2*dx')•x by sorry_proof

--------------------------------------------------------------------------------
-- sum - ∑
--------------------------------------------------------------------------------

function_properties sum {X ι} [Vec X] [Enumtype ι] (f : ι → X) : X
argument f
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := sum df by symdiff

function_properties sum {X ι} [SemiHilbert X] [Enumtype ι] (f : ι → X) : X
argument f
  hasAdjoint := sorry_proof,
  abbrev † := λ _ => f' by sorry_proof,
  hasAdjDiff,
  abbrev ∂† ℛ := λ _ => df' by unfold adjointDifferential; symdiff; symdiff

--------------------------------------------------------------------------------
-- SmoothMap.val
--------------------------------------------------------------------------------

function_properties SmoothMap.val {X Y} [Vec X] [Vec Y] (f : X⟿Y) (x : X) : Y
argument (f,x)
  isSmooth := sorry_proof,
  abbrev ∂ := df x + ∂ f x dx by funext (f,x) (df,dx); simp; sorry_proof,
  abbrev 𝒯 := let (y,dy) := 𝒯 f x dx; (y, df x + dy) by unfold Smooth.tangentMap; symdiff
argument f
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := df x by symdiff
-- argument x
--   isSmooth := sorry_proof,
--   abbrev ∂ := ∂ f x dx by unfold Smooth.differential; symdiff,
--   abbrev 𝒯 := 𝒯 f x dx by unfold Smooth.tangentMap; symdiff

--------------------------------------------------------------------------------
-- SmoothMap.mk'
--------------------------------------------------------------------------------

-- instance SmoothMap.mk'.arg_f.prolongation.isSmoothT {X Y W} [Vec X] [Vec Y] [Vec W]
--   (f : W → X → Y) [IsSmoothNT 2 f]
--   : IsSmoothT (λ w => λ x ⟿ f w x) := sorry_proof

-- instance SmoothMap.mk'.arg_f.prolongation.diff_simp {X Y W} [Vec X] [Vec Y] [Vec W]
--   (f : W → X → Y) [IsSmoothNT 2 f]
--   : ∂ (λ w => λ x ⟿ f w x)
--     =
--     λ w dw => λ x ⟿ ∂ f w dw x:= sorry_proof

--------------------------------------------------------------------------------
-- LinMap.val
--------------------------------------------------------------------------------

function_properties LinMap.val {X Y} [Vec X] [Vec Y] (f : X⊸Y) (x : X) : Y
argument (f,x)
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := df x + f dx by funext (f,x) (df,dx); simp; sorry_proof
argument f ..
  isLin := sorry_proof,
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := df x by symdiff
-- argument x
--   isLin := sorry_proof-- ,
  -- isSmooth := sorry_proof,
  -- abbrev ∂ 𝒯 := f dx by symdiff

-- function_properties LinMap.val {X Y ι} [Enumtype ι] [FinVec X ι] [Hilbert Y] (f : X⊸Y) (x : X) : Y
-- argument f
--   hasAdjoint := sorry_proof,
--   isLin := sorry_proof,  -- TODO: this should be done automatically!
--   abbrev † := ⟨λ x' => ⟪x,x'⟫ * f', sorry_proof⟩ by sorry_proof,
--   hasAdjDiff,
--   abbrev ∂† ℛ := ⟨λ x' => ⟪x,x'⟫ * df', sorry_proof⟩ by unfold adjointDifferential; symdiff; symdiff

--------------------------------------------------------------------------------
-- LinMap.mk'
--------------------------------------------------------------------------------

-- instance SmoothMap.mk'.arg_f.prolongation.isSmoothT {X Y W} [Vec X] [Vec Y] [Vec W]
--   (f : W → X → Y) [IsSmoothNT 2 f]
--   : IsSmoothT (λ w => λ x ⟿ f w x) := sorry_proof

-- instance SmoothMap.mk'.arg_f.prolongation.diff_simp {X Y W} [Vec X] [Vec Y] [Vec W]
--   (f : W → X → Y) [IsSmoothNT 2 f]
--   : ∂ (λ w => λ x ⟿ f w x)
--     =
--     λ w dw => λ x ⟿ ∂ f w dw x:= sorry_proof


import linear_algebra.quotient
import algebra.category.Module.basic

namespace module

variables {A : Type*} [ring A] {M N L : Type*}
  [add_comm_group M]
  [add_comm_group N]
  [add_comm_group L]
  [module A M]
  [module A N]
  [module A L]
  (f : M →ₗ[A] N)
  (g : M →ₗ[A] L)

def compare_in_prod : M →ₗ[A] N × L :=
{ to_fun := λ m, ⟨f m , - g m⟩,
  map_add' := λ x y, by ext; simp [add_comm],
  map_smul' := λ r x, by ext; simp }

@[derive add_comm_group]
def pushout :=
(N × L) ⧸ (compare_in_prod f g).range

instance : module A (pushout f g) :=
show (module A ((N × L) ⧸ (compare_in_prod f g).range)), by apply_instance

def pushout.π : N × L →ₗ[A] pushout f g :=
(compare_in_prod f g).range.mkq -- mkq?

def pushout.inl : N →ₗ[A] pushout f g :=
{ to_fun := λ n, pushout.π _ _ (n,0),
  map_add' := λ x y, by { rw ← (pushout.π f g).map_add, congr' 1, ext; simp },
  map_smul' := λ r x, by { rw ← (pushout.π f g).map_smul, congr' 1, ext; simp } }

def pushout.inr : L →ₗ[A] pushout f g :=
{ to_fun := λ l, pushout.π _ _ (0,l),
  map_add' := λ x y, by { rw ← (pushout.π f g).map_add, congr' 1, ext; simp },
  map_smul' := λ r x, by { rw ← (pushout.π f g).map_smul, congr' 1, ext; simp } }

lemma surjective_of_comp_inl_eq_comp_inr (f : M →ₗ[A] N)
  (h :
    pushout.inl f.range.subtype f.range.subtype =
    pushout.inr f.range.subtype f.range.subtype ) : function.surjective f :=
begin
  intros b,
  apply_fun (λ e, e b) at h,
  dsimp [pushout.inl, pushout.inr, pushout.π] at h,
  rw submodule.quotient.eq at h,
  simp at h,
  obtain ⟨⟨a,⟨a,rfl⟩⟩,ht⟩ := h,
  dsimp [compare_in_prod] at ht,
  apply_fun (λ e, e.fst) at ht,
  use a,
  exact ht,
end

end module

open category_theory

namespace Module

universes u
theorem surjective_of_epi {A : Type u} [ring A] {M N : Module.{u} A}
  (f : M ⟶ N) [epi f] : function.surjective f :=
begin
  apply module.surjective_of_comp_inl_eq_comp_inr,
  apply_fun Module.of_hom,
  swap, { tidy },
  erw ← cancel_epi f,
  change linear_map.comp _ _ = linear_map.comp _ _,
  ext,
  dsimp [Module.of_hom, module.pushout.inl, module.pushout.inr, module.pushout.π],
  rw submodule.quotient.eq,
  simp,
  use ⟨_,⟨x,rfl⟩⟩,
  refl,
end

end Module


import Playground.Data.Bool.Basic

namespace List

theorem all_of_forall {α} {l : List α} {p : α → Prop} [DecidablePred p]
: (∀ x ∈ l, p x) → (l.all λ x => decide (p x)) = true
:= λ h => match l with
| [] => rfl
| a :: l => Bool.and_of_true
  (decide_eq_true (h a (Mem.head l)))
  (all_of_forall λ x hx => h x (Mem.tail a hx))

theorem forall_of_all {α} {l : List α} {p : α → Prop} [DecidablePred p]
: (l.all λ x => decide (p x)) = true → (∀ x ∈ l, p x)
:= λ h => match l with
| [] => λ x hx => nomatch hx
| a :: l => λ x hx => match hx with
  | Mem.head .. => of_decide_eq_true (Bool.and_left h)
  | Mem.tail _ hx => forall_of_all (Bool.and_right h) x hx

end List


import LeanCodePrompts.FirstTacticData
open Lean Parser Tactic

-- for testing
partial def allTheoremSyntaxes (text: String)
    (accum : Array String) : MetaM (Array String) := do
  if text.isEmpty then
      return accum
  else
      match (← partialParser (categoryParser `theoremAndTactic 0) text) with
      | none => allTheoremSyntaxes (text.drop 1) accum
      | some (_, head, tail) =>
          allTheoremSyntaxes tail (accum.push head)

def egFile := "import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.Ring.Basic
import Polylean.Morphisms
import Polylean.ProductGroups
import Polylean.EnumDecide
open SubNegMonoid

/-!
The section `Zhom` consists of results related to the scalar integer multiplication homomorphism of additive groups.

The later part contains the theory of free Abelian groups, with `ℤ` as an example, as well as a proof that the product of free Abelian groups is free.
-/

section Zhom

variable {A : Type} [abg : AddCommGroup A]

abbrev zhom (a: A) : ℤ → A :=
  fun n => abg.gsmul n a

theorem gsmul_succ (n: ℤ) (x : A) : gsmul (n+1) x = x + gsmul n x  := by
    cases n
    case ofNat k =>
      apply abg.gsmul_succ'
    case negSucc k =>
      induction k with
      | zero =>
        simp
        simp [add_zero]
        have l : -[1+ 0] + 1 = 0 := by rfl
        rw [l]
        have l₀ : gsmul 0 x = 0 := by apply abg.gsmul_zero'
        rw [l₀]
        simp
        rw [abg.gsmul_neg']
        simp
        let l : gsmul 1 x =
                x + gsmul (0) x := abg.gsmul_succ' 0 x
        rw [l]
        rw [l₀]
        simp
      | succ l _ =>
        have l₀ : -[1+ Nat.succ l] + 1 = -[1+ l] := by rfl
        rw [l₀]
        rw [abg.gsmul_neg']
        rw [abg.gsmul_neg']
        simp

        let l₁ := abg.gsmul_succ' (l + 1) x
        simp at l₁
        rw [l₁, ← add_assoc, neg_hom, ← add_assoc, neg_hom, ← add_assoc x _ _]
        simp

theorem isHom₁ (x : A) (n : ℤ) (m: Nat) :
      zhom x (n + m) = zhom x n + zhom x m :=
  by
    induction m with
    | zero =>
      simp [zhom]
    | succ k ih =>
      simp [zhom]
      simp [zhom] at ih
      rw [← add_assoc]
      simp
      simp
      let l₂ := gsmul_succ (n + k) x
      simp at l₂
      rw [l₂]
      rw [ih]
      simp
      conv =>
        lhs
        rw [← add_assoc]
        arg 1
        rw [add_comm]
      rw [← add_assoc]

theorem isHom₂ (x : A) (n m : Nat) :
        zhom x ((Int.negSucc n) + (Int.negSucc m)) =
          zhom x (Int.negSucc m) + zhom x (Int.negSucc n) :=
  by
    simp [zhom]
    repeat (rw [abg.gsmul_neg'])
    simp
    simp [Int.add]
    have l₀ : -[1+ n] + -[1+ m] = -[1+ (n + m) + 1] := by rfl
    rw [l₀]
    rw [abg.gsmul_neg']
    simp
    have l₁ : ((n : ℤ) + m + 1 + 1) = (n + 1) + (m + 1) := by
        rw [← add_assoc]
        simp [add_comm]
        rw [← add_assoc]
        simp [add_comm]
    rw [l₁]
    simp
    let l₂ := isHom₁ x (n  + 1) (m + 1)
    simp [zhom] at l₂
    rw [l₂]
    simp [neg_hom]
    rw [add_assoc, add_assoc]
    simp
    rw [add_comm, add_comm (-gsmul _ x) _, add_assoc, add_assoc]
    simp [add_comm]

theorem zhom_is_hom (x: A) (n m : ℤ) :
  zhom x (n + m) = zhom x n + zhom x m := by
  cases m
  case ofNat k =>
    apply isHom₁ x n k
  case negSucc k =>
    cases n
    case ofNat l =>
      let l₀ := isHom₁ x (Int.negSucc k) l
      rw [add_comm] at l₀
      conv =>
        rhs
        rw [add_comm]
      assumption
    case negSucc l =>
      let l₁ := isHom₂ x l k
      conv =>
        rhs
        rw [add_comm]
      assumption

theorem zhom_one (x : A) : zhom x 1 = x := by
  simp [zhom]
  let l : gsmul 1 x = x + gsmul 0 x := abg.gsmul_succ' 0 x
  rw [l]
  rw [abg.gsmul_zero' x]
  simp [add_zero]

instance zhomHom(a : A) : AddCommGroup.Homomorphism  (zhom a) :=
  ⟨zhom_is_hom a⟩

theorem unique_morphism_nat (f g : ℤ → A)[AddCommGroup.Homomorphism f]
        [AddCommGroup.Homomorphism g]:
          f 1 = g 1  → ∀ n: ℕ, f (n + 1) = g (n + 1) := by
          intro hyp
          intro n
          induction n with
          | zero =>
            simp [hyp]
          | succ k ih =>
            simp [hyp] at *
            assumption

theorem unique_morphism (f g : ℤ → A)[AddCommGroup.Homomorphism f]
        [AddCommGroup.Homomorphism g]: f 1 = g 1  → f = g := by
          intro hyp
          have fzero : f (Int.ofNat Nat.zero) = 0 :=  by simp
          have gzero : g (Int.ofNat Nat.zero) = 0 := by simp
          apply funext
          intro n
          cases n
          case ofNat k =>
            cases k
            case zero =>
              rw [fzero, gzero]
            case succ k' =>
              apply unique_morphism_nat f g hyp
          case negSucc k =>
            have fn : f (Int.negSucc k)  = -f (k + 1) := by
              simp [Int.negSucc_ofNat_eq]
            have gn : g (Int.negSucc k)  = -g (k + 1) := by
              simp [Int.negSucc_ofNat_eq]
            rw [fn, gn]
            let l := unique_morphism_nat f g hyp k
            rw [l]

end Zhom

class FreeAbelianGroup(F: Type)[AddCommGroup F] (X: Type) where
  i: X → F
  inducedMap : (A: Type) →  [AddCommGroup A] →  (X → A) → (F → A)
  induced_extends{A: Type}[AddCommGroup A] : ∀ f : X → A, (inducedMap A f) ∘ i = f
  induced_hom: (A: Type) → [abg : AddCommGroup A] →
      (f : X → A) →  AddCommGroup.Homomorphism (@inducedMap A abg f)
  unique_extension{A: Type}[AddCommGroup A]
    (f g : F → A)[AddCommGroup.Homomorphism f][AddCommGroup.Homomorphism g] :
       f ∘ i = g ∘ i  → f = g

section Homomorphisms

theorem unique_extension{F: Type}[AddCommGroup F] {X: Type}[fgp : FreeAbelianGroup F X]{A: Type}[AddCommGroup A] (f g : F → A)[AddCommGroup.Homomorphism f][AddCommGroup.Homomorphism g] : f ∘ fgp.i = g ∘ fgp.i  → f = g := fgp.unique_extension f g

@[inline] def fromBasis {F: Type}[AddCommGroup F]{X: Type}[fag : FreeAbelianGroup F X]{A: Type}[AddCommGroup A] (f: X → A) : F → A := by
    apply fag.inducedMap
    exact f

instance fromBasisHom {F: Type}[AddCommGroup F]
  {X: Type}[fag : FreeAbelianGroup F X]{A: Type}[AddCommGroup A]
  {f: X → A} : @AddCommGroup.Homomorphism F A _ _
    (@fromBasis F _ X  fag A _ f) := by
    apply fag.induced_hom

@[inline] def fromBasisFamily (F: Type)[AddCommGroup F]{X: Type}[fag : FreeAbelianGroup F X]{A: Type}[AddCommGroup A](D: Type)(f: D → X → A) : D →  F → A := by
    intro p
    apply fag.inducedMap
    exact f p

instance inducedHomomorphism (F : Type) [AddCommGroup F] {X : Type} [fag : FreeAbelianGroup F X]
  {A : Type} [AddCommGroup A] (f : X → A) : AddCommGroup.Homomorphism (fag.inducedMap A f) :=
    fag.induced_hom A f

instance fromBasisFamilyHom {F: Type}[AddCommGroup F]
  {X: Type}[fag : FreeAbelianGroup F X]{A: Type}[AddCommGroup A]{D : Type}
  {f: D → X → A}{p : D} :  @AddCommGroup.Homomorphism F A _ _
    ((@fromBasisFamily F _ X  fag A _ D f) p) := by
    apply fag.induced_hom

instance fromBasisHom' {F: Type}[AddCommGroup F]
  {X: Type}[fag : FreeAbelianGroup F X]{A: Type}[AddCommGroup A]
  {f: X → A} : @AddCommGroup.Homomorphism F A _ _
    (fag.inducedMap A f) := by
    apply fag.induced_hom

end Homomorphisms

section ZasFree
def unitBasis : Unit → ℤ  := fun _ => 1

instance intFree : FreeAbelianGroup ℤ Unit  where
  i := unitBasis
  inducedMap := fun A _ f => zhom (f ())
  induced_extends := by
    intro A _ f
    apply funext; intro u
    simp [unitBasis]
    apply zhom_one

  induced_hom := by
    intro A abg f
    simp
    exact ⟨zhom_is_hom (f ())⟩
  unique_extension := by
    intro A abg f g fh gh hyp
    let at1 := congrFun hyp ()
    simp [unitBasis] at at1
    apply unique_morphism f g at1
end ZasFree

open EnumDecide

section DecideHomsEqual
def decideHomsEqual{F: Type}[AddCommGroup F] (X: Type)[fgp : FreeAbelianGroup F X] {A: Type}[AddCommGroup A][DecidableEq A][DecideForall X] (f g : F → A)[AddCommGroup.Homomorphism f][AddCommGroup.Homomorphism g] : Decidable (f = g) :=
        if c : ∀ x : X, f (fgp.i x) = g (fgp.i x) then
        by
          apply Decidable.isTrue
          apply fgp.unique_extension f g
          apply funext
          intro x
          exact c x
        else by
          apply Decidable.isFalse
          intro contra
          let c' : ∀ (x : X), f (fgp.i x) = g (fgp.i x) := by
            intro x
            apply congrFun contra (fgp.i x)
          contradiction

instance decHomsEqual{F: Type}[AddCommGroup F]
  {X: Type}[fgp : FreeAbelianGroup F X]
  {A: Type}[AddCommGroup A][DecidableEq A][DecideForall X]
    (f g : F → A)[AddCommGroup.Homomorphism f][AddCommGroup.Homomorphism g] :
      Decidable (f = g) := by apply decideHomsEqual X

end DecideHomsEqual

section Examples
abbrev double : ℤ → ℤ := fromBasis (fun _ : Unit => 2)

def dblHom : AddCommGroup.Homomorphism (double ) := inferInstance

abbrev egAction : Fin 2 → ℤ → ℤ
| ⟨0, _⟩ => fromBasis (fun _ : Unit => 1)
| ⟨1, _⟩ => fromBasis (fun _ : Unit => -1)

def egHom₀  : AddCommGroup.Homomorphism (egAction 0) := inferInstance

-- proof of being an action

def egActionBasis' : Fin 2 → Unit → ℤ
| ⟨0, _⟩ => fun _ => 1
| ⟨1, _⟩ => fun _ => -1

abbrev egAction' := fromBasisFamily ℤ (Fin 2)  (egActionBasis')

def egHom' (x: Fin 2)  :
  AddCommGroup.Homomorphism (egAction' x) := inferInstance -- works!

def egHom'' (x y: Fin 2)  :
  AddCommGroup.Homomorphism <|
      (egAction' x) ∘ (egAction' y) := inferInstance -- works!

theorem egIsAction: ∀ (x y: Fin 2),
  (egAction' x) ∘ (egAction' y) = egAction' (x + y) := by decide -- works!

end Examples
section Product

variable {A B : Type _} [AddCommGroup A] [AddCommGroup B]
variable {X_A X_B : Type _}
variable [FAb_A : FreeAbelianGroup A X_A] [FAb_B : FreeAbelianGroup B X_B ]

def ι : (X_A ⊕ X_B) → A × B
  | Sum.inl x_a => (FAb_A.i x_a, 0)
  | Sum.inr x_b => (0, FAb_B.i x_b)

def inducedProdMap (G : Type _) [AddCommGroup G] (f : X_A ⊕ X_B → G) : A × B → G
  | (a, b) =>
    let f_A : X_A → G := f ∘ Sum.inl
    let f_B : X_B → G := f ∘ Sum.inr
    let ϕ_A : A → G := FAb_A.inducedMap  G f_A
    let ϕ_B : B → G := FAb_B.inducedMap  G f_B
    ϕ_A a + ϕ_B b

instance prodFree : FreeAbelianGroup (A × B) (X_A ⊕ X_B)  :=
  {
    i := ι
    inducedMap := inducedProdMap
    induced_extends := by
      intro G GrpG f
      apply funext
      intro x
      cases x
      · rename_i x_A
        show (inducedProdMap G f) (FAb_A.i x_A, (0 : B)) = _
        rw [inducedProdMap]
        simp
        have fA_extends : FreeAbelianGroup.inducedMap G (f ∘ Sum.inl) (FreeAbelianGroup.i x_A) = f (Sum.inl x_A) := congrFun (FAb_A.induced_extends (f ∘ Sum.inl)) x_A
        exact fA_extends
      · rename_i x_B
        show (inducedProdMap G f) ((0 : A), FAb_B.i x_B) = _
        rw [inducedProdMap]
        simp
        have fB_extends : FreeAbelianGroup.inducedMap G (f ∘ Sum.inr) (FreeAbelianGroup.i x_B) = f (Sum.inr x_B) := congrFun (FAb_B.induced_extends (f ∘ Sum.inr)) x_B
        exact fB_extends
    induced_hom := by
      intro G GrpG f
      apply AddCommGroup.Homomorphism.mk
      intro (a, b)
      intro (a', b')
      rw [DirectSum.add]
      repeat (rw [inducedProdMap])
      simp
      rw [add_assoc, add_assoc, add_left_cancel_iff, ← add_assoc, ← add_assoc, add_right_cancel_iff, add_comm]
    unique_extension := by
      intro G GrpG f g Homf Homg
      intro h
      apply funext
      intro (a, b)
      have coordsplit : (a, b) = (a, 0) + (0, b) := by rw [DirectSum.add, add_zero, zero_add]
      rw [coordsplit, Homf.add_dist, Homg.add_dist]
      have A_unique : f ∘ ι₁ = g ∘ ι₁ := by
        apply FAb_A.unique_extension (f ∘ ι₁) (g ∘ ι₁)
        apply funext
        intro x_A
        have := congrFun h (Sum.inl x_A)
        assumption
      have B_unique : f ∘ ι₂ = g ∘ ι₂ := by
        apply FAb_B.unique_extension (f ∘ ι₂) (g ∘ ι₂)
        apply funext
        intro x_B
        have := congrFun h (Sum.inr x_B)
        assumption
      have acoordeq : f (a, 0) = g (a, 0) := congrFun A_unique a
      have bcoordeq : f (0, b) = g (0, b) := congrFun B_unique b
      rw [acoordeq, bcoordeq]
  }

theorem FreeAbelianGroup.induced_left (G : Type _) [AddCommGroup G] (f : X_A ⊕ X_B → G) :
  (FreeAbelianGroup.inducedMap G f) ∘ (ι₁ : A → A × B) = (FAb_A.inducedMap G (f ∘ Sum.inl)) := by
    apply funext; intro a; simp [FreeAbelianGroup.inducedMap, inducedProdMap]

theorem FreeAbelianGroup.induced_right (G : Type _) [AddCommGroup G] (f : X_A ⊕ X_B → G) :
  (FreeAbelianGroup.inducedMap G f) ∘ (ι₂ : B → A × B) = (FAb_B.inducedMap G (f ∘ Sum.inr)) := by
    apply funext; intro b; simp [FreeAbelianGroup.inducedMap, inducedProdMap]

theorem FreeAbelianGroup.left_incl (xa : X_A) : FreeAbelianGroup.i ((Sum.inl xa) : X_A ⊕ X_B) = (FAb_A.i xa, (0 : B)) := by simp [i, ι]

theorem FreeAbelianGroup.right_incl (xb : X_B) : FreeAbelianGroup.i ((Sum.inr xb) : X_A ⊕ X_B) = ((0 : A), FAb_B.i xb) := by simp [i, ι]

end Product

namespace Z3

-- elements in the basis `X` of Z3 ; to be mapped by inclusion
def  ex : Unit ⊕ Unit ⊕ Unit := Sum.inl ()
def  ey : Unit ⊕ Unit ⊕ Unit := Sum.inr (Sum.inl ())
def  ez : Unit ⊕ Unit ⊕ Unit := Sum.inr (Sum.inr ())

def onX {α : Type _} : α × α × α →   Unit ⊕ Unit ⊕ Unit → α
| (a, _, _), (Sum.inl _) => a
| (_, b, _), (Sum.inr (Sum.inl _)) => b
| (_, _, c), (Sum.inr (Sum.inr _)) => c

instance free : FreeAbelianGroup (ℤ × ℤ × ℤ) (Unit ⊕ Unit ⊕ Unit) :=
        inferInstance

end Z3
"

#eval allTheoremSyntaxes egFile #[]

#eval getTheoremsTactics egFile

-- Extra example during debugging

def tacEg :=
"apply f
skip
decide"

def mlParse : MetaM <| Except String String := do
  return runParserCategory (← getEnv) `tactic tacEg |>.map
    fun s => s.reprint.get!

#eval mlParse

#eval partialParser (categoryParser `tactic 0) tacEg

#eval partialParser tacticSeq tacEg

def egThm2 := "theorem unique_morphism_nat (f g : ℤ → A)[AddCommGroup.Homomorphism f]
        [AddCommGroup.Homomorphism g]:
          f 1 = g 1  → ∀ n: ℕ, f (n + 1) = g (n + 1) := by
          intro hyp
          decide
          intro n
          induction n with
          | zero =>
            simp [hyp]
          | succ k ih =>
            simp [hyp] at *
            assumption"

#eval partialParser (categoryParser `theoremAndTactic 0) egThm2

#eval parseTactics tacEg

#eval parseTheoremAndTactic? egThm2

-- #eval getTheoremsTacticsFromPolyLean

#eval polyLeanFiles

def egBugFile := "/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.Data.Finset.Basic
import Mathlib.Data.List.Range

/-!
# Finite types

This file defines a typeclass to state that a type is finite.

## Main declarations

* `Fintype α`: Typeclass saying that a type is finite. It takes as fields a `Finset` and a proof
  that all terms of type `α` are in it.
* `Finset.univ`: The finset of all elements of a fintype.

-/

/-- `fintype α` means that `α` is finite, i.e. there are only
  finitely many distinct elements of type `α`. The evidence of this
  is a finset `elems` (a list up to permutation without duplicates),
  together with a proof that everything of type `α` is in the list. -/
class Fintype (α : Type _) where
  /-- The `Finset` of elements of a `Fintype`. -/
  elems : Finset α
  /-- The proof that every term of the type is contained in the `Finset` of elements. -/
  complete : ∀ x : α, x ∈ elems

namespace Finset

variable [Fintype α]

/-- `univ` is the universal finite set of type `finset α` implied from
  the assumption `fintype α`. -/
def univ : Finset α := Fintype.elems

@[simp] theorem mem_univ (x : α) : x ∈ (univ : Finset α) := Fintype.complete x

end Finset

namespace Fintype

instance (n : ℕ) : Fintype (Fin n) :=
  ⟨⟨List.finRange n, List.nodup_fin_range n⟩, List.mem_fin_range⟩

end Fintype
"

#eval getTheoremsTactics egBugFile

#eval partialParser (categoryParser `theoremAndTactic 0) egBugFile

#eval (egFile.splitOn "by").tailD []|>.length

#eval parseTacticBlocks egFile


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.limits.shapes.strict_initial
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.Terminal
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts

/-!
# Strict initial objects

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file sets up the basic theory of strict initial objects: initial objects where every morphism
to it is an isomorphism. This generalises a property of the empty set in the category of sets:
namely that the only function to the empty set is from itself.

We say `C` has strict initial objects if every initial object is strict, ie given any morphism
`f : A ⟶ I` where `I` is initial, then `f` is an isomorphism.
Strictly speaking, this says that *any* initial object must be strict, rather than that strict
initial objects exist, which turns out to be a more useful notion to formalise.

If the binary product of `X` with a strict initial object exists, it is also initial.

To show a category `C` with an initial object has strict initial objects, the most convenient way
is to show any morphism to the (chosen) initial object is an isomorphism and use
`has_strict_initial_objects_of_initial_is_strict`.

The dual notion (strict terminal objects) occurs much less frequently in practice so is ignored.

## TODO

* Construct examples of this: `Type*`, `Top`, `Groupoid`, simplicial types, posets.
* Construct the bottom element of the subobject lattice given strict initials.
* Show cartesian closed categories have strict initials

## References
* https://ncatlab.org/nlab/show/strict+initial+object
-/

universe v u

namespace CategoryTheory

namespace Limits

open Category

variable (C : Type u) [Category.{v} C]

section StrictInitial

#print CategoryTheory.Limits.HasStrictInitialObjects /-
/-- We say `C` has strict initial objects if every initial object is strict, ie given any morphism
`f : A ⟶ I` where `I` is initial, then `f` is an isomorphism.

Strictly speaking, this says that *any* initial object must be strict, rather than that strict
initial objects exist.
-/
class HasStrictInitialObjects : Prop where
  out : ∀ {I A : C} (f : A ⟶ I), IsInitial I → IsIso f
#align category_theory.limits.has_strict_initial_objects CategoryTheory.Limits.HasStrictInitialObjects
-/

variable {C}

section

variable [HasStrictInitialObjects C] {I : C}

#print CategoryTheory.Limits.IsInitial.isIso_to /-
theorem IsInitial.isIso_to (hI : IsInitial I) {A : C} (f : A ⟶ I) : IsIso f :=
  HasStrictInitialObjects.out f hI
#align category_theory.limits.is_initial.is_iso_to CategoryTheory.Limits.IsInitial.isIso_to
-/

#print CategoryTheory.Limits.IsInitial.strict_hom_ext /-
theorem IsInitial.strict_hom_ext (hI : IsInitial I) {A : C} (f g : A ⟶ I) : f = g :=
  by
  haveI := hI.is_iso_to f
  haveI := hI.is_iso_to g
  exact eq_of_inv_eq_inv (hI.hom_ext (inv f) (inv g))
#align category_theory.limits.is_initial.strict_hom_ext CategoryTheory.Limits.IsInitial.strict_hom_ext
-/

#print CategoryTheory.Limits.IsInitial.subsingleton_to /-
theorem IsInitial.subsingleton_to (hI : IsInitial I) {A : C} : Subsingleton (A ⟶ I) :=
  ⟨hI.strict_hom_ext⟩
#align category_theory.limits.is_initial.subsingleton_to CategoryTheory.Limits.IsInitial.subsingleton_to
-/

#print CategoryTheory.Limits.initial_mono_of_strict_initial_objects /-
instance (priority := 100) initial_mono_of_strict_initial_objects : InitialMonoClass C
    where isInitial_mono_from I A hI :=
    { right_cancellation := fun B g h i => hI.strict_hom_ext _ _ }
#align category_theory.limits.initial_mono_of_strict_initial_objects CategoryTheory.Limits.initial_mono_of_strict_initial_objects
-/

#print CategoryTheory.Limits.mulIsInitial /-
/-- If `I` is initial, then `X ⨯ I` is isomorphic to it. -/
@[simps Hom]
noncomputable def mulIsInitial (X : C) [HasBinaryProduct X I] (hI : IsInitial I) : X ⨯ I ≅ I :=
  @asIso _ prod.snd (hI.isIso_to _)
#align category_theory.limits.mul_is_initial CategoryTheory.Limits.mulIsInitial
-/

#print CategoryTheory.Limits.mulIsInitial_inv /-
@[simp]
theorem mulIsInitial_inv (X : C) [HasBinaryProduct X I] (hI : IsInitial I) :
    (mulIsInitial X hI).inv = hI.to _ :=
  hI.hom_ext _ _
#align category_theory.limits.mul_is_initial_inv CategoryTheory.Limits.mulIsInitial_inv
-/

#print CategoryTheory.Limits.isInitialMul /-
/-- If `I` is initial, then `I ⨯ X` is isomorphic to it. -/
@[simps Hom]
noncomputable def isInitialMul (X : C) [HasBinaryProduct I X] (hI : IsInitial I) : I ⨯ X ≅ I :=
  @asIso _ prod.fst (hI.isIso_to _)
#align category_theory.limits.is_initial_mul CategoryTheory.Limits.isInitialMul
-/

#print CategoryTheory.Limits.isInitialMul_inv /-
@[simp]
theorem isInitialMul_inv (X : C) [HasBinaryProduct I X] (hI : IsInitial I) :
    (isInitialMul X hI).inv = hI.to _ :=
  hI.hom_ext _ _
#align category_theory.limits.is_initial_mul_inv CategoryTheory.Limits.isInitialMul_inv
-/

variable [HasInitial C]

#print CategoryTheory.Limits.initial_isIso_to /-
instance initial_isIso_to {A : C} (f : A ⟶ ⊥_ C) : IsIso f :=
  initialIsInitial.isIso_to _
#align category_theory.limits.initial_is_iso_to CategoryTheory.Limits.initial_isIso_to
-/

#print CategoryTheory.Limits.initial.hom_ext /-
@[ext]
theorem initial.hom_ext {A : C} (f g : A ⟶ ⊥_ C) : f = g :=
  initialIsInitial.strict_hom_ext _ _
#align category_theory.limits.initial.hom_ext CategoryTheory.Limits.initial.hom_ext
-/

#print CategoryTheory.Limits.initial.subsingleton_to /-
theorem initial.subsingleton_to {A : C} : Subsingleton (A ⟶ ⊥_ C) :=
  initialIsInitial.subsingleton_to
#align category_theory.limits.initial.subsingleton_to CategoryTheory.Limits.initial.subsingleton_to
-/

#print CategoryTheory.Limits.mulInitial /-
/-- The product of `X` with an initial object in a category with strict initial objects is itself
initial.
This is the generalisation of the fact that `X × empty ≃ empty` for types (or `n * 0 = 0`).
-/
@[simps Hom]
noncomputable def mulInitial (X : C) [HasBinaryProduct X (⊥_ C)] : X ⨯ ⊥_ C ≅ ⊥_ C :=
  mulIsInitial _ initialIsInitial
#align category_theory.limits.mul_initial CategoryTheory.Limits.mulInitial
-/

#print CategoryTheory.Limits.mulInitial_inv /-
@[simp]
theorem mulInitial_inv (X : C) [HasBinaryProduct X (⊥_ C)] : (mulInitial X).inv = initial.to _ :=
  Subsingleton.elim _ _
#align category_theory.limits.mul_initial_inv CategoryTheory.Limits.mulInitial_inv
-/

#print CategoryTheory.Limits.initialMul /-
/-- The product of `X` with an initial object in a category with strict initial objects is itself
initial.
This is the generalisation of the fact that `empty × X ≃ empty` for types (or `0 * n = 0`).
-/
@[simps Hom]
noncomputable def initialMul (X : C) [HasBinaryProduct (⊥_ C) X] : (⊥_ C) ⨯ X ≅ ⊥_ C :=
  isInitialMul _ initialIsInitial
#align category_theory.limits.initial_mul CategoryTheory.Limits.initialMul
-/

#print CategoryTheory.Limits.initialMul_inv /-
@[simp]
theorem initialMul_inv (X : C) [HasBinaryProduct (⊥_ C) X] : (initialMul X).inv = initial.to _ :=
  Subsingleton.elim _ _
#align category_theory.limits.initial_mul_inv CategoryTheory.Limits.initialMul_inv
-/

end

#print CategoryTheory.Limits.hasStrictInitialObjects_of_initial_is_strict /-
/-- If `C` has an initial object such that every morphism *to* it is an isomorphism, then `C`
has strict initial objects. -/
theorem hasStrictInitialObjects_of_initial_is_strict [HasInitial C]
    (h : ∀ (A) (f : A ⟶ ⊥_ C), IsIso f) : HasStrictInitialObjects C :=
  {
    out := fun I A f hI =>
      haveI := h A (f ≫ hI.to _)
      ⟨⟨hI.to _ ≫ inv (f ≫ hI.to (⊥_ C)), by rw [← assoc, is_iso.hom_inv_id], hI.hom_ext _ _⟩⟩ }
#align category_theory.limits.has_strict_initial_objects_of_initial_is_strict CategoryTheory.Limits.hasStrictInitialObjects_of_initial_is_strict
-/

end StrictInitial

section StrictTerminal

#print CategoryTheory.Limits.HasStrictTerminalObjects /-
/-- We say `C` has strict terminal objects if every terminal object is strict, ie given any morphism
`f : I ⟶ A` where `I` is terminal, then `f` is an isomorphism.

Strictly speaking, this says that *any* terminal object must be strict, rather than that strict
terminal objects exist.
-/
class HasStrictTerminalObjects : Prop where
  out : ∀ {I A : C} (f : I ⟶ A), IsTerminal I → IsIso f
#align category_theory.limits.has_strict_terminal_objects CategoryTheory.Limits.HasStrictTerminalObjects
-/

variable {C}

section

variable [HasStrictTerminalObjects C] {I : C}

#print CategoryTheory.Limits.IsTerminal.isIso_from /-
theorem IsTerminal.isIso_from (hI : IsTerminal I) {A : C} (f : I ⟶ A) : IsIso f :=
  HasStrictTerminalObjects.out f hI
#align category_theory.limits.is_terminal.is_iso_from CategoryTheory.Limits.IsTerminal.isIso_from
-/

#print CategoryTheory.Limits.IsTerminal.strict_hom_ext /-
theorem IsTerminal.strict_hom_ext (hI : IsTerminal I) {A : C} (f g : I ⟶ A) : f = g :=
  by
  haveI := hI.is_iso_from f
  haveI := hI.is_iso_from g
  exact eq_of_inv_eq_inv (hI.hom_ext (inv f) (inv g))
#align category_theory.limits.is_terminal.strict_hom_ext CategoryTheory.Limits.IsTerminal.strict_hom_ext
-/

#print CategoryTheory.Limits.IsTerminal.subsingleton_to /-
theorem IsTerminal.subsingleton_to (hI : IsTerminal I) {A : C} : Subsingleton (I ⟶ A) :=
  ⟨hI.strict_hom_ext⟩
#align category_theory.limits.is_terminal.subsingleton_to CategoryTheory.Limits.IsTerminal.subsingleton_to
-/

variable {J : Type v} [SmallCategory J]

/- warning: category_theory.limits.limit_π_is_iso_of_is_strict_terminal -> CategoryTheory.Limits.limit_π_isIso_of_is_strict_terminal is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasStrictTerminalObjects.{u1, u2} C _inst_1] {J : Type.{u1}} [_inst_3 : CategoryTheory.SmallCategory.{u1} J] (F : CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_3 C _inst_1) [_inst_4 : CategoryTheory.Limits.HasLimit.{u1, u1, u1, u2} J _inst_3 C _inst_1 F] (i : J), (forall (j : J), (Ne.{succ u1} J j i) -> (CategoryTheory.Limits.IsTerminal.{u1, u2} C _inst_1 (CategoryTheory.Functor.obj.{u1, u1, u1, u2} J _inst_3 C _inst_1 F j))) -> (forall [_inst_5 : Subsingleton.{succ u1} (Quiver.Hom.{succ u1, u1} J (CategoryTheory.CategoryStruct.toQuiver.{u1, u1} J (CategoryTheory.Category.toCategoryStruct.{u1, u1} J _inst_3)) i i)], CategoryTheory.IsIso.{u1, u2} C _inst_1 (CategoryTheory.Limits.limit.{u1, u1, u1, u2} J _inst_3 C _inst_1 F _inst_4) (CategoryTheory.Functor.obj.{u1, u1, u1, u2} J _inst_3 C _inst_1 F i) (CategoryTheory.Limits.limit.π.{u1, u1, u1, u2} J _inst_3 C _inst_1 F _inst_4 i))
but is expected to have type
  forall {C : Type.{u2}} [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasStrictTerminalObjects.{u1, u2} C _inst_1] {J : Type.{u1}} [_inst_3 : CategoryTheory.SmallCategory.{u1} J] (F : CategoryTheory.Functor.{u1, u1, u1, u2} J _inst_3 C _inst_1) [_inst_4 : CategoryTheory.Limits.HasLimit.{u1, u1, u1, u2} J _inst_3 C _inst_1 F] (i : J), (forall (j : J), (Ne.{succ u1} J j i) -> (CategoryTheory.Limits.IsTerminal.{u1, u2} C _inst_1 (Prefunctor.obj.{succ u1, succ u1, u1, u2} J (CategoryTheory.CategoryStruct.toQuiver.{u1, u1} J (CategoryTheory.Category.toCategoryStruct.{u1, u1} J _inst_3)) C (CategoryTheory.CategoryStruct.toQuiver.{u1, u2} C (CategoryTheory.Category.toCategoryStruct.{u1, u2} C _inst_1)) (CategoryTheory.Functor.toPrefunctor.{u1, u1, u1, u2} J _inst_3 C _inst_1 F) j))) -> (forall [_inst_5 : Subsingleton.{succ u1} (Quiver.Hom.{succ u1, u1} J (CategoryTheory.CategoryStruct.toQuiver.{u1, u1} J (CategoryTheory.Category.toCategoryStruct.{u1, u1} J _inst_3)) i i)], CategoryTheory.IsIso.{u1, u2} C _inst_1 (CategoryTheory.Limits.limit.{u1, u1, u1, u2} J _inst_3 C _inst_1 F _inst_4) (Prefunctor.obj.{succ u1, succ u1, u1, u2} J (CategoryTheory.CategoryStruct.toQuiver.{u1, u1} J (CategoryTheory.Category.toCategoryStruct.{u1, u1} J _inst_3)) C (CategoryTheory.CategoryStruct.toQuiver.{u1, u2} C (CategoryTheory.Category.toCategoryStruct.{u1, u2} C _inst_1)) (CategoryTheory.Functor.toPrefunctor.{u1, u1, u1, u2} J _inst_3 C _inst_1 F) i) (CategoryTheory.Limits.limit.π.{u1, u1, u1, u2} J _inst_3 C _inst_1 F _inst_4 i))
Case conversion may be inaccurate. Consider using '#align category_theory.limits.limit_π_is_iso_of_is_strict_terminal CategoryTheory.Limits.limit_π_isIso_of_is_strict_terminalₓ'. -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (j «expr ≠ » i) -/
/-- If all but one object in a diagram is strict terminal, the the limit is isomorphic to the
said object via `limit.π`. -/
theorem limit_π_isIso_of_is_strict_terminal (F : J ⥤ C) [HasLimit F] (i : J)
    (H : ∀ (j) (_ : j ≠ i), IsTerminal (F.obj j)) [Subsingleton (i ⟶ i)] : IsIso (limit.π F i) := by
  classical
    refine' ⟨⟨limit.lift _ ⟨_, ⟨_, _⟩⟩, _, _⟩⟩
    ·
      exact fun j =>
        dite (j = i)
          (fun h =>
            eq_to_hom
              (by
                cases h
                rfl))
          fun h => (H _ h).from _
    · intro j k f
      split_ifs
      · cases h
        cases h_1
        obtain rfl : f = 𝟙 _ := Subsingleton.elim _ _
        simpa
      · cases h
        erw [category.comp_id]
        haveI : is_iso (F.map f) := (H _ h_1).isIso_from _
        rw [← is_iso.comp_inv_eq]
        apply (H _ h_1).hom_ext
      · cases h_1
        apply (H _ h).hom_ext
      · apply (H _ h).hom_ext
    · ext
      rw [assoc, limit.lift_π]
      dsimp only
      split_ifs
      · cases h
        rw [id_comp, eq_to_hom_refl]
        exact comp_id _
      · apply (H _ h).hom_ext
    · rw [limit.lift_π]
      simpa
#align category_theory.limits.limit_π_is_iso_of_is_strict_terminal CategoryTheory.Limits.limit_π_isIso_of_is_strict_terminal

variable [HasTerminal C]

#print CategoryTheory.Limits.terminal_isIso_from /-
instance terminal_isIso_from {A : C} (f : ⊤_ C ⟶ A) : IsIso f :=
  terminalIsTerminal.isIso_from _
#align category_theory.limits.terminal_is_iso_from CategoryTheory.Limits.terminal_isIso_from
-/

#print CategoryTheory.Limits.terminal.hom_ext /-
@[ext]
theorem terminal.hom_ext {A : C} (f g : ⊤_ C ⟶ A) : f = g :=
  terminalIsTerminal.strict_hom_ext _ _
#align category_theory.limits.terminal.hom_ext CategoryTheory.Limits.terminal.hom_ext
-/

#print CategoryTheory.Limits.terminal.subsingleton_to /-
theorem terminal.subsingleton_to {A : C} : Subsingleton (⊤_ C ⟶ A) :=
  terminalIsTerminal.subsingleton_to
#align category_theory.limits.terminal.subsingleton_to CategoryTheory.Limits.terminal.subsingleton_to
-/

end

#print CategoryTheory.Limits.hasStrictTerminalObjects_of_terminal_is_strict /-
/-- If `C` has an object such that every morphism *from* it is an isomorphism, then `C`
has strict terminal objects. -/
theorem hasStrictTerminalObjects_of_terminal_is_strict (I : C) (h : ∀ (A) (f : I ⟶ A), IsIso f) :
    HasStrictTerminalObjects C :=
  {
    out := fun I' A f hI' =>
      haveI := h A (hI'.from _ ≫ f)
      ⟨⟨inv (hI'.from I ≫ f) ≫ hI'.from I, hI'.hom_ext _ _, by rw [assoc, is_iso.inv_hom_id]⟩⟩ }
#align category_theory.limits.has_strict_terminal_objects_of_terminal_is_strict CategoryTheory.Limits.hasStrictTerminalObjects_of_terminal_is_strict
-/

end StrictTerminal

end Limits

end CategoryTheory