/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.const
import Mathlib.category_theory.discrete_category
import Mathlib.category_theory.yoneda
import Mathlib.category_theory.reflects_isomorphisms
import Mathlib.PostPort

universes v u l u'

namespace Mathlib

namespace category_theory

namespace functor

/--
`F.cones` is the functor assigning to an object `X` the type of
natural transformations from the constant functor with value `X` to `F`.
An object representing this functor is a limit of `F`.
-/
def cones {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) : Cᵒᵖ ⥤ Type v :=
  functor.op (const J) ⋙ obj yoneda F

/--
`F.cocones` is the functor assigning to an object `X` the type of
natural transformations from `F` to the constant functor with value `X`.
An object corepresenting this functor is a colimit of `F`.
-/
@[simp] theorem cocones_obj {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) (X : C) : obj (cocones F) X = (F ⟶ obj (const J) X) :=
  Eq.refl (F ⟶ obj (const J) X)

end functor

/--
Functorially associated to each functor `J ⥤ C`, we have the `C`-presheaf consisting of
cones with a given cone point.
-/
@[simp] theorem cones_map (J : Type v) [small_category J] (C : Type u) [category C] (F : J ⥤ C) (G : J ⥤ C) (f : F ⟶ G) : functor.map (cones J C) f = whisker_left (functor.op (functor.const J)) (functor.map yoneda f) :=
  Eq.refl (functor.map (cones J C) f)

/--
Contravariantly associated to each functor `J ⥤ C`, we have the `C`-copresheaf consisting of
cocones with a given cocone point.
-/
@[simp] theorem cocones_obj (J : Type v) [small_category J] (C : Type u) [category C] (F : J ⥤ Cᵒᵖ) : functor.obj (cocones J C) F = functor.cocones (opposite.unop F) :=
  Eq.refl (functor.obj (cocones J C) F)

namespace limits

/--
A `c : cone F` is:
* an object `c.X` and
* a natural transformation `c.π : c.X ⟶ F` from the constant `c.X` functor to `F`.

`cone F` is equivalent, via `cone.equiv` below, to `Σ X, F.cones.obj X`.
-/
structure cone {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C)
where
  X : C
  π : functor.obj (functor.const J) X ⟶ F

protected instance inhabited_cone {C : Type u} [category C] (F : discrete PUnit ⥤ C) : Inhabited (cone F) :=
  { default := cone.mk (functor.obj F PUnit.unit) (nat_trans.mk fun (X : discrete PUnit) => sorry) }

@[simp] theorem cone.w {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone F) {j : J} {j' : J} (f : j ⟶ j') : nat_trans.app (cone.π c) j ≫ functor.map F f = nat_trans.app (cone.π c) j' := sorry

/--
A `c : cocone F` is
* an object `c.X` and
* a natural transformation `c.ι : F ⟶ c.X` from `F` to the constant `c.X` functor.

`cocone F` is equivalent, via `cone.equiv` below, to `Σ X, F.cocones.obj X`.
-/
structure cocone {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C)
where
  X : C
  ι : F ⟶ functor.obj (functor.const J) X

protected instance inhabited_cocone {C : Type u} [category C] (F : discrete PUnit ⥤ C) : Inhabited (cocone F) :=
  { default := cocone.mk (functor.obj F PUnit.unit) (nat_trans.mk fun (X : discrete PUnit) => sorry) }

@[simp] theorem cocone.w_assoc {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone F) {j : J} {j' : J} (f : j ⟶ j') {X' : C} (f' : functor.obj (functor.obj (functor.const J) (cocone.X c)) j' ⟶ X') : functor.map F f ≫ nat_trans.app (cocone.ι c) j' ≫ f' = nat_trans.app (cocone.ι c) j ≫ f' := sorry

namespace cone

/-- The isomorphism between a cone on `F` and an element of the functor `F.cones`. -/
def equiv {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) : cone F ≅ sigma fun (X : Cᵒᵖ) => functor.obj (functor.cones F) X :=
  iso.mk (fun (c : cone F) => sigma.mk (opposite.op (X c)) (π c))
    fun (c : sigma fun (X : Cᵒᵖ) => functor.obj (functor.cones F) X) => mk (opposite.unop (sigma.fst c)) (sigma.snd c)

/-- A map to the vertex of a cone naturally induces a cone by composition. -/
@[simp] def extensions {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone F) : functor.obj yoneda (X c) ⟶ functor.cones F :=
  nat_trans.mk fun (X : Cᵒᵖ) (f : functor.obj (functor.obj yoneda (X c)) X) => functor.map (functor.const J) f ≫ π c

/-- A map to the vertex of a cone induces a cone by composition. -/
@[simp] def extend {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone F) {X : C} (f : X ⟶ X c) : cone F :=
  mk X (nat_trans.app (extensions c) (opposite.op X) f)

@[simp] theorem extend_π {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone F) {X : Cᵒᵖ} (f : opposite.unop X ⟶ X c) : π (extend c f) = nat_trans.app (extensions c) X f :=
  rfl

/-- Whisker a cone by precomposition of a functor. -/
def whisker {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (E : K ⥤ J) (c : cone F) : cone (E ⋙ F) :=
  mk (X c) (whisker_left E (π c))

end cone

namespace cocone

/-- The isomorphism between a cocone on `F` and an element of the functor `F.cocones`. -/
def equiv {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) : cocone F ≅ sigma fun (X : C) => functor.obj (functor.cocones F) X :=
  iso.mk (fun (c : cocone F) => sigma.mk (X c) (ι c))
    fun (c : sigma fun (X : C) => functor.obj (functor.cocones F) X) => mk (sigma.fst c) (sigma.snd c)

/-- A map from the vertex of a cocone naturally induces a cocone by composition. -/
@[simp] def extensions {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone F) : functor.obj coyoneda (opposite.op (X c)) ⟶ functor.cocones F :=
  nat_trans.mk
    fun (X : C) (f : functor.obj (functor.obj coyoneda (opposite.op (X c))) X) => ι c ≫ functor.map (functor.const J) f

/-- A map from the vertex of a cocone induces a cocone by composition. -/
@[simp] def extend {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone F) {X : C} (f : X c ⟶ X) : cocone F :=
  mk X (nat_trans.app (extensions c) X f)

@[simp] theorem extend_ι {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone F) {X : C} (f : X c ⟶ X) : ι (extend c f) = nat_trans.app (extensions c) X f :=
  rfl

/--
Whisker a cocone by precomposition of a functor. See `whiskering` for a functorial
version.
-/
@[simp] theorem whisker_ι {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (E : K ⥤ J) (c : cocone F) : ι (whisker E c) = whisker_left E (ι c) :=
  Eq.refl (ι (whisker E c))

end cocone

/-- A cone morphism between two cones for the same diagram is a morphism of the cone points which
commutes with the cone legs. -/
structure cone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (A : cone F) (B : cone F)
where
  hom : cone.X A ⟶ cone.X B
  w' : autoParam (∀ (j : J), hom ≫ nat_trans.app (cone.π B) j = nat_trans.app (cone.π A) j)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem cone_morphism.w {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {A : cone F} {B : cone F} (c : cone_morphism A B) (j : J) : cone_morphism.hom c ≫ nat_trans.app (cone.π B) j = nat_trans.app (cone.π A) j := sorry

@[simp] theorem cone_morphism.w_assoc {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {A : cone F} {B : cone F} (c : cone_morphism A B) (j : J) {X' : C} (f' : functor.obj F j ⟶ X') : cone_morphism.hom c ≫ nat_trans.app (cone.π B) j ≫ f' = nat_trans.app (cone.π A) j ≫ f' := sorry

protected instance inhabited_cone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (A : cone F) : Inhabited (cone_morphism A A) :=
  { default := cone_morphism.mk 𝟙 }

/-- The category of cones on a given diagram. -/
protected instance cone.category {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} : category (cone F) :=
  category.mk

namespace cones

/-- To give an isomorphism between cones, it suffices to give an
  isomorphism between their vertices which commutes with the cone
  maps. -/
def ext {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {c : cone F} {c' : cone F} (φ : cone.X c ≅ cone.X c') (w : ∀ (j : J), nat_trans.app (cone.π c) j = iso.hom φ ≫ nat_trans.app (cone.π c') j) : c ≅ c' :=
  iso.mk (cone_morphism.mk (iso.hom φ)) (cone_morphism.mk (iso.inv φ))

/--
Given a cone morphism whose object part is an isomorphism, produce an
isomorphism of cones.
-/
def cone_iso_of_hom_iso {J : Type v} [small_category J] {C : Type u} [category C] {K : J ⥤ C} {c : cone K} {d : cone K} (f : c ⟶ d) [i : is_iso (cone_morphism.hom f)] : is_iso f :=
  is_iso.mk (cone_morphism.mk (inv (cone_morphism.hom f)))

/--
Functorially postcompose a cone for `F` by a natural transformation `F ⟶ G` to give a cone for `G`.
-/
@[simp] theorem postcompose_map_hom {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} (α : F ⟶ G) (c₁ : cone F) (c₂ : cone F) (f : c₁ ⟶ c₂) : cone_morphism.hom (functor.map (postcompose α) f) = cone_morphism.hom f :=
  Eq.refl (cone_morphism.hom (functor.map (postcompose α) f))

/-- Postcomposing a cone by the composite natural transformation `α ≫ β` is the same as
postcomposing by `α` and then by `β`. -/
def postcompose_comp {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} {H : J ⥤ C} (α : F ⟶ G) (β : G ⟶ H) : postcompose (α ≫ β) ≅ postcompose α ⋙ postcompose β :=
  nat_iso.of_components (fun (s : cone F) => ext (iso.refl (cone.X (functor.obj (postcompose (α ≫ β)) s))) sorry) sorry

/-- Postcomposing by the identity does not change the cone up to isomorphism. -/
def postcompose_id {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} : postcompose 𝟙 ≅ 𝟭 :=
  nat_iso.of_components (fun (s : cone F) => ext (iso.refl (cone.X (functor.obj (postcompose 𝟙) s))) sorry) sorry

/--
If `F` and `G` are naturally isomorphic functors, then they have equivalent categories of
cones.
-/
@[simp] theorem postcompose_equivalence_unit_iso {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} (α : F ≅ G) : equivalence.unit_iso (postcompose_equivalence α) =
  nat_iso.of_components
    (fun (s : cone F) => ext (iso.refl (cone.X (functor.obj 𝟭 s))) (postcompose_equivalence._proof_1 α s))
    (postcompose_equivalence._proof_2 α) :=
  Eq.refl (equivalence.unit_iso (postcompose_equivalence α))

/--
Whiskering on the left by `E : K ⥤ J` gives a functor from `cone F` to `cone (E ⋙ F)`.
-/
@[simp] theorem whiskering_obj {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (E : K ⥤ J) (c : cone F) : functor.obj (whiskering E) c = cone.whisker E c :=
  Eq.refl (functor.obj (whiskering E) c)

/--
Whiskering by an equivalence gives an equivalence between categories of cones.
-/
@[simp] theorem whiskering_equivalence_inverse {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (e : K ≌ J) : equivalence.inverse (whiskering_equivalence e) =
  whiskering (equivalence.inverse e) ⋙
    postcompose
      (iso.inv (functor.associator (equivalence.inverse e) (equivalence.functor e) F) ≫
        whisker_right (iso.hom (equivalence.counit_iso e)) F ≫ iso.hom (functor.left_unitor F)) :=
  Eq.refl (equivalence.inverse (whiskering_equivalence e))

/--
The categories of cones over `F` and `G` are equivalent if `F` and `G` are naturally isomorphic
(possibly after changing the indexing category by an equivalence).
-/
def equivalence_of_reindexing {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] {G : K ⥤ C} (e : K ≌ J) (α : equivalence.functor e ⋙ F ≅ G) : cone F ≌ cone G :=
  equivalence.trans (whiskering_equivalence e) (postcompose_equivalence α)

/-- Forget the cone structure and obtain just the cone point. -/
def forget {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) : cone F ⥤ C :=
  functor.mk (fun (t : cone F) => cone.X t) fun (s t : cone F) (f : s ⟶ t) => cone_morphism.hom f

/-- A functor `G : C ⥤ D` sends cones over `F` to cones over `F ⋙ G` functorially. -/
@[simp] theorem functoriality_obj_π_app {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) (A : cone F) (j : J) : nat_trans.app (cone.π (functor.obj (functoriality F G) A)) j = functor.map G (nat_trans.app (cone.π A) j) :=
  Eq.refl (nat_trans.app (cone.π (functor.obj (functoriality F G) A)) j)

protected instance functoriality_full {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) [full G] [faithful G] : full (functoriality F G) :=
  full.mk
    fun (X Y : cone F) (t : functor.obj (functoriality F G) X ⟶ functor.obj (functoriality F G) Y) =>
      cone_morphism.mk (functor.preimage G (cone_morphism.hom t))

protected instance functoriality_faithful {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) [faithful G] : faithful (functoriality F G) :=
  faithful.mk

/--
If `e : C ≌ D` is an equivalence of categories, then `functoriality F e.functor` induces an
equivalence between cones over `F` and cones over `F ⋙ e.functor`.
-/
@[simp] theorem functoriality_equivalence_counit_iso {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (e : C ≌ D) : equivalence.counit_iso (functoriality_equivalence F e) =
  nat_iso.of_components
    (fun (c : cone (F ⋙ equivalence.functor e)) =>
      ext (iso.app (equivalence.counit_iso e) (cone.X c)) (functoriality_equivalence._proof_3 F e c))
    (functoriality_equivalence._proof_4 F e) :=
  Eq.refl (equivalence.counit_iso (functoriality_equivalence F e))

/--
If `F` reflects isomorphisms, then `cones.functoriality F` reflects isomorphisms
as well.
-/
protected instance reflects_cone_isomorphism {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] (F : C ⥤ D) [reflects_isomorphisms F] (K : J ⥤ C) : reflects_isomorphisms (functoriality K F) :=
  reflects_isomorphisms.mk
    fun (A B : cone K) (f : A ⟶ B) (_inst_3_1 : is_iso (functor.map (functoriality K F) f)) => cone_iso_of_hom_iso f

end cones

/-- A cocone morphism between two cocones for the same diagram is a morphism of the cocone points
which commutes with the cocone legs. -/
structure cocone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (A : cocone F) (B : cocone F)
where
  hom : cocone.X A ⟶ cocone.X B
  w' : autoParam (∀ (j : J), nat_trans.app (cocone.ι A) j ≫ hom = nat_trans.app (cocone.ι B) j)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

protected instance inhabited_cocone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (A : cocone F) : Inhabited (cocone_morphism A A) :=
  { default := cocone_morphism.mk 𝟙 }

@[simp] theorem cocone_morphism.w {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {A : cocone F} {B : cocone F} (c : cocone_morphism A B) (j : J) : nat_trans.app (cocone.ι A) j ≫ cocone_morphism.hom c = nat_trans.app (cocone.ι B) j := sorry

@[simp] theorem cocone_morphism.w_assoc {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {A : cocone F} {B : cocone F} (c : cocone_morphism A B) (j : J) {X' : C} (f' : cocone.X B ⟶ X') : nat_trans.app (cocone.ι A) j ≫ cocone_morphism.hom c ≫ f' = nat_trans.app (cocone.ι B) j ≫ f' := sorry

@[simp] theorem cocone.category_to_category_struct_id_hom {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (B : cocone F) : cocone_morphism.hom 𝟙 = 𝟙 :=
  Eq.refl (cocone_morphism.hom 𝟙)

namespace cocones

/-- To give an isomorphism between cocones, it suffices to give an
  isomorphism between their vertices which commutes with the cocone
  maps. -/
@[simp] theorem ext_inv_hom {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {c : cocone F} {c' : cocone F} (φ : cocone.X c ≅ cocone.X c') (w : ∀ (j : J), nat_trans.app (cocone.ι c) j ≫ iso.hom φ = nat_trans.app (cocone.ι c') j) : cocone_morphism.hom (iso.inv (ext φ w)) = iso.inv φ :=
  Eq.refl (cocone_morphism.hom (iso.inv (ext φ w)))

/--
Given a cocone morphism whose object part is an isomorphism, produce an
isomorphism of cocones.
-/
def cocone_iso_of_hom_iso {J : Type v} [small_category J] {C : Type u} [category C] {K : J ⥤ C} {c : cocone K} {d : cocone K} (f : c ⟶ d) [i : is_iso (cocone_morphism.hom f)] : is_iso f :=
  is_iso.mk (cocone_morphism.mk (inv (cocone_morphism.hom f)))

/--
Functorially precompose a cocone for `F` by a natural transformation `G ⟶ F` to give a cocone for `G`.
-/
def precompose {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} (α : G ⟶ F) : cocone F ⥤ cocone G :=
  functor.mk (fun (c : cocone F) => cocone.mk (cocone.X c) (α ≫ cocone.ι c))
    fun (c₁ c₂ : cocone F) (f : c₁ ⟶ c₂) => cocone_morphism.mk (cocone_morphism.hom f)

/-- Precomposing a cocone by the composite natural transformation `α ≫ β` is the same as
precomposing by `β` and then by `α`. -/
def precompose_comp {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} {H : J ⥤ C} (α : F ⟶ G) (β : G ⟶ H) : precompose (α ≫ β) ≅ precompose β ⋙ precompose α :=
  nat_iso.of_components (fun (s : cocone H) => ext (iso.refl (cocone.X (functor.obj (precompose (α ≫ β)) s))) sorry) sorry

/-- Precomposing by the identity does not change the cocone up to isomorphism. -/
def precompose_id {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} : precompose 𝟙 ≅ 𝟭 :=
  nat_iso.of_components (fun (s : cocone F) => ext (iso.refl (cocone.X (functor.obj (precompose 𝟙) s))) sorry) sorry

/--
If `F` and `G` are naturally isomorphic functors, then they have equivalent categories of
cocones.
-/
@[simp] theorem precompose_equivalence_functor {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {G : J ⥤ C} (α : G ≅ F) : equivalence.functor (precompose_equivalence α) = precompose (iso.hom α) :=
  Eq.refl (equivalence.functor (precompose_equivalence α))

/--
Whiskering on the left by `E : K ⥤ J` gives a functor from `cocone F` to `cocone (E ⋙ F)`.
-/
def whiskering {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (E : K ⥤ J) : cocone F ⥤ cocone (E ⋙ F) :=
  functor.mk (fun (c : cocone F) => cocone.whisker E c)
    fun (c c' : cocone F) (f : c ⟶ c') => cocone_morphism.mk (cocone_morphism.hom f)

/--
Whiskering by an equivalence gives an equivalence between categories of cones.
-/
def whiskering_equivalence {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] (e : K ≌ J) : cocone F ≌ cocone (equivalence.functor e ⋙ F) :=
  equivalence.mk' (whiskering (equivalence.functor e))
    (whiskering (equivalence.inverse e) ⋙
      precompose
        (iso.inv (functor.left_unitor F) ≫
          whisker_right (iso.inv (equivalence.counit_iso e)) F ≫
            iso.inv (functor.associator (equivalence.inverse e) (equivalence.functor e) F)))
    (nat_iso.of_components (fun (s : cocone F) => ext (iso.refl (cocone.X (functor.obj 𝟭 s))) sorry) sorry)
    (nat_iso.of_components
      (fun (s : cocone (equivalence.functor e ⋙ F)) =>
        ext
          (iso.refl
            (cocone.X
              (functor.obj
                ((whiskering (equivalence.inverse e) ⋙
                    precompose
                      (iso.inv (functor.left_unitor F) ≫
                        whisker_right (iso.inv (equivalence.counit_iso e)) F ≫
                          iso.inv (functor.associator (equivalence.inverse e) (equivalence.functor e) F))) ⋙
                  whiskering (equivalence.functor e))
                s)))
          sorry)
      sorry)

/--
The categories of cocones over `F` and `G` are equivalent if `F` and `G` are naturally isomorphic
(possibly after changing the indexing category by an equivalence).
-/
@[simp] theorem equivalence_of_reindexing_functor_obj {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {K : Type v} [small_category K] {G : K ⥤ C} (e : K ≌ J) (α : equivalence.functor e ⋙ F ≅ G) (X : cocone F) : functor.obj (equivalence.functor (equivalence_of_reindexing e α)) X =
  functor.obj (precompose (iso.inv α)) (cocone.whisker (equivalence.functor e) X) :=
  Eq.refl (functor.obj (precompose (iso.inv α)) (cocone.whisker (equivalence.functor e) X))

/-- Forget the cocone structure and obtain just the cocone point. -/
@[simp] theorem forget_map {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) (s : cocone F) (t : cocone F) (f : s ⟶ t) : functor.map (forget F) f = cocone_morphism.hom f :=
  Eq.refl (functor.map (forget F) f)

/-- A functor `G : C ⥤ D` sends cocones over `F` to cocones over `F ⋙ G` functorially. -/
@[simp] theorem functoriality_map_hom {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) (_x : cocone F) : ∀ (_x_1 : cocone F) (f : _x ⟶ _x_1),
  cocone_morphism.hom (functor.map (functoriality F G) f) = functor.map G (cocone_morphism.hom f) :=
  fun (_x_1 : cocone F) (f : _x ⟶ _x_1) => Eq.refl (cocone_morphism.hom (functor.map (functoriality F G) f))

protected instance functoriality_full {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) [full G] [faithful G] : full (functoriality F G) :=
  full.mk
    fun (X Y : cocone F) (t : functor.obj (functoriality F G) X ⟶ functor.obj (functoriality F G) Y) =>
      cocone_morphism.mk (functor.preimage G (cocone_morphism.hom t))

protected instance functoriality_faithful {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (G : C ⥤ D) [faithful G] : faithful (functoriality F G) :=
  faithful.mk

/--
If `e : C ≌ D` is an equivalence of categories, then `functoriality F e.functor` induces an
equivalence between cocones over `F` and cocones over `F ⋙ e.functor`.
-/
@[simp] theorem functoriality_equivalence_functor {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) {D : Type u'} [category D] (e : C ≌ D) : equivalence.functor (functoriality_equivalence F e) = functoriality F (equivalence.functor e) :=
  Eq.refl (equivalence.functor (functoriality_equivalence F e))

/--
If `F` reflects isomorphisms, then `cocones.functoriality F` reflects isomorphisms
as well.
-/
protected instance reflects_cocone_isomorphism {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] (F : C ⥤ D) [reflects_isomorphisms F] (K : J ⥤ C) : reflects_isomorphisms (functoriality K F) :=
  reflects_isomorphisms.mk
    fun (A B : cocone K) (f : A ⟶ B) (_inst_3_1 : is_iso (functor.map (functoriality K F) f)) => cocone_iso_of_hom_iso f

end cocones

end limits

namespace functor

/-- The image of a cone in C under a functor G : C ⥤ D is a cone in D. -/
/-- The image of a cocone in C under a functor G : C ⥤ D is a cocone in D. -/
@[simp] theorem map_cone_X {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) (c : limits.cone F) : limits.cone.X (map_cone H c) = obj H (limits.cone.X c) :=
  Eq.refl (obj H (limits.cone.X c))

@[simp] theorem map_cocone_ι_app {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) (c : limits.cocone F) (j : J) : nat_trans.app (limits.cocone.ι (map_cocone H c)) j = map H (nat_trans.app (limits.cocone.ι c) j) :=
  Eq.refl (map H (nat_trans.app (limits.cocone.ι c) j))

/-- Given a cone morphism `c ⟶ c'`, construct a cone morphism on the mapped cones functorially.  -/
def map_cone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) {c : limits.cone F} {c' : limits.cone F} (f : c ⟶ c') : map_cone H c ⟶ map_cone H c' :=
  map (limits.cones.functoriality F H) f

/-- Given a cocone morphism `c ⟶ c'`, construct a cocone morphism on the mapped cocones functorially.  -/
def map_cocone_morphism {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) {c : limits.cocone F} {c' : limits.cocone F} (f : c ⟶ c') : map_cocone H c ⟶ map_cocone H c' :=
  map (limits.cocones.functoriality F H) f

/-- If `H` is an equivalence, we invert `H.map_cone` and get a cone for `F` from a cone
for `F ⋙ H`.-/
def map_cone_inv {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) [is_equivalence H] (c : limits.cone (F ⋙ H)) : limits.cone F :=
  obj (equivalence.inverse (limits.cones.functoriality_equivalence F (as_equivalence H))) c

/-- `map_cone` is the left inverse to `map_cone_inv`. -/
def map_cone_map_cone_inv {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : limits.cone (F ⋙ H)) : map_cone H (map_cone_inv H c) ≅ c :=
  iso.app (equivalence.counit_iso (limits.cones.functoriality_equivalence F (as_equivalence H))) c

/-- `map_cone` is the right inverse to `map_cone_inv`. -/
def map_cone_inv_map_cone {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : limits.cone F) : map_cone_inv H (map_cone H c) ≅ c :=
  iso.app (iso.symm (equivalence.unit_iso (limits.cones.functoriality_equivalence F (as_equivalence H)))) c

/-- If `H` is an equivalence, we invert `H.map_cone` and get a cone for `F` from a cone
for `F ⋙ H`.-/
def map_cocone_inv {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) [is_equivalence H] (c : limits.cocone (F ⋙ H)) : limits.cocone F :=
  obj (equivalence.inverse (limits.cocones.functoriality_equivalence F (as_equivalence H))) c

/-- `map_cocone` is the left inverse to `map_cocone_inv`. -/
def map_cocone_map_cocone_inv {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : limits.cocone (F ⋙ H)) : map_cocone H (map_cocone_inv H c) ≅ c :=
  iso.app (equivalence.counit_iso (limits.cocones.functoriality_equivalence F (as_equivalence H))) c

/-- `map_cocone` is the right inverse to `map_cocone_inv`. -/
def map_cocone_inv_map_cocone {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ D} (H : D ⥤ C) [is_equivalence H] (c : limits.cocone F) : map_cocone_inv H (map_cocone H c) ≅ c :=
  iso.app (iso.symm (equivalence.unit_iso (limits.cocones.functoriality_equivalence F (as_equivalence H)))) c

/-- `functoriality F _ ⋙ postcompose (whisker_left F _)` simplifies to `functoriality F _`. -/
@[simp] theorem functoriality_comp_postcompose_inv_app_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {H : C ⥤ D} {H' : C ⥤ D} (α : H ≅ H') (X : limits.cone F) : limits.cone_morphism.hom (nat_trans.app (iso.inv (functoriality_comp_postcompose α)) X) =
  nat_trans.app (iso.inv α) (limits.cone.X X) :=
  Eq.refl (nat_trans.app (iso.inv α) (limits.cone.X X))

/--
For `F : J ⥤ C`, given a cone `c : cone F`, and a natural isomorphism `α : H ≅ H'` for functors
`H H' : C ⥤ D`, the postcomposition of the cone `H.map_cone` using the isomorphism `α` is
isomorphic to the cone `H'.map_cone`.
-/
def postcompose_whisker_left_map_cone {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {H : C ⥤ D} {H' : C ⥤ D} (α : H ≅ H') (c : limits.cone F) : obj (limits.cones.postcompose (whisker_left F (iso.hom α))) (map_cone H c) ≅ map_cone H' c :=
  iso.app (functoriality_comp_postcompose α) c

/--
`map_cone` commutes with `postcompose`. In particular, for `F : J ⥤ C`, given a cone `c : cone F`, a
natural transformation `α : F ⟶ G` and a functor `H : C ⥤ D`, we have two obvious ways of producing
a cone over `G ⋙ H`, and they are both isomorphic.
-/
@[simp] theorem map_cone_postcompose_inv_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {G : J ⥤ C} (H : C ⥤ D) {α : F ⟶ G} {c : limits.cone F} : limits.cone_morphism.hom (iso.inv (map_cone_postcompose H)) = 𝟙 :=
  Eq.refl 𝟙

/--
`map_cone` commutes with `postcompose_equivalence`
-/
@[simp] theorem map_cone_postcompose_equivalence_functor_hom_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {G : J ⥤ C} (H : C ⥤ D) {α : F ≅ G} {c : limits.cone F} : limits.cone_morphism.hom (iso.hom (map_cone_postcompose_equivalence_functor H)) = 𝟙 :=
  Eq.refl 𝟙

/-- `functoriality F _ ⋙ precompose (whisker_left F _)` simplifies to `functoriality F _`. -/
@[simp] theorem functoriality_comp_precompose_inv_app_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {H : C ⥤ D} {H' : C ⥤ D} (α : H ≅ H') (X : limits.cocone F) : limits.cocone_morphism.hom (nat_trans.app (iso.inv (functoriality_comp_precompose α)) X) =
  nat_trans.app (iso.inv α) (limits.cocone.X X) :=
  Eq.refl (nat_trans.app (iso.inv α) (limits.cocone.X X))

/--
For `F : J ⥤ C`, given a cocone `c : cocone F`, and a natural isomorphism `α : H ≅ H'` for functors
`H H' : C ⥤ D`, the precomposition of the cocone `H.map_cocone` using the isomorphism `α` is
isomorphic to the cocone `H'.map_cocone`.
-/
def precompose_whisker_left_map_cocone {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {H : C ⥤ D} {H' : C ⥤ D} (α : H ≅ H') (c : limits.cocone F) : obj (limits.cocones.precompose (whisker_left F (iso.inv α))) (map_cocone H c) ≅ map_cocone H' c :=
  iso.app (functoriality_comp_precompose α) c

/--
`map_cocone` commutes with `precompose`. In particular, for `F : J ⥤ C`, given a cocone
`c : cocone F`, a natural transformation `α : F ⟶ G` and a functor `H : C ⥤ D`, we have two obvious
ways of producing a cocone over `G ⋙ H`, and they are both isomorphic.
-/
@[simp] theorem map_cocone_precompose_hom_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {G : J ⥤ C} (H : C ⥤ D) {α : F ⟶ G} {c : limits.cocone G} : limits.cocone_morphism.hom (iso.hom (map_cocone_precompose H)) = 𝟙 :=
  Eq.refl 𝟙

/--
`map_cocone` commutes with `precompose_equivalence`
-/
@[simp] theorem map_cocone_precompose_equivalence_functor_inv_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} {G : J ⥤ C} (H : C ⥤ D) {α : F ≅ G} {c : limits.cocone G} : limits.cocone_morphism.hom (iso.inv (map_cocone_precompose_equivalence_functor H)) = 𝟙 :=
  Eq.refl 𝟙

/--
`map_cone` commutes with `whisker`
-/
@[simp] theorem map_cone_whisker_inv_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) {K : Type v} [small_category K] {E : K ⥤ J} {c : limits.cone F} : limits.cone_morphism.hom (iso.inv (map_cone_whisker H)) = 𝟙 :=
  Eq.refl 𝟙

/--
`map_cocone` commutes with `whisker`
-/
@[simp] theorem map_cocone_whisker_inv_hom {J : Type v} [small_category J] {C : Type u} [category C] {D : Type u'} [category D] {F : J ⥤ C} (H : C ⥤ D) {K : Type v} [small_category K] {E : K ⥤ J} {c : limits.cocone F} : limits.cocone_morphism.hom (iso.inv (map_cocone_whisker H)) = 𝟙 :=
  Eq.refl 𝟙

end functor

end category_theory

namespace category_theory.limits

/-- Change a `cocone F` into a `cone F.op`. -/
@[simp] theorem cocone.op_X {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone F) : cone.X (cocone.op c) = opposite.op (cocone.X c) :=
  Eq.refl (cone.X (cocone.op c))

/-- Change a `cone F` into a `cocone F.op`. -/
def cone.op {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone F) : cocone (functor.op F) :=
  cocone.mk (opposite.op (cone.X c))
    (nat_trans.mk fun (j : Jᵒᵖ) => has_hom.hom.op (nat_trans.app (cone.π c) (opposite.unop j)))

/-- Change a `cocone F.op` into a `cone F`. -/
def cocone.unop {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cocone (functor.op F)) : cone F :=
  cone.mk (opposite.unop (cocone.X c))
    (nat_trans.mk fun (j : J) => has_hom.hom.unop (nat_trans.app (cocone.ι c) (opposite.op j)))

/-- Change a `cone F.op` into a `cocone F`. -/
@[simp] theorem cone.unop_X {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} (c : cone (functor.op F)) : cocone.X (cone.unop c) = opposite.unop (cone.X c) :=
  Eq.refl (cocone.X (cone.unop c))

/--
The category of cocones on `F`
is equivalent to the opposite category of
the category of cones on the opposite of `F`.
-/
@[simp] theorem cocone_equivalence_op_cone_op_unit_iso {J : Type v} [small_category J] {C : Type u} [category C] (F : J ⥤ C) : equivalence.unit_iso (cocone_equivalence_op_cone_op F) =
  nat_iso.of_components
    (fun (c : cocone F) =>
      cocones.ext (iso.refl (cocone.X (functor.obj 𝟭 c))) (cocone_equivalence_op_cone_op._proof_7 F c))
    (cocone_equivalence_op_cone_op._proof_8 F) :=
  Eq.refl (equivalence.unit_iso (cocone_equivalence_op_cone_op F))

/-- Change a cocone on `F.left_op : Jᵒᵖ ⥤ C` to a cocone on `F : J ⥤ Cᵒᵖ`. -/
-- Here and below we only automatically generate the `@[simp]` lemma for the `X` field,

-- as we can write a simpler `rfl` lemma for the components of the natural transformation by hand.

def cone_of_cocone_left_op {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ (Cᵒᵖ)} (c : cocone (functor.left_op F)) : cone F :=
  cone.mk (opposite.op (cocone.X c))
    (nat_trans.remove_left_op (cocone.ι c ≫ iso.hom (functor.const.op_obj_unop (opposite.op (cocone.X c)))))

/-- Change a cone on `F : J ⥤ Cᵒᵖ` to a cocone on `F.left_op : Jᵒᵖ ⥤ C`. -/
def cocone_left_op_of_cone {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ (Cᵒᵖ)} (c : cone F) : cocone (functor.left_op F) :=
  cocone.mk (opposite.unop (cone.X c)) (nat_trans.left_op (cone.π c))

/-- Change a cone on `F.left_op : Jᵒᵖ ⥤ C` to a cocone on `F : J ⥤ Cᵒᵖ`. -/
/- When trying use `@[simps]` to generate the `ι_app` field of this definition, `@[simps]` tries to
  reduce the RHS using `expr.dsimp` and `expr.simp`, but for some reason the expression is not
  being simplified properly. -/

def cocone_of_cone_left_op {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ (Cᵒᵖ)} (c : cone (functor.left_op F)) : cocone F :=
  cocone.mk (opposite.op (cone.X c))
    (nat_trans.remove_left_op (iso.hom (functor.const.op_obj_unop (opposite.op (cone.X c))) ≫ cone.π c))

@[simp] theorem cocone_of_cone_left_op_ι_app {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ (Cᵒᵖ)} (c : cone (functor.left_op F)) (j : J) : nat_trans.app (cocone.ι (cocone_of_cone_left_op c)) j = has_hom.hom.op (nat_trans.app (cone.π c) (opposite.op j)) := sorry

/-- Change a cocone on `F : J ⥤ Cᵒᵖ` to a cone on `F.left_op : Jᵒᵖ ⥤ C`. -/
def cone_left_op_of_cocone {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ (Cᵒᵖ)} (c : cocone F) : cone (functor.left_op F) :=
  cone.mk (opposite.unop (cocone.X c)) (nat_trans.left_op (cocone.ι c))

end category_theory.limits

namespace category_theory.functor

/-- The opposite cocone of the image of a cone is the image of the opposite cocone. -/
def map_cone_op {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {D : Type u'} [category D] (G : C ⥤ D) (t : limits.cone F) : limits.cone.op (map_cone G t) ≅ map_cocone (functor.op G) (limits.cone.op t) :=
  limits.cocones.ext (iso.refl (limits.cocone.X (limits.cone.op (map_cone G t)))) sorry

/-- The opposite cone of the image of a cocone is the image of the opposite cone. -/
def map_cocone_op {J : Type v} [small_category J] {C : Type u} [category C] {F : J ⥤ C} {D : Type u'} [category D] (G : C ⥤ D) {t : limits.cocone F} : limits.cocone.op (map_cocone G t) ≅ map_cone (functor.op G) (limits.cocone.op t) :=
  limits.cones.ext (iso.refl (limits.cone.X (limits.cocone.op (map_cocone G t)))) sorry


constants p q : Prop

theorem t1 (hp : p) (hq : q) : p := hp

axiom hp : p

theorem t2 : q → p := t1 hp


import .basic

open parser_tactic

universe u

structure Language : Type (u+1) :=
(functions : ℕ → Type u) (relations : ℕ → Type u)

def Language.constants (L : Language) := L.functions 0

variable (L : Language.{u})

inductive preterm : ℕ → Type u
| var {} : ∀ (k : ℕ), preterm 0
| func : ∀ {l : ℕ} (f : L.functions l), preterm l
| app : ∀ {l : ℕ} (t : preterm (l + 1)) (s : preterm 0), preterm l
export preterm

@[reducible] def term := preterm L 0

variable {L}
prefix `&`:max := preterm.var

-- @[simp] def apps : ∀{l}, preterm L l → dvector (term L) l → term L
-- | _ t []       := t
-- | _ t (t'::ts) := apps (app t t') ts

-- -- @[simp] def apps' : ∀{l l'}, preterm L (l'+l) → dvector (term L) l → preterm L l'
-- -- | _ _ t []       := t
-- -- | _ _ t (t'::ts) := apps' (app t t') ts

-- -- @[simp] def rev_apps : ∀{l l'}, preterm L (l+l) → dvector (term L) l' → preterm L l
-- -- | _ _ t []       := sorry
-- -- | l _ t (@dvector.cons _ l' t' ts) := app (@rev_apps (l+1) l' t ts) t'

-- @[simp] lemma apps_zero (t : term L) (ts : dvector (term L) 0) : apps t ts = t :=
-- by cases ts; refl

-- lemma apps_eq_app {l} (t : preterm L (l+1)) (s : term L) (ts : dvector (term L) l) :
--   ∃t' s', apps t (s::ts) = app t' s' :=
-- begin
--   induction ts generalizing s, exact ⟨t, s, rfl⟩, exact ts_ih (app t s) ts_x
-- end

-- namespace preterm
-- @[simp] def change_arity' : ∀{l l'} (h : l = l') (t : preterm L l), preterm L l'
-- | _ _ h &k          := by induction h; exact &k
-- | _ _ h (func f)    := func (by induction h; exact f)
-- | _ _ h (app t₁ t₂) := app (change_arity' (congr_arg succ h) t₁) t₂

-- @[simp] lemma change_arity'_rfl : ∀{l} (t : preterm L l), change_arity' rfl t = t
-- | _ &k          := by refl
-- | _ (func f)    := by refl
-- | _ (app t₁ t₂) := by dsimp; simp*

-- end preterm

-- -- lemma apps'_concat {l l'} (t : preterm L (l'+(l+1))) (s : term L) (ts : dvector (term L) l) :
-- --   apps' t (ts.concat s) = app (apps' (t.change_arity' (by simp)) ts) s :=
-- -- begin
-- --   induction ts generalizing s,
-- --   { simp },
-- --   { apply ts_ih (app t ts_x) s }
-- -- end

-- lemma apps_ne_var {l} {f : L.functions l} {ts : dvector (term L) l} {k : ℕ} :
--   apps (func f) ts ≠ &k :=
-- begin
--   intro h, cases ts, injection h,
--   rcases apps_eq_app (func f) ts_x ts_xs with ⟨t, s, h'⟩, cases h.symm.trans h'
-- end

-- lemma apps_inj' {l} {t t' : preterm L l} {ts ts' : dvector (term L) l}
--   (h : apps t ts = apps t' ts') : t = t' ∧ ts = ts' :=
-- begin
--   induction ts; cases ts',
--   { exact ⟨h, rfl⟩ },
--   { rcases ts_ih h with ⟨⟨rfl, rfl⟩, rfl⟩, exact ⟨rfl, rfl⟩ }
-- end

-- -- lemma apps_inj_length {l l'} {f : L.functions l} {f' : L.functions l'}
-- --   {ts : dvector (term L) l} {ts' : dvector (term L) l'}
-- --   (h : apps (func f) ts = apps (func f') ts') : l = l' :=
-- -- begin
-- --   sorry
-- -- end

-- -- lemma apps'_inj_length {l₁ l₂ l'} {f : L.functions (l' + l₁)} {f' : L.functions (l' + l₂)}
-- --   {ts : dvector (term L) l₁} {ts' : dvector (term L) l₂}
-- --   (h : apps' (func f) ts = apps' (func f') ts') : l₁ = l₂ :=
-- -- begin
-- --   sorry
-- --   -- induction ts generalizing l'; cases ts',
-- --   -- { refl },
-- --   -- { rcases apps'_eq_app (func f') ts'_x ts'_xs with ⟨t, s, h'⟩, cases h.trans h' },
-- --   -- { rcases apps'_eq_app (func f) ts_x ts_xs with ⟨t, s, h'⟩, cases h.symm.trans h' },
-- --   -- { rcases apps'_eq_app (func f) ts_x ts_xs with ⟨t₁, s₁, h₁⟩,
-- --   --   rcases apps'_eq_app (func f') ts'_x ts'_xs with ⟨t₂, s₂, h₂⟩,
-- --   --    }
-- -- end

-- lemma apps_inj {l} {f f' : L.functions l} {ts ts' : dvector (term L) l}
--   (h : apps (func f) ts = apps (func f') ts') : f = f' ∧ ts = ts' :=
-- by rcases apps_inj' h with ⟨h', rfl⟩; cases h'; exact ⟨rfl, rfl⟩

-- def term_of_function {l} (f : L.functions l) : arity' (term L) (term L) l :=
-- arity'.of_dvector_map $ apps (func f)

-- @[elab_as_eliminator] def term.rec {C : term L → Sort v}
--   (hvar : ∀(k : ℕ), C &k)
--   (hfunc : Π {l} (f : L.functions l) (ts : dvector (term L) l) (ih_ts : ∀t, ts.pmem t → C t),
--     C (apps (func f) ts)) : ∀(t : term L), C t :=
-- have h : ∀{l} (t : preterm L l) (ts : dvector (term L) l) (ih_ts : ∀s, ts.pmem s → C s),
--   C (apps t ts),
-- begin
--   intros, induction t; try {rw ts.zero_eq},
--   { apply hvar },
--   { apply hfunc t_f ts ih_ts },
--   { apply t_ih_t (t_s::ts), intros t ht,
--     cases ht,
--     { induction ht, apply t_ih_s ([]), intros s hs, cases hs },
--     { exact ih_ts t ht }},
-- end,
-- λt, h t ([]) (by intros s hs; cases hs)

-- @[elab_as_eliminator] def term.elim' {C : Type v}
--   (hvar : ∀(k : ℕ), C)
--   (hfunc : Π {{l}} (f : L.functions l) (ts : dvector (term L) l) (ih_ts : dvector C l), C) :
--   ∀{l} (t : preterm L l) (ts : dvector (term L) l) (ih_ts : dvector C l), C
-- | _ &k ts ih_ts        := hvar k
-- | _ (func f) ts ih_ts  := hfunc f ts ih_ts
-- | _ (app t s) ts ih_ts := term.elim' t (s::ts) (term.elim' s ([]) ([])::ih_ts)

-- @[elab_as_eliminator] def term.elim {C : Type v}
--   (hvar : ∀(k : ℕ), C)
--   (hfunc : Π {{l}} (f : L.functions l) (ts : dvector (term L) l) (ih_ts : dvector C l), C) :
--   ∀(t : term L), C :=
-- λt, term.elim' hvar hfunc t ([]) ([])

-- lemma term.elim'_apps {C : Type v}
--   (hvar : ∀(k : ℕ), C)
--   (hfunc : Π {{l}} (f : L.functions l) (ts : dvector (term L) l) (ih_ts : dvector C l), C)
--   {l} (t : preterm L l) (ts : dvector (term L) l) :
--   @term.elim' L C hvar hfunc 0 (apps t ts) ([]) ([]) = @term.elim' L C hvar hfunc l t ts
--   (ts.map $ term.elim hvar hfunc) :=
-- begin
--   induction ts,
--   { refl },
--   { dsimp only [dvector.map, apps], rw [ts_ih], refl }
-- end

-- lemma term.elim_apps {C : Type v}
--   (hvar : ∀(k : ℕ), C)
--   (hfunc : Π {{l}} (f : L.functions l) (ts : dvector (term L) l) (ih_ts : dvector C l), C)
--   {l} (f : L.functions l) (ts : dvector (term L) l) :
--   @term.elim L C hvar hfunc (apps (func f) ts) = hfunc f ts (ts.map $ @term.elim L C hvar hfunc) :=
-- by dsimp only [term.elim]; rw term.elim'_apps; refl

-- /- lift_term_at _ t n m raises variables in t which are at least m by n -/
-- @[simp] def lift_term_at : ∀ {l}, preterm L l → ℕ → ℕ → preterm L l
-- | _ &k          n m := &(if m ≤ k then k+n else k)
-- | _ (func f)    n m := func f
-- | _ (app t₁ t₂) n m := app (lift_term_at t₁ n m) (lift_term_at t₂ n m)

-- notation t ` ↑' `:90 n ` # `:90 m:90 := fol.lift_term_at t n m -- input ↑ with \u or \upa

-- -- @[simp] lemma lift_term_var_le {k n m} (h : m ≤ k) : &k ↑' n # m = (&(k+n) : term L) := dif_pos h
-- -- @[simp] lemma lift_term_var_gt {k n m} (h : ¬(m ≤ k)) : &k ↑' n # m = (&k : term L) := dif_neg h
-- -- @[simp] lemma lift_term_at_func {l} (f : L.functions l) (n m) : func f ↑' n # m = func f := by refl
-- -- @[simp] lemma lift_term_at_app {l} (t : preterm L (l+1)) (s : preterm L 0) (n m) :
-- --   app t s ↑' n # m = app (t ↑' n # m) (s ↑' n # m) := by refl

-- @[reducible] def lift_term {l} (t : preterm L l) (n : ℕ) : preterm L l := t ↑' n # 0
-- infix ` ↑ `:100 := fol.lift_term -- input ↑' with \u or \upa
-- @[reducible, simp] def lift_term1 {l} (t : preterm L l) : preterm L l := t ↑ 1

-- @[simp] lemma lift_term_def {l} (t : preterm L l) (n : ℕ) : t ↑' n # 0 = t ↑ n := by refl

-- lemma injective_lift_term_at : ∀ {l} {n m : ℕ},
--   function.injective (λ(t : preterm L l), lift_term_at t n m)
-- | _ n m &k &k' h :=
--   by by_cases h₁ : m ≤ k; by_cases h₂ : m ≤ k'; simp [h₁, h₂] at h;
--      congr;[assumption, skip, skip, assumption]; exfalso; try {apply h₁};
--      try {apply h₂}; subst h; apply le_trans (by assumption) (le_add_left _ _)
-- | _ n m &k (func f')            h := by cases h
-- | _ n m &k (app t₁' t₂')        h := by cases h
-- | _ n m (func f) &k'            h := by cases h
-- | _ n m (func f) (func f')      h := h
-- | _ n m (func f) (app t₁' t₂')  h := by cases h
-- | _ n m (app t₁ t₂) &k'         h := by cases h
-- | _ n m (app t₁ t₂) (func f')   h := by cases h
-- | _ n m (app t₁ t₂) (app t₁' t₂') h :=
--   begin injection h, congr; apply injective_lift_term_at; assumption end

-- @[simp] lemma lift_term_at_zero : ∀ {l} (t : preterm L l) (m : ℕ), t ↑' 0 # m = t
-- | _ &k          m := by simp [lift_term_at]
-- | _ (func f)    m := by refl
-- | _ (app t₁ t₂) m := by dsimp; congr; apply lift_term_at_zero

-- @[simp] lemma lift_term_zero {l} (t : preterm L l) : t ↑ 0 = t := lift_term_at_zero t 0

-- /- the following lemmas simplify iterated lifts, depending on the size of m' -/
-- lemma lift_term_at2_small : ∀ {l} (t : preterm L l) (n n') {m m'}, m' ≤ m →
--   (t ↑' n # m) ↑' n' # m' = (t ↑' n' # m') ↑' n # (m + n')
-- | _ &k          n n' m m' H :=
--   begin
--     by_cases h : m ≤ k,
--     { have h₁ : m' ≤ k := le_trans H h,
--       have h₂ : m' ≤ k + n, from le_trans h₁ (k.le_add_right n),
--       simp [*, -add_assoc, -add_comm], simp },
--     { have h₁ : ¬m + n' ≤ k + n', from λ h', h (le_of_add_le_add_right h'),
--       have h₂ : ¬m + n' ≤ k, from λ h', h₁ (le_trans h' (k.le_add_right n')),
--       by_cases h' : m' ≤ k; simp [*, -add_comm, -add_assoc] }
--   end
-- | _ (func f)    n n' m m' H := by refl
-- | _ (app t₁ t₂) n n' m m' H :=
--   begin dsimp; congr1; apply lift_term_at2_small; assumption end

-- lemma lift_term_at2_medium : ∀ {l} (t : preterm L l) {n} (n') {m m'}, m ≤ m' → m' ≤ m+n →
--   (t ↑' n # m) ↑' n' # m' = t ↑' (n+n') # m
-- | _ &k          n n' m m' H₁ H₂ :=
--   begin
--     by_cases h : m ≤ k,
--     { have h₁ : m' ≤ k + n, from le_trans H₂ (add_le_add_right h n), simp [*, -add_comm], },
--     { have h₁ : ¬m' ≤ k, from λ h', h (le_trans H₁ h'), simp [*, -add_comm, -add_assoc] }
--   end
-- | _ (func f)    n n' m m' H₁ H₂ := by refl
-- | _ (app t₁ t₂) n n' m m' H₁ H₂ :=
--   begin dsimp; congr1; apply lift_term_at2_medium; assumption end

-- lemma lift_term2_medium {l} (t : preterm L l) {n} (n') {m'} (h : m' ≤ n) :
--   (t ↑ n) ↑' n' # m' = t ↑ (n+n') :=
-- lift_term_at2_medium t n' m'.zero_le (by simp*)

-- lemma lift_term2 {l} (t : preterm L l) (n n') : (t ↑ n) ↑ n' = t ↑ (n+n') :=
-- lift_term2_medium t n' n.zero_le

-- lemma lift_term_at2_eq {l} (t : preterm L l) (n n' m : ℕ) :
--   (t ↑' n # m) ↑' n' # (m+n) = t ↑' (n+n') # m :=
-- lift_term_at2_medium t n' (m.le_add_right n) (le_refl _)

-- lemma lift_term_at2_large {l} (t : preterm L l) {n} (n') {m m'} (H : m + n ≤ m') :
--   (t ↑' n # m) ↑' n' # m' = (t ↑' n' # (m'-n)) ↑' n # m :=
-- have H₁ : n ≤ m', from le_trans (n.le_add_left m) H,
-- have H₂ : m ≤ m' - n, from nat.le_sub_right_of_add_le H,
-- begin rw fol.lift_term_at2_small t n' n H₂, rw [nat.sub_add_cancel], exact H₁ end

-- @[simp] lemma lift_term_var0 (n : ℕ) : &0 ↑ n = (&n : term L) :=
-- by have h : 0 ≤ 0 := le_refl 0; rw [←lift_term_def]; simp [h, -lift_term_def]

-- @[simp] lemma lift_term_at_apps {l} (t : preterm L l) (ts : dvector (term L) l) (n m : ℕ) :
--   (apps t ts) ↑' n # m = apps (t ↑' n # m) (ts.map $ λx, x ↑' n # m) :=
-- by induction ts generalizing t;[refl, apply ts_ih (app t ts_x)]

-- @[simp] lemma lift_term_apps {l} (t : preterm L l) (ts : dvector (term L) l) (n : ℕ) :
--   (apps t ts) ↑ n = apps (t ↑ n) (ts.map $ λx, x ↑ n) :=
-- lift_term_at_apps t ts n 0

-- /- subst_term t s n substitutes s for (&n) and reduces the level of all variables above n by 1 -/
-- def subst_term : ∀ {l}, preterm L l → term L → ℕ → preterm L l
-- | _ &k          s n := subst_realize var (s ↑ n) n k
-- | _ (func f)    s n := func f
-- | _ (app t₁ t₂) s n := app (subst_term t₁ s n) (subst_term t₂ s n)

-- notation t `[`:max s ` // `:95 n `]`:0 := fol.subst_term t s n

-- @[simp] lemma subst_term_var_lt (s : term L) {k n : ℕ} (H : k < n) : &k[s // n] = &k :=
-- by simp only [H, fol.subst_term, fol.subst_realize_lt, eq_self_iff_true]

-- @[simp] lemma subst_term_var_gt (s : term L) {k n : ℕ} (H : n < k) : &k[s // n] = &(k-1) :=
-- by simp only [H, fol.subst_term, fol.subst_realize_gt, eq_self_iff_true]

-- @[simp] lemma subst_term_var_eq (s : term L) (n : ℕ) : &n[s // n] = s ↑' n # 0 :=
-- by simp [subst_term]

-- lemma subst_term_var0 (s : term L) : &0[s // 0] = s := by simp

-- @[simp] lemma subst_term_func {l} (f : L.functions l) (s : term L) (n : ℕ) :
--   (func f)[s // n] = func f :=
-- by refl

-- @[simp] lemma subst_term_app {l} (t₁ : preterm L (l+1)) (t₂ s : term L) (n : ℕ) :
--   (app t₁ t₂)[s // n] = app (t₁[s // n]) (t₂[s // n]) :=
-- by refl

-- @[simp] lemma subst_term_apps {l} (t : preterm L l) (ts : dvector (term L) l) (s : term L)
--   (n : ℕ) : (apps t ts)[s // n] = apps (t[s // n]) (ts.map $ λx, x[s // n]) :=
-- by induction ts generalizing t;[refl, apply ts_ih (app t ts_x)]

-- /- the following lemmas simplify first lifting and then substituting, depending on the size
--   of the substituted variable -/
-- lemma lift_at_subst_term_large : ∀{l} (t : preterm L l) (s : term L) {n₁} (n₂) {m}, m ≤ n₁ →
--  (t ↑' n₂ # m)[s // n₁+n₂] = (t [s // n₁]) ↑' n₂ # m
-- | _ &k          s n₁ n₂ m h :=
--   begin
--     apply decidable.lt_by_cases k n₁; intro h₂,
--     { have : k < n₁ + n₂, from lt_of_le_of_lt (k.le_add_right n₂) (by simp*),
--       by_cases m ≤ k; simp* },
--     { subst h₂, simp [*, lift_term2_medium] },
--     { have h₂ : m < k, by apply lt_of_le_of_lt; assumption,
--       have : m ≤ k - 1, from nat.le_sub_right_of_add_le (succ_le_of_lt h₂),
--       have : m ≤ k, from le_of_lt h₂,
--       have : 1 ≤ k, from one_le_of_lt h₂,
--       simp [*, nat.add_sub_swap this n₂, -add_assoc, -add_comm] }
--   end
-- | _ (func f)    s n₁ n₂ m h := rfl
-- | _ (app t₁ t₂) s n₁ n₂ m h := by simp*

-- lemma lift_subst_term_large {l} (t : preterm L l) (s : term L) (n₁ n₂) :
--   (t ↑ n₂)[s // n₁+n₂] = (t [s // n₁]) ↑ n₂ :=
-- lift_at_subst_term_large t s n₂ n₁.zero_le

-- lemma lift_subst_term_large' {l} (t : preterm L l) (s : term L) (n₁ n₂) :
--   (t ↑ n₂)[s // n₂+n₁] = (t [s // n₁]) ↑ n₂ :=
-- by rw [add_comm]; apply lift_subst_term_large

-- lemma lift_at_subst_term_medium : ∀{l} (t : preterm L l) (s : term L) {n₁ n₂ m}, m ≤ n₂ →
--   n₂ ≤ m + n₁ → (t ↑' n₁+1 # m)[s // n₂] = t ↑' n₁ # m
-- | _ &k          s n₁ n₂ m h₁ h₂ :=
--   begin
--     by_cases h : m ≤ k,
--     { have h₃ : n₂ < k + (n₁ + 1), from lt_succ_of_le (le_trans h₂ (add_le_add_right h _)),
--       simp [*, add_sub_cancel_right] },
--     { have h₃ : k < n₂, from lt_of_lt_of_le (lt_of_not_ge h) h₁, simp* }
--   end
-- | _ (func f)    s n₁ n₂ m h₁ h₂ := rfl
-- | _ (app t₁ t₂) s n₁ n₂ m h₁ h₂ := by simp*

-- lemma lift_subst_term_medium {l} (t : preterm L l) (s : term L) (n₁ n₂) :
--   (t ↑ ((n₁ + n₂) + 1))[s // n₁] = t ↑ (n₁ + n₂) :=
-- lift_at_subst_term_medium t s n₁.zero_le (by rw [zero_add]; exact n₁.le_add_right n₂)

-- lemma lift_at_subst_term_eq {l} (t : preterm L l) (s : term L) (n : ℕ) : (t ↑' 1 # n)[s // n] = t :=
-- begin rw [lift_at_subst_term_medium t s, lift_term_at_zero]; refl end

-- @[simp] lemma lift_term1_subst_term {l} (t : preterm L l) (s : term L) : (t ↑ 1)[s // 0] = t :=
-- lift_at_subst_term_eq t s 0

-- lemma lift_at_subst_term_small : ∀{l} (t : preterm L l) (s : term L) (n₁ n₂ m),
--  (t ↑' n₁ # (m + n₂ + 1))[s ↑' n₁ # m // n₂] = (t [s // n₂]) ↑' n₁ # (m + n₂)
-- | _ &k          s n₁ n₂ m :=
--   begin
--     by_cases h : m + n₂ + 1 ≤ k,
--     { change m + n₂ + 1 ≤ k at h,
--       have h₂ : n₂ < k := lt_of_le_of_lt (le_add_left n₂ m) (lt_of_succ_le h),
--       have h₃ : n₂ < k + n₁ := by apply nat.lt_add_right; exact h₂,
--       have h₄ : m + n₂ ≤ k - 1 := nat.le_sub_right_of_add_le h,
--       simp [*, -add_comm, -add_assoc, nat.add_sub_swap (one_le_of_lt h₂)] },
--     { change ¬(m + n₂ + 1 ≤ k) at h,
--       apply decidable.lt_by_cases k n₂; intro h₂,
--       { have h₃ : ¬(m + n₂ ≤ k) := λh', not_le_of_gt h₂ (le_trans (le_add_left n₂ m) h'),
--         simp [h, h₂, h₃, -add_comm, -add_assoc] },
--       { subst h₂,
--         have h₃ : ¬(k + m + 1 ≤ k) := by rw [add_comm k m]; exact h,
--         simp [h, h₃, -add_comm, -add_assoc],
--         exact lift_term_at2_small _ _ _ m.zero_le },
--       { have h₃ : ¬(m + n₂ ≤ k - 1) :=
--           λh', h $ (nat.le_sub_right_iff_add_le $ one_le_of_lt h₂).mp h',
--         simp [h, h₂, h₃, -add_comm, -add_assoc] }}
--   end
-- | _ (func f)    s n₁ n₂ m := rfl
-- | _ (app t₁ t₂) s n₁ n₂ m := by simp [*, -add_assoc, -add_comm]

-- lemma subst_term2 : ∀{l} (t : preterm L l) (s₁ s₂ : term L) (n₁ n₂),
--   t [s₁ // n₁] [s₂ // n₁ + n₂] = t [s₂ // n₁ + n₂ + 1] [s₁[s₂ // n₂] // n₁]
-- | _ &k          s₁ s₂ n₁ n₂ :=
--   begin -- can we use subst_realize2 here?
--     apply decidable.lt_by_cases k n₁; intro h,
--     { have : k < n₁ + n₂, from lt_of_le_of_lt (k.le_add_right n₂) (by simp*),
--       have : k < n₁ + n₂ + 1, from lt.step this,
--       simp only [*, eq_self_iff_true, fol.subst_term_var_lt] },
--     { have : k < k + (n₂ + 1), from lt_succ_of_le (le_add_right _ n₂),
--       subst h, simp [*, lift_subst_term_large', -add_comm] },
--     apply decidable.lt_by_cases k (n₁ + n₂ + 1); intro h',
--     { have : k - 1 < n₁ + n₂, from (nat.sub_lt_right_iff_lt_add (one_le_of_lt h)).2 h',
--       simp [*, -add_comm, -add_assoc] },
--     { subst h', simp [h, lift_subst_term_medium, -add_comm, -add_assoc] },
--     { have : n₁ + n₂ < k - 1, from nat.lt_sub_right_of_add_lt h',
--       have : n₁ < k - 1, from lt_of_le_of_lt (n₁.le_add_right n₂) this,
--       simp only [*, eq_self_iff_true, fol.subst_term_var_gt] }
--   end
-- | _ (func f)    s₁ s₂ n₁ n₂ := rfl
-- | _ (app t₁ t₂) s₁ s₂ n₁ n₂ := by simp*

-- lemma subst_term2_0 {l} (t : preterm L l) (s₁ s₂ : term L) (n) :
--   t [s₁ // 0] [s₂ // n] = t [s₂ // n + 1] [s₁[s₂ // n] // 0] :=
-- let h := subst_term2 t s₁ s₂ 0 n in by simp only [zero_add] at h; exact h

-- lemma lift_subst_term_cancel : ∀{l} (t : preterm L l) (n : ℕ), (t ↑' 1 # (n+1))[&0 // n] = t
-- | _ &k          n :=
--   begin
--     apply decidable.lt_by_cases n k; intro h,
--     { change n+1 ≤ k at h, have h' : n < k+1, from lt.step (lt_of_succ_le h), simp [h, h'] },
--     { have h' : ¬(k+1 ≤ k), from not_succ_le_self k, simp [h, h'] },
--     { have h' : ¬(n+1 ≤ k) := not_le_of_lt (lt.step h), simp [h, h'] }
--   end
-- | _ (func f)    n := rfl
-- | _ (app t₁ t₂) n := by dsimp; simp [*]

-- /- Probably useful facts about substitution which we should add when needed:
-- (forall M N i j k, ( M [ j ← N] ) ↑' k # (j+i) = (M ↑' k # (S (j+i))) [ j ← (N ↑' k # i ) ])
-- subst_travers : (forall M N P n, (M [← N]) [n ← P] = (M [n+1 ← P])[← N[n← P]])
-- erasure_lem3 : (forall n m t, m>n->#m = (#m ↑' 1 # (S n)) [n ← t]).
-- lift_is_lift_sublemma : forall j v, j<v->exists w,#v=w↑1#j.
-- lift_is_lift : (forall N A n i j,N ↑' i # n=A ↑' 1 # j -> j<n -> exists M,N=M ↑' 1 # j)
-- subst_is_lift : (forall N T A n j, N [n ← T]=A↑' 1#j->j<n->exists M,N=M↑' 1#j)
-- -/

-- /- preformula l is a partially applied formula. if applied to n terms, it becomes a formula.
--   * We only have implication as binary connective. Since we use classical logic, we can define
--     the other connectives from implication and falsum.
--   * Similarly, universal quantification is our only quantifier.
--   * We could make `falsum` and `equal` into elements of rel. However, if we do that, then we cannot make the interpretation of them in a model definitionally what we want.
-- -/
variable (L)
inductive preformula : ℕ → Type u
| falsum {} : preformula 0
| equal (t₁ t₂ : term L) : preformula 0
| rel {l : ℕ} (R : L.relations l) : preformula l
| apprel {l : ℕ} (f : preformula (l + 1)) (t : term L) : preformula l
| imp (f₁ f₂ : preformula 0) : preformula 0
| all (f : preformula 0) : preformula 0
export preformula
@[reducible] def formula := preformula L 0
variable {L}

notation `⊥` := preformula.falsum -- input: \bot
infix ` ≃ `:88 := preformula.equal -- input \~- or \simeq
infixr ` ⟹ `:62 := preformula.imp -- input \==>
prefix `∀'`:110 := preformula.all
def preformula.not   (f : formula L)     : formula L := f ⟹ ⊥
prefix `∼`:max := preformula.not -- input \~, the ASCII character ~ has too low precedence
notation `⊤` := ∼⊥ -- input: \top
def preformula.and   (f₁ f₂ : formula L) : formula L := ∼(f₁ ⟹ ∼f₂)
infixr ` ⊓ ` := preformula.and -- input: \sqcap
def preformula.or    (f₁ f₂ : formula L) : formula L := ∼f₁ ⟹ f₂
infixr ` ⊔ ` := preformula.or -- input: \sqcup
def biimp (f₁ f₂ : formula L) : formula L := (f₁ ⟹ f₂) ⊓ (f₂ ⟹ f₁)
infix ` ⇔ `:61 := biimp -- input \<=>
def ex    (f : formula L)     : formula L := ∼ ∀' ∼f
prefix `∃'`:110 := ex -- input \ex

meta instance preterm.reflect {L : Language.{0}} [reflected L] [∀ n, has_reflect (L.functions n)] :
  ∀{n}, has_reflect (preterm L n)
| _ &k          := `(&k)
| _ (func f)    := `(func f)
| _ (app t₁ t₂) := (`(λ x y, app x y).subst (preterm.reflect t₁)).subst (preterm.reflect t₂)

meta instance preformula.reflect {L : Language.{0}} [reflected L] [∀ n, has_reflect (L.functions n)]
  [∀ n, has_reflect (L.relations n)] : ∀{n}, has_reflect (preformula L n)
| _ falsum           := `(falsum)
| _ (equal t₁ t₂)    := (`(λ x₁ x₂, equal x₁ x₂).subst (preterm.reflect t₁)).subst (preterm.reflect t₂)
| _ (rel R)          := `(λ x, preformula.rel x).subst `(R)
| _ (apprel f t)     := (`(λ x₁ x₂, apprel x₁ x₂).subst (preformula.reflect f)).subst (preterm.reflect t)
| _ (imp f₁ f₂)      := (`(λ x₁ x₂, imp x₁ x₂).subst (preformula.reflect f₁)).subst (preformula.reflect f₂)
| _ (all f)          := `(λ x, all x).subst (preformula.reflect f)

def L_empty : Language :=
  ⟨λ _, empty, λ _, empty⟩

meta instance L_empty.reflect_functions : ∀ n, has_reflect (L_empty.functions n) :=
λ _ _, empty.elim ‹_›

meta instance L_empty.reflect_relations : ∀ n, has_reflect (L_empty.relations n) :=
λ _ _, empty.elim ‹_›

meta def parse_preterm : Π {k}, parser_tactic $ preterm L_empty k
| 0 := alphanumeric_token *> return (preterm.var 0)
| (n+1) := fail

meta def parse_term := @parse_preterm 0

-- -- note(jesse): for non-empty languages, need parsers parametrized over the function and relation symbols
-- meta def parse_preformula : Π {k},  parser_tactic $ preformula L_empty k
-- | 0 := (-- preformula.all <$> ((token $ str "∀") *> @parse_preformula 0) <|>
-- do b <- lookahead "⟹",
--           if b then preformula.imp <$> (@parse_preformula 0) <*>(@parse_preformula 0)
--                else fail <|>
--        (token $ str "⊥") *> return preformula.falsum <|>
--        preformula.equal <$> @parse_preterm 0 <* (token $ str "=") <*> @parse_preterm 0) <* whitespace -- TODO(jesse) eliminate the recursive call
-- | (n+1) := fail

-- meta def parse_formula := @parse_preformula 0

-- a ⟹ (b ⟹ (c ⟹ d)) -- let's assume that implication associates to the right

-- gets parsed as
-- app "imp" [leaf "a", app "imp" [leaf "b", app "imp" ["leaf c", leaf "d"]]]

inductive tree (α : Type) : Type
| leaf (a : α) : tree
| app (l : option α) (ts : list tree) : tree
open tree

def add_subtree {α} : ∀ (t : tree α) (t' : tree α), tree α
| (leaf a) t' := app none [t', leaf a]
| (app l ts) t' := app l $ t' :: ts

def add_parent {α} : ∀ (t : tree α) (a : option α), tree α :=
λ t a, app a [t]

def imp_handler (arg : string) (t : tree string) : tree string :=
if arg = "⟹" then add_parent t (some arg) else add_subtree t (leaf arg)

-- meta def parse_imp_aux : tree string → (parser_tactic $ tree string) :=
-- λ t, do
--   imp_handler <$> return t <*> (token $ not_whitespace)

meta def parse_imp : (parser_tactic $ tree string) :=
do  x <- token not_whitespace,
    (imp_handler <$> return x <*> parse_imp) <|> return (leaf x)

meta instance tree_string_reflect : has_reflect (tree string)
| (leaf arg) := `(λ x, leaf x).subst `(arg)
| (app l ts) := (`(λ x y, tree.app x y).subst `(l)).subst (by haveI := tree_string_reflect; exact list.reflect ts)

def my_tree' : tree string := by (parse_imp).get_result "a ⟹ b ⟹ c ⟹ d"

#print my_tree'

-- def my_eq : preformula L_empty 0 := by (preformula.equal <$> @parse_preterm 0 <* (token $ str "=") <*> @parse_preterm 0).get_result "a = a"

-- def my_falsum : preformula L_empty 0 := by parse_formula.get_result "a = a ⟹ a = b"

-- #reduce my_falsum

-- def foo := by (preformula.all <$> (symb "∀" *> eof)).get_result "∀"

-- #reduce my_eq -- &0 ≃ &0

-- def foo : preterm L_empty 0 := by parse_term.get_result "f1"

-- #reduce by parse_term.get_result "f1"

-- run_cmd (run' (preformula.all <$> (str "∀" *> @parse_preformula 0)) "foo"

-- def my_falsum : preformula L_empty 0 := by parse_formula.get_result "⊥"

-- #reduce by parse_term.get_result ""

-- #eval by (token $ str "=").get_result "="

-- #reduce "foo"


import tactic
import data.polynomial.basic
import data.polynomial.degree.definitions
import data.polynomial.eval
import data.list.func
import data.nat.prime
import data.matrix.notation
import linear_algebra.matrix.determinant
import tactic.sageify.socket
.

class has_sageify (R : Type*) :=
(sageify : R → string)
class has_sageify_type (R : Type*) :=
(sageify_type : string)

namespace has_sageify
open has_sageify_type
instance : has_sageify ℕ := ⟨λ n, to_string n⟩
instance : has_sageify ℤ := ⟨λ n, to_string n⟩
instance : has_sageify ℚ := ⟨λ n, to_string n⟩

instance : has_sageify_type ℤ := ⟨"Integers()"⟩
instance : has_sageify_type ℚ := ⟨"Rationals()"⟩
-- instance : has_sageify_type ℝ := ⟨λ n, "RDF()"⟩
-- instance : has_sageify_type ℂ := ⟨λ n, "CDF()"⟩

instance {R S : Type*} [has_sageify R] [has_sageify S] : has_sageify (R × S) :=
⟨λ n, "(" ++ sageify n.1 ++ ", " ++ sageify n.2 ++ ")"⟩
instance {R : Type*} [has_sageify R] : has_sageify (list R) :=
⟨λ n, "[" ++ ", ".intercalate (n.map (sageify)) ++ "]"⟩

instance {R : Type*} [semiring R] [has_sageify R] [has_sageify_type R] :
  has_sageify (polynomial R) :=
⟨λ n,
  let coeffs : list R := (list.range (n.nat_degree + 1)).map n.coeff in
  sformat!"PolynomialRing({sageify_type R})({sageify coeffs})"⟩
end has_sageify

class has_from_sage (R : Type*) :=
(sage_parser : parser R)

namespace parser

-- unlike the mathlib  one we allow "2" as a rat, and not only "2/1"
def possible_rat : parser ℚ := decorate_error "<rationals>" $ do
  ing ← int,
  di ← many (ch '/'),
  if 0 < di.length then do
    na ← nat,
    pure $ (ing : ℚ) / na
  else
    pure ing

def list {R : Type*} (pR : parser R) : parser (list R) := decorate_error "<list>" $ do
  ch '[',
  l ← many (do
    l ← pR,
    str ", ",
    pure l),
  ch ']',
  pure l
#eval (list (nat)).run_string "[1]"

end parser

namespace has_from_sage

-- dangerous!
def from_sage {R : Type*} [has_from_sage R] (s : string) : option R :=
(sage_parser.run_string s).get_right
def ifrom_sage {R : Type*} [has_from_sage R] [inhabited R] (s : string) : R :=
(from_sage s).iget
-- TODO fix this to remove all space
def strip_from_sage {R : Type*} [has_from_sage R] [inhabited R] (s : string) : option R :=
let s := if s.head = ' ' then s.popn 1 else s in
let s := if s.back = ' ' then s.popn_back 1 else s in
from_sage s

instance : has_from_sage ℕ := ⟨parser.nat⟩
instance : has_from_sage ℤ := ⟨parser.int⟩
instance : has_from_sage ℚ := ⟨parser.possible_rat⟩
#eval (ifrom_sage "-1232/113" : ℚ)

instance {R : Type*} [has_from_sage R] : has_from_sage (list R) :=
-- ⟨λ n, ((n.popn 1).pop_back.split (= ',')).map strip_from_sage⟩
⟨do
  parser.ch '[',
  h ← parser.sep_by (parser.str ", ") sage_parser,
  parser.ch ']',
  pure h⟩
#eval (ifrom_sage "[-1232/113, 12]" : list ℚ)
#eval (ifrom_sage "[12113, 12]" : list ℚ)

instance {R S : Type*} [has_from_sage R] [has_from_sage S] : has_from_sage (R × S) :=
⟨do
  parser.ch '(',
  l ← (sage_parser : parser R),
  parser.str ", ",
  r ← (sage_parser : parser S),
  parser.ch ')',
  pure (l, r)⟩
-- ⟨λ n, let st := ((n.popn 1).pop_back.split (= ',')) in
--   (strip_from_sage st.head, strip_from_sage st.tail.head)⟩

#eval (ifrom_sage "[(-1232/113, 1), (12, 1)]" : list (ℚ × ℕ))
instance {R : Type*} [has_from_sage R] [semiring R] : has_from_sage (polynomial R) :=
sorry
-- ⟨λ n, (parser.rat.run_string n).get_right.get_or_else 0⟩

#eval (ifrom_sage "[([-1, 1], 1), ([1], 1)]" : list (list ℚ × ℕ))

end has_from_sage

def sage_config : io.process.spawn_args :=
{ cmd := "conda",
  args := ["run", "-n", "sage", "sage", "-q"],
  stdin := io.process.stdio.piped,
  stderr := io.process.stdio.piped,
  stdout := io.process.stdio.piped
  }

def sage_io_config : io.process.spawn_args :=
{ cmd := "conda",
  args := ["run", "-n", "sage", "--no-capture-output", "sage", "-q"],
      --     -- "--simple-prompt" -- unclear if helpful
  stdin := io.process.stdio.piped,
  stderr := io.process.stdio.piped,
  stdout := io.process.stdio.piped
  }

def sage_io_config' : io.process.spawn_args :=
{ cmd := "sage",
  args := ["-q"],
  stdin := io.process.stdio.piped,
  stderr := io.process.stdio.piped,
  stdout := io.process.stdio.piped
  }

-- no longer needed
def escape (s : string) : string := "\\\"".intercalate $ s.split (= '\"')

open list.func
#check rat.reflect
run_cmd do to_string <$> tactic.eval_expr ℕ `(2 + 2) >>= tactic.trace

-- meta def reify_poly_aux (R : Type*) [has_add R] [has_zero R] [reflected R] : expr → list R → tactic (list R)
meta def reify_poly_aux : expr → list ℚ → tactic (list ℚ) -- TODO maybe use ring_m.eval instead
| `(tactic.ring.horner %%a %%x %%n %%b) l := do
  A ← reify_poly_aux a [],
  N ← tactic.eval_expr ℕ n,
  B ← expr.to_rat b,
  return (add (list.repeat 0 N ++ A) [B]) -- this should also be a function TODO
| e _ := do
  t ← expr.to_rat e, return [t]

-- meta def reify_poly (R : Type*) [has_add R] [has_zero R] [reflected R] (p : expr) :
meta def reify_poly (p : expr) : tactic (list ℚ) :=
reify_poly_aux p []

open tactic

open has_sageify has_from_sage
def sage_filename := "sagetmp.sage"
-- run_cmd
-- (unsafe_run_io $ do
--     i ← io.proc.spawn sage_io_config',
--     io.fs.put_str_ln i.stdin "1",
--     io.fs.put_str_ln i.stdin sformat!"exit()",
--     io.fs.flush i.stdin,
--     (do 0 ← io.proc.wait i, return ()) <|>
--       io.fail ("Sage produced an error, is it accessible with the " ++
--                "commands specified in `sage_io_config`?"),
--     s ← io.fs.get_line i.stdout,
--     io.fs.close i.stdin,
--     io.print_ln s.to_string)

run_cmd
  unsafe_run_io $ do
    han ← io.mk_file_handle sage_filename io.mode.write,
    let q := sageify (2/4 : ℚ),
    io.fs.put_str_ln han sformat!"print({q})",
    -- let q := sageify (polynomial.X ^ 2 - 1 : polynomial ℚ),
    -- let q := sageify (polynomial.X ^ 2 - 1 : polynomial ℚ),
    io.fs.put_str_ln han sformat!"print(list(PolynomialRing(Rationals(),'x')([1,0,-1]).factor()))",
    io.fs.flush han,
    i ← io.proc.spawn ({args := sage_config.args ++ [sage_filename], ..sage_config} : io.process.spawn_args),
    -- i ← io.proc.spawn ({args := sage_config.args ++ ["-c", "print\\(1\\)"], ..sage_config} : io.process.spawn_args),
    -- i ← io.proc.spawn ({args := sage_config.args ++ ["-c", "\"" ++ escape sage_cmd ++ "\""], ..sage_config} : io.process.spawn_args),
    io.fs.close han,
    s ← io.fs.get_line i.stdout,
    io.print_ln (ifrom_sage $ (buffer.to_string s).pop_back : ℚ),
    s ← io.fs.get_line i.stdout,
    io.print_ln (buffer.to_string s)
    -- io.print_ln (to_string $`((ifrom_sage $ (buffer.to_string s).pop_back : list (polynomial ℚ × ℕ)).head.1))
    -- io.print_ln ((from_sage $ (buffer.to_string s).pop_back : list (polynomial ℚ × ℕ)))

-- run_cmd
--   unsafe_run_io $ do
--     i ← io.proc.spawn
--   { cmd := "conda",
--     args := ["run", "-n", "sage", "--no-capture-output", "sage", "-q"
--       -- "--simple-prompt" -- unclear if helpful
--       ],
--     stdin := io.process.stdio.piped,
--     -- stderr := io.process.stdio.piped,
--     stdout := io.process.stdio.piped
--     },
--     let q := sageify (2/4 : ℚ),
--     io.fs.put_str_ln i.stdin "'t'",
--     -- -- let q := sageify (polynomial.X ^ 2 - 1 : polynomial ℚ),
--     -- let q := sageify (polynomial.X ^ 2 - 1 : polynomial ℚ),
--     io.fs.put_str_ln i.stdin sformat!"list(map(lambda x : (list(x[0]), x[1]), list(PolynomialRing(Rationals(),'x')([1,0,-1]).factor())))",
--     io.fs.put_str_ln i.stdin sformat!"exit()",
--     io.fs.flush i.stdin,
--     n ← io.proc.wait i,
--     io.print_ln n,
--     s ← io.fs.get_line i.stdout,
--     io.print_ln (s.drop 6).pop_back.to_string,
--     s ← io.fs.get_line i.stdout,
--     io.print_ln (s.drop 6).pop_back.to_string,
--     io.print_ln (from_sage $ (s.drop 6).pop_back.to_string : list (list ℚ × ℕ)),
--     io.fs.close i.stdin
meta def fac_to_expr (l : list (list ℚ × ℕ)) : tactic expr :=
do
  (fs : list expr) ← l.mmap (λ lin, do
    ((ine, _) : expr × nat) ← lin.1.mfoldl
      (λ ol ex, do return (`(%%ol.1 + (polynomial.C (%%(ex.reflect) : ℚ) : polynomial ℚ) * polynomial.X ^ ((%%(nat.reflect ol.2)) : nat) : polynomial ℚ), ol.2 + 1)) (`(0 : polynomial ℚ), 0),
    return `((%%ine) ^ (%%lin.2.reflect : nat) : polynomial ℚ)),
  final ← fs.mfoldl (λ ol ex, do return `((%%ol) * (%%ex) : polynomial ℚ)) `(1 : polynomial ℚ),
  trace final,
  sl ← simp_lemmas.mk_default,
  prod.fst <$> simplify sl [] final

section
setup_tactic_parser
open tactic.ring
open tactic

-- TODO catch errors :)
-- TODO multiple commands in one run
meta def get_sage_output_for_string (l : string) : tactic string :=
do
  trace "CALLING SAGE",
  unsafe_run_io $ (do
    i ← io.proc.spawn sage_io_config',
    io.fs.put_str_ln i.stdin l,
    io.fs.put_str_ln i.stdin sformat!"exit()",
    io.fs.flush i.stdin,
    (do 0 ← io.proc.wait i, return ()) <|>
      io.fail ("Sage produced an error, is it accessible with the " ++
               "commands specified in `sage_io_config`?"),
    s ← io.fs.get_line i.stdout,
    if (s.drop 13).take 10 = "----------".to_char_buffer
    then
      (do t ← io.fs.get_line i.stdout,
          t2 ← io.fs.get_line i.stdout,
          t2 ← io.fs.get_line i.stdout,
          io.fail $ "Sage errored with: " ++ (t.drop 7).to_string ++ t2.to_string)
    else return (),
-- TODO return more of the error, eg we should parse the entire traceback by looking for the second blank line? or maybe just read to end?
-- TypeError                                 Traceback (most recent call last)
-- <ipython-input-36-25a6001b137e> in <module>
-- ----> 1 R = PolynomialRing(NonNegativeIntegerSemiring(),'x', names=('x',)); (x,) = R._first_ngens(1)

-- /usr/local/Caskroom/miniconda/base/envs/sage/lib/python3.8/site-packages/sage/rings/polynomial/polynomial_ring_constructor.py in PolynomialRing(base_ring, *args, **kwds)
--     553     """
--     554     if not ring.is_Ring(base_ring):
-- --> 555         raise TypeError("base_ring {!r} must be a ring".format(base_ring))
--     556
--     557     n = -1  # Unknown number of variables

-- TypeError: base_ring Non negative integer semiring must be a ring
    io.fs.close i.stdin,
    io.print_ln s.to_string,
    return $ (s.drop 6).pop_back.to_string)

-- run_cmd (do (l : list ℚ) ← get_sage_output_for_string "[a]", skip)

section
setup_tactic_parser
#check expr.to_string
-- TODO a dependently typed version of this would be good
-- I.e. we should be able to factor integer polys with the same code that factors rational
meta def replace_certified_sage_equality
  (matcher : expr → tactic bool) -- match exprs to be converted
  (reify_type : Type*) -- the type the input should be converted to
  (reify : expr → tactic reify_type)
  (sage_input : reify_type → tactic string) -- takes the reified expr to
  (output_type : Type*) -- the type the sage output should be converted to
  [has_from_sage output_type]
  [has_to_tactic_format output_type] -- only for testing
  (convert_output : output_type → tactic expr) -- takes the output
  (validator : expr → expr → tactic (expr)) -- produces proofs that original expr agrees with the
  (naam : string)
  (wi : parse (parser.tk "with" *> parser.pexpr)?) :
  tactic unit :=
do
  g ← target,
  (oe : option expr) ← g.mfold (none : option expr) (λ sub n old, if old.is_some then return old else (do
    s ← matcher sub,
    match s with
    | tt := return (some sub)
    | ff := return old
    end)),
  trace oe,
  oe ← oe,
  (re : reify_type) ← reify oe,
  (s : string) ← (do w ← (wi.map return).get_or_else failure, w ← i_to_expr w,
    trace w,
    trace w.to_string,
    return $ (w.to_string.popn 1).popn_back 1)
    <|> sage_input re >>= (λ r, get_sage_output_for_string r <|> unsafe_run_io (run_online_sage_for_string' r)),
  let l : option output_type := from_sage s,
  l ← l,
  newe ← convert_output l,
  p ← validator oe newe,
  rewrite_target p,
  -- TODO maybe check equality here
  (guard wi.is_none >> trace (sformat!"Try this: {naam} with \"{s}\"")) <|> skip

end

/-
Examples:
-/

-- TODO fix other uses of reflect
meta def tactic.interactive.factor_nats := replace_certified_sage_equality
  (λ ex, do
    t ← infer_type ex,
    return $ t = `(nat))
  ℕ
  (λ e, e.to_nat)
  (λ n, return sformat!"print(list(ZZ({n}).factor()))")
  (list (ℕ × ℕ))
  (λ l, do
    ini ← l.mfoldl (λ ol ⟨p, n⟩, do
      P ← expr.of_nat `(ℕ) p,
      N ← expr.of_nat `(ℕ) n,
      return `((%%ol : ℕ) * (%%P : ℕ) ^ (%%N : ℕ))) `(1 : ℕ),
    sl ← simp_lemmas.mk_default,
    prod.fst <$> simplify sl [] ini)
  (λ o n, do
    (e₁', p₁) ← or_refl_conv norm_num.derive o, -- TODO use this trick in mathlib
    (e₂', p₂) ← or_refl_conv norm_num.derive n,
    trace e₁',
    trace e₂',
    is_def_eq e₁' e₂',
    mk_eq_symm p₂ >>= mk_eq_trans p₁)
  "factor_nats"

meta def tactic.interactive.factor_poly := replace_certified_sage_equality
  (λ ex, do
    t ← infer_type ex,
    return $ t = `(polynomial ℚ))
  (list ℚ)
  (λ e, do using_new_ref mk_buffer $ λ atoms,
    do
      (e, f) ← normalize' atoms reducible ring.normalize_mode.raw tt e,
      reify_poly e)
  (λ n, return
    sformat!"list(map(lambda x : (list(x[0]), x[1]), list(PolynomialRing(Rationals(),'x')({n}).factor())))")
  (list (list ℚ × ℕ))
  fac_to_expr
  (λ o n, do
    ((e₁', p₁), (e₂', p₂)) ← ring_m.run reducible n $
      prod.mk <$> eval (λ _, failed) o <*> eval (λ _, failed) n,
    trace e₁',
    trace e₂',
    is_def_eq e₁' e₂',
    mk_eq_symm p₂ >>= mk_eq_trans p₁)
  "factor_poly"

meta def reify_vec_cons_aux (R : Type*) (rei : expr → tactic R) : expr → list R → tactic (list R)
| `(@matrix.vec_cons %%a %%n %%el %%b) l := do
  A ← reify_vec_cons_aux b l,
  l ← rei el,
  return $ l :: A -- this should also be a function TODO
| `(matrix.vec_empty) _ := return []
| e _ := return []

meta def reify_vec_cons (R : Type*) (rei : expr → tactic R) (p : expr) : tactic (list R) :=
reify_vec_cons_aux R rei p []

meta def reify_mat {R : Type*} (f : expr → option R) (p : expr) : tactic (list $ list R) :=
reify_vec_cons (list R) (reify_vec_cons R (λ e, f e)) p

meta def mat_to_expr {R : Type} (ty : expr) (f : R → expr) (l : list (list R)) : pexpr := -- TODO use a pexpr here and i_to_expr_for_???
let n : expr := `(%%l.head.length.reflect : ℕ) in -- TODO change to ncols
l.reverse.enum.reverse.foldr (λ t ol,
  let a : expr := t.2.reverse.enum.reverse.foldr (λ v ol',
    let inp := f v.2 in `(@matrix.vec_cons.{0} %%ty (%%(v.1.reflect)) %%inp %%ol'))
    (`(matrix.vec_empty.{0} : fin 0 → %%ty) : expr) in
  ``(matrix.vec_cons.{0} %%a %%ol : fin (nat.succ %%(t.1.reflect)) → fin (%%n : ℕ) → %%ty))
  ``(@matrix.vec_empty.{0} $ fin %%n →  %%ty)

-- example :false :=
-- begin
--   (do m ← mk_mvar,
--   t ← infer_type m,
--   unify t `((%%(mat_to_expr [[1,1],[1,0]]) : fin 2 → fin 2 → ℚ) = %%(mat_to_expr [[1,1],[1,0]])), set_goals  [m]),

-- end

meta def tactic.interactive.rref := replace_certified_sage_equality
  (λ ex, do
    t ← infer_type ex >>= whnf <|> return `(Type), -- if infer type fails then return false
    match t with
    | `(fin %%e → fin %%f → ℚ) := return tt
    | _ := return ff
    end)
  (list (list ℚ))
  (reify_mat expr.to_rat)
  (λ n, return $
    sformat!"A = Matrix(QQ, {n}); A = A.augment(MatrixSpace(QQ, A.nrows(), A.nrows())(1), subdivide=True);" ++
      "B = A.rref(); (list(list(b) for b in B.subdivision(0,0)),list(list(b) for b in B.subdivision(0,1).inverse()))")
  (list (list ℚ) × list (list ℚ))
  (λ l, do
    n ← expr.of_nat `(ℕ) l.1.length,
    m ← expr.of_nat `(ℕ) l.1.head.length,
    m1 ← i_to_expr $ mat_to_expr `(ℚ) (λ n : ℚ, reflect n) l.1,
    m2 ← i_to_expr $ mat_to_expr `(ℚ) (λ n : ℚ, reflect n) l.2,
    return $ `(matrix.mul
      (%%m2 : matrix (fin %%n) (fin %%n) ℚ)
      (%%m1 : matrix (fin _) (fin %%m) ℚ)))
  (λ o n, do
    trace o,
    trace n,
    (e₁', p₁) ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) o,
    -- sl ← simp_lemmas.mk.add_simp ``matrix.mul_fin_two,
    -- (e₂', p₂) ← or_refl_conv (λ e, do f ← simplify sl [] e, return (f.1, f.2.1)) n,
    (e₂'', p₂') ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) n,
    -- good for debugging
    -- (do m ← mk_mvar,
    --   t ← infer_type m,
    --   i_to_expr ``(%%e₂'' = %%n) >>= unify t, set_goals [m]),
    is_def_eq e₁' e₂'',
    -- p₂ ← mk_eq_trans p₂ p₂',
    mk_eq_symm p₂' >>= mk_eq_trans p₁)
  "rref"

meta def tactic.interactive.hnf := replace_certified_sage_equality
  (λ ex, do
    t ← infer_type ex >>= whnf <|> return `(Type), -- if infer type fails then return false
    match t with
    | `(fin %%e → fin %%f → ℤ) := return tt
    | _ := return ff
    end)
  (list (list ℤ))
  (reify_mat expr.to_int)
  (λ n, return $
    sformat!"A = Matrix(ZZ, {n});" ++
      "B, U = A.hermite_form(transformation=True); (list(list(b) for b in B), list(list(u) for u in U.inverse()))")
  (list (list ℤ) × list (list ℤ))
  (λ l, do
    n ← expr.of_nat `(ℕ) l.1.length,
    m ← expr.of_nat `(ℕ) l.1.head.length,
    m1 ← i_to_expr $ mat_to_expr `(ℤ) (λ n : ℤ, reflect n) l.1, -- TODO fix this
    m2 ← i_to_expr $ mat_to_expr `(ℤ) (λ n : ℤ, reflect n) l.2,
    return $ `(matrix.mul
      (%%m2 : matrix (fin %%n) (fin %%n) ℤ)
      (%%m1 : matrix (fin _) (fin %%m) ℤ)))
  (λ o n, do
    (e₁', p₁) ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) o,
    (e₂'', p₂') ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) n,
    is_def_eq e₁' e₂'',
    mk_eq_symm p₂' >>= mk_eq_trans p₁)
  "hnf"

open_locale matrix
meta def tactic.interactive.snf := replace_certified_sage_equality
  (λ ex, do
    t ← infer_type ex >>= whnf <|> return `(Type), -- if infer type fails then return false
    match t with
    | `(fin %%e → fin %%f → ℤ) := return tt
    | _ := return ff
    end)
  (list (list ℤ))
  (reify_mat expr.to_int)
  (λ n, return $
    sformat!"A = Matrix(ZZ, {n});" ++
      "B, U, V = A.smith_form(transformation=True); [list(list(b) for b in B), list(list(u) for u in U.inverse()), list(list(v) for v in V.inverse())]")
  (list $ list (list ℤ)) -- TODO make a 3-tuple parser work and change this
  (λ l, do
    n ← expr.of_nat `(ℕ) l.head.length,
    m ← expr.of_nat `(ℕ) l.head.head.length,
    m1 ← i_to_expr $ mat_to_expr `(ℤ) (λ n : ℤ, reflect n) l.head, -- TODO fix this
    m2 ← i_to_expr $ mat_to_expr `(ℤ) (λ n : ℤ, reflect n) l.tail.head,
    m3 ← i_to_expr $ mat_to_expr `(ℤ) (λ n : ℤ, reflect n) l.tail.tail.head,
    trace ">>>>>",
    return $ `(
      (%%m2 : matrix (fin %%n) (fin %%n) ℤ) ⬝
      (%%m1 : matrix (fin _) (fin %%m) ℤ) ⬝
      (%%m3 : matrix (fin _) (fin %%m) ℤ)))
  (λ o n, do
    (e₁', p₁) ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) o,
    (e₂'', p₂') ← or_refl_conv (conv.convert $ conv.interactive.norm_num []) n,
    is_def_eq e₁' e₂'',
    mk_eq_symm p₂' >>= mk_eq_trans p₁)
  "snf"

end

-- want multivariate examples too
-- example (x y : ℤ) : x * y + x * x * y + y + 1 = 0 :=
-- begin
--   ring_nf,
-- end

example : polynomial.eval 1 (polynomial.X ^ 3 - 1 : polynomial ℚ) = 0 :=
begin
  factor_poly with "[([-1, 1], 1), ([1, 1, 1], 1)]", -- TODO at loc
  simp,
end

example : ¬ nat.prime 1111 :=
begin
  factor_nats, -- TODO at loc
  simp [nat.prime_mul_iff],
end

open_locale matrix
-- TODO update to new mats
-- example {α : Type*} [comm_ring α] {a b c d e f g h i : α} :
--         ![![a, b], ![c, d]] ⬝ ![![e, f], ![g, i]] =
--        ![![a, b], ![c, d]] :=
-- begin
--   rw [matrix.mul_fin_two],
-- end
-- example :
--         ![![1, 2], ![3, 4]] ⬝ ![![4, 4,1], ![4, 4,1]] =
--        ![![4, 4,8], ![4, 4,0]] :=
-- begin
--   norm_num,
-- end

-- set_option trace.simplify true
-- set_option pp.all true
-- set_option trace.type_context.is_def_eq true
-- set_option trace.type_context.is_def_eq_detail true

-- example : ∃ v : fin 1 → fin 2 → ℚ, v ⬝
--         (![![1, 1, 0], ![1, 1, 0]] : matrix _ _ ℚ) = 0 :=
-- begin
--   rref,
--   simp_rw [← matrix.mul_assoc],
-- end

-- example : ∃ v : fin 1 → fin 2 → ℤ, v ⬝
--         (![![1, 1, 0], ![2, 2, 1]] : matrix _ _ ℤ) = 0 :=
-- begin
--   hnf,
--   simp_rw [← matrix.mul_assoc],
-- end

-- example : ∃ v : fin 1 → fin 2 → ℤ, v ⬝
--         (![![1, 1, 0], ![2, 2, 1]] : matrix _ _ ℤ) = 0 :=
-- begin
--   snf,
--   dsimp,
--   simp_rw [← matrix.mul_assoc],
-- end

/-
How should the sage monad look?
do
  let t : list blah := something from tactic state,
  s ← sage_compute

-/

/-
# TODO
- gcd by bezout
- ideal membership
- ideal equality/containment
  - optimal ideal basis
- factoring
- inverse in the class group
- class group structure
- class group generators
- finding local obstructions

## Harder

Certificate for non-principality of ideals
-/


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Supplementary theorems about the `string` type.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.data.char
import Mathlib.PostPort

namespace Mathlib

namespace string

def ltb : iterator → iterator → Bool := sorry

protected instance has_lt' : HasLess string :=
  { Less := fun (s₁ s₂ : string) => ↥(ltb (mk_iterator s₁) (mk_iterator s₂)) }

protected instance decidable_lt : DecidableRel Less :=
  fun (a b : string) => bool.decidable_eq (ltb (mk_iterator a) (mk_iterator b)) tt

@[simp] theorem lt_iff_to_list_lt {s₁ : string} {s₂ : string} : s₁ < s₂ ↔ to_list s₁ < to_list s₂ :=
  sorry

protected instance has_le : HasLessEq string := { LessEq := fun (s₁ s₂ : string) => ¬s₂ < s₁ }

protected instance decidable_le : DecidableRel LessEq :=
  fun (a b : string) => ne.decidable (ltb (mk_iterator b) (mk_iterator a)) tt

@[simp] theorem le_iff_to_list_le {s₁ : string} {s₂ : string} : s₁ ≤ s₂ ↔ to_list s₁ ≤ to_list s₂ :=
  iff.trans (not_congr lt_iff_to_list_lt) not_lt

theorem to_list_inj {s₁ : string} {s₂ : string} : to_list s₁ = to_list s₂ ↔ s₁ = s₂ := sorry

theorem nil_as_string_eq_empty : list.as_string [] = empty := rfl

@[simp] theorem to_list_empty : to_list empty = [] := rfl

theorem as_string_inv_to_list (s : string) : list.as_string (to_list s) = s :=
  string_imp.cases_on s fun (s : List char) => Eq.refl (list.as_string (to_list (string_imp.mk s)))

@[simp] theorem to_list_singleton (c : char) : to_list (singleton c) = [c] := rfl

theorem to_list_nonempty {s : string} (h : s ≠ empty) : to_list s = head s :: to_list (popn s 1) :=
  sorry

@[simp] theorem head_empty : head empty = Inhabited.default := rfl

@[simp] theorem popn_empty {n : ℕ} : popn empty n = empty := sorry

protected instance linear_order : linear_order string :=
  linear_order.mk LessEq Less sorry sorry sorry sorry string.decidable_le
    (fun (a b : string) => string.has_decidable_eq a b)
    fun (a b : string) => string.decidable_lt a b

end string

theorem list.to_list_inv_as_string (l : List char) : string.to_list (list.as_string l) = l := sorry

@[simp] theorem list.as_string_inj {l : List char} {l' : List char} :
    list.as_string l = list.as_string l' ↔ l = l' :=
  sorry

theorem list.as_string_eq {l : List char} {s : string} :
    list.as_string l = s ↔ l = string.to_list s :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.group.type_tags
import algebra.hom.equiv
import algebra.hom.ring
import algebra.hom.units

/-!
# Unbundled monoid and group homomorphisms

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines predicates for unbundled monoid and group homomorphisms. Instead of using
this file, please use `monoid_hom`, defined in `algebra.hom.group`, with notation `→*`, for
morphisms between monoids or groups. For example use `φ : G →* H` to represent a group
homomorphism between multiplicative groups, and `ψ : A →+ B` to represent a group homomorphism
between additive groups.

## Main Definitions

`is_monoid_hom` (deprecated), `is_group_hom` (deprecated)

## Tags

is_group_hom, is_monoid_hom

-/

universes u v
variables {α : Type u} {β : Type v}

/-- Predicate for maps which preserve an addition. -/
structure is_add_hom {α β : Type*} [has_add α] [has_add β] (f : α → β) : Prop :=
(map_add [] : ∀ x y, f (x + y) = f x + f y)

/-- Predicate for maps which preserve a multiplication. -/
@[to_additive]
structure is_mul_hom {α β : Type*} [has_mul α] [has_mul β] (f : α → β) : Prop :=
(map_mul [] : ∀ x y, f (x * y) = f x * f y)

namespace is_mul_hom
variables [has_mul α] [has_mul β] {γ : Type*} [has_mul γ]

/-- The identity map preserves multiplication. -/
@[to_additive "The identity map preserves addition"]
lemma id : is_mul_hom (id : α → α) := {map_mul := λ _ _, rfl}

/-- The composition of maps which preserve multiplication, also preserves multiplication. -/
@[to_additive "The composition of addition preserving maps also preserves addition"]
lemma comp {f : α → β} {g : β → γ} (hf : is_mul_hom f) (hg : is_mul_hom g) : is_mul_hom (g ∘ f) :=
{ map_mul := λ x y, by simp only [function.comp, hf.map_mul, hg.map_mul] }

/-- A product of maps which preserve multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "A sum of maps which preserves addition, preserves addition when the target
is commutative."]
lemma mul {α β} [semigroup α] [comm_semigroup β]
  {f g : α → β} (hf : is_mul_hom f) (hg : is_mul_hom g) :
  is_mul_hom (λ a, f a * g a) :=
{ map_mul := λ a b, by simp only [hf.map_mul, hg.map_mul, mul_comm, mul_assoc, mul_left_comm] }

/-- The inverse of a map which preserves multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "The negation of a map which preserves addition, preserves addition when
the target is commutative."]
lemma inv {α β} [has_mul α] [comm_group β] {f : α → β} (hf : is_mul_hom f) :
  is_mul_hom (λ a, (f a)⁻¹) :=
{ map_mul := λ a b, (hf.map_mul a b).symm ▸ mul_inv _ _ }

end is_mul_hom

/-- Predicate for add_monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
structure is_add_monoid_hom [add_zero_class α] [add_zero_class β] (f : α → β)
  extends is_add_hom f : Prop :=
(map_zero [] : f 0 = 0)

/-- Predicate for monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
@[to_additive]
structure is_monoid_hom [mul_one_class α] [mul_one_class β] (f : α → β)
  extends is_mul_hom f : Prop :=
(map_one [] : f 1 = 1)

namespace monoid_hom

variables {M : Type*} {N : Type*} [mM : mul_one_class M] [mN : mul_one_class N]

include mM mN
/-- Interpret a map `f : M → N` as a homomorphism `M →* N`. -/
@[to_additive "Interpret a map `f : M → N` as a homomorphism `M →+ N`."]
def of {f : M → N} (h : is_monoid_hom f) : M →* N :=
{ to_fun := f,
  map_one' := h.2,
  map_mul' := h.1.1 }

variables {mM mN}
@[simp, to_additive]
lemma coe_of {f : M → N} (hf : is_monoid_hom f) : ⇑ (monoid_hom.of hf) = f :=
rfl

@[to_additive]

end monoid_hom

namespace mul_equiv

variables {M : Type*} {N : Type*} [mul_one_class M] [mul_one_class N]

/-- A multiplicative isomorphism preserves multiplication (deprecated). -/
@[to_additive "An additive isomorphism preserves addition (deprecated)."]
theorem is_mul_hom (h : M ≃* N) : is_mul_hom h := ⟨h.map_mul⟩

/-- A multiplicative bijection between two monoids is a monoid hom
  (deprecated -- use `mul_equiv.to_monoid_hom`). -/
@[to_additive "An additive bijection between two additive monoids is an additive
monoid hom (deprecated). "]
lemma is_monoid_hom (h : M ≃* N) : is_monoid_hom h :=
{ map_mul := h.map_mul,
  map_one := h.map_one }

end mul_equiv

namespace is_monoid_hom
variables [mul_one_class α] [mul_one_class β] {f : α → β} (hf : is_monoid_hom f)

/-- A monoid homomorphism preserves multiplication. -/
@[to_additive "An additive monoid homomorphism preserves addition."]
lemma map_mul (x y) : f (x * y) = f x * f y :=
hf.map_mul x y

/-- The inverse of a map which preserves multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "The negation of a map which preserves addition, preserves addition
when the target is commutative."]
lemma inv {α β} [mul_one_class α] [comm_group β] {f : α → β} (hf : is_monoid_hom f) :
  is_monoid_hom (λ a, (f a)⁻¹) :=
{ map_one := hf.map_one.symm ▸ inv_one,
  map_mul := λ a b, (hf.map_mul a b).symm ▸ mul_inv _ _ }

end is_monoid_hom

/-- A map to a group preserving multiplication is a monoid homomorphism. -/
@[to_additive "A map to an additive group preserving addition is an additive monoid
homomorphism."]
theorem is_mul_hom.to_is_monoid_hom [mul_one_class α] [group β] {f : α → β} (hf : is_mul_hom f) :
  is_monoid_hom f :=
{ map_one := mul_right_eq_self.1 $ by rw [← hf.map_mul, one_mul],
  map_mul := hf.map_mul }

namespace is_monoid_hom
variables [mul_one_class α] [mul_one_class β] {f : α → β}

/-- The identity map is a monoid homomorphism. -/
@[to_additive "The identity map is an additive monoid homomorphism."]
lemma id : is_monoid_hom (@id α) := { map_one := rfl, map_mul := λ _ _, rfl }

/-- The composite of two monoid homomorphisms is a monoid homomorphism. -/
@[to_additive "The composite of two additive monoid homomorphisms is an additive monoid
homomorphism."]
lemma comp (hf : is_monoid_hom f) {γ} [mul_one_class γ] {g : β → γ} (hg : is_monoid_hom g) :
  is_monoid_hom (g ∘ f) :=
{ map_one := show g _ = 1, by rw [hf.map_one, hg.map_one],
  ..is_mul_hom.comp hf.to_is_mul_hom hg.to_is_mul_hom }

end is_monoid_hom

namespace is_add_monoid_hom

/-- Left multiplication in a ring is an additive monoid morphism. -/
lemma is_add_monoid_hom_mul_left {γ : Type*} [non_unital_non_assoc_semiring γ] (x : γ) :
  is_add_monoid_hom (λ y : γ, x * y) :=
{ map_zero := mul_zero x, map_add := λ y z, mul_add x y z }

/-- Right multiplication in a ring is an additive monoid morphism. -/
lemma is_add_monoid_hom_mul_right {γ : Type*} [non_unital_non_assoc_semiring γ] (x : γ) :
  is_add_monoid_hom (λ y : γ, y * x) :=
{ map_zero := zero_mul x, map_add := λ y z, add_mul y z x }

end is_add_monoid_hom

/-- Predicate for additive group homomorphism (deprecated -- use bundled `monoid_hom`). -/
structure is_add_group_hom [add_group α] [add_group β] (f : α → β) extends is_add_hom f : Prop

/-- Predicate for group homomorphisms (deprecated -- use bundled `monoid_hom`). -/
@[to_additive]
structure is_group_hom [group α] [group β] (f : α → β) extends is_mul_hom f : Prop

@[to_additive]
lemma monoid_hom.is_group_hom {G H : Type*} {_ : group G} {_ : group H} (f : G →* H) :
  is_group_hom (f : G → H) :=
{ map_mul := f.map_mul }

@[to_additive]
lemma mul_equiv.is_group_hom {G H : Type*} {_ : group G} {_ : group H} (h : G ≃* H) :
  is_group_hom h := { map_mul := h.map_mul }

/-- Construct `is_group_hom` from its only hypothesis. -/
@[to_additive "Construct `is_add_group_hom` from its only hypothesis."]
lemma is_group_hom.mk' [group α] [group β] {f : α → β} (hf : ∀ x y, f (x * y) = f x * f y) :
  is_group_hom f :=
{ map_mul := hf }

namespace is_group_hom
variables [group α] [group β] {f : α → β} (hf : is_group_hom f)
open is_mul_hom (map_mul)

lemma map_mul : ∀ (x y), f (x * y) = f x * f y := hf.to_is_mul_hom.map_mul

/-- A group homomorphism is a monoid homomorphism. -/
@[to_additive "An additive group homomorphism is an additive monoid homomorphism."]
lemma to_is_monoid_hom : is_monoid_hom f :=
hf.to_is_mul_hom.to_is_monoid_hom

/-- A group homomorphism sends 1 to 1. -/
@[to_additive "An additive group homomorphism sends 0 to 0."]
lemma map_one : f 1 = 1 := hf.to_is_monoid_hom.map_one

/-- A group homomorphism sends inverses to inverses. -/
@[to_additive "An additive group homomorphism sends negations to negations."]
theorem map_inv (hf : is_group_hom f) (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq_inv_of_mul_eq_one_left $ by rw [← hf.map_mul, inv_mul_self, hf.map_one]

@[to_additive] lemma map_div (hf : is_group_hom f) (a b : α) : f (a / b) = f a / f b :=
by simp_rw [div_eq_mul_inv, hf.map_mul, hf.map_inv]

/-- The identity is a group homomorphism. -/
@[to_additive "The identity is an additive group homomorphism."]
lemma id : is_group_hom (@id α) := { map_mul := λ _ _, rfl}

/-- The composition of two group homomorphisms is a group homomorphism. -/
@[to_additive "The composition of two additive group homomorphisms is an additive
group homomorphism."]
lemma comp (hf : is_group_hom f) {γ} [group γ] {g : β → γ} (hg : is_group_hom g) :
  is_group_hom (g ∘ f) :=
{ ..is_mul_hom.comp hf.to_is_mul_hom hg.to_is_mul_hom }

/-- A group homomorphism is injective iff its kernel is trivial. -/
@[to_additive "An additive group homomorphism is injective if its kernel is trivial."]
lemma injective_iff {f : α → β} (hf : is_group_hom f) :
  function.injective f ↔ (∀ a, f a = 1 → a = 1) :=
⟨λ h _, by rw ← hf.map_one; exact @h _ _,
  λ h x y hxy, eq_of_div_eq_one $ h _ $ by rwa [hf.map_div, div_eq_one]⟩

/-- The product of group homomorphisms is a group homomorphism if the target is commutative. -/
@[to_additive "The sum of two additive group homomorphisms is an additive group homomorphism
if the target is commutative."]
lemma mul {α β} [group α] [comm_group β]
  {f g : α → β} (hf : is_group_hom f) (hg : is_group_hom g) :
  is_group_hom (λa, f a * g a) :=
{ map_mul := (hf.to_is_mul_hom.mul hg.to_is_mul_hom).map_mul }

/-- The inverse of a group homomorphism is a group homomorphism if the target is commutative. -/
@[to_additive "The negation of an additive group homomorphism is an additive group homomorphism
if the target is commutative."]
lemma inv {α β} [group α] [comm_group β] {f : α → β} (hf : is_group_hom f) :
  is_group_hom (λa, (f a)⁻¹) :=
{ map_mul := hf.to_is_mul_hom.inv.map_mul }

end is_group_hom

namespace ring_hom
/-!
These instances look redundant, because `deprecated.ring` provides `is_ring_hom` for a `→+*`.
Nevertheless these are harmless, and helpful for stripping out dependencies on `deprecated.ring`.
-/
variables {R : Type*} {S : Type*}

section
variables [non_assoc_semiring R] [non_assoc_semiring S]

lemma to_is_monoid_hom (f : R →+* S) : is_monoid_hom f :=
{ map_one := f.map_one,
  map_mul := f.map_mul }

lemma to_is_add_monoid_hom (f : R →+* S) : is_add_monoid_hom f :=
{ map_zero := f.map_zero,
  map_add := f.map_add }
end

section
variables [ring R] [ring S]

lemma to_is_add_group_hom (f : R →+* S) : is_add_group_hom f :=
{ map_add := f.map_add }
end

end ring_hom

/-- Inversion is a group homomorphism if the group is commutative. -/
@[to_additive neg.is_add_group_hom
"Negation is an `add_group` homomorphism if the `add_group` is commutative."]
lemma inv.is_group_hom [comm_group α] : is_group_hom (has_inv.inv : α → α) :=
{ map_mul := mul_inv }

/-- The difference of two additive group homomorphisms is an additive group
homomorphism if the target is commutative. -/
lemma is_add_group_hom.sub {α β} [add_group α] [add_comm_group β]
  {f g : α → β} (hf : is_add_group_hom f) (hg : is_add_group_hom g) :
  is_add_group_hom (λa, f a - g a) :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

namespace units

variables {M : Type*} {N : Type*} [monoid M] [monoid N]

/-- The group homomorphism on units induced by a multiplicative morphism. -/
@[reducible] def map' {f : M → N} (hf : is_monoid_hom f) : Mˣ →* Nˣ :=
  map (monoid_hom.of hf)

@[simp] lemma coe_map' {f : M → N} (hf : is_monoid_hom f) (x : Mˣ) :
  ↑((map' hf : Mˣ → Nˣ) x) = f x :=
rfl

lemma coe_is_monoid_hom : is_monoid_hom (coe : Mˣ → M) := (coe_hom M).is_monoid_hom_coe

end units

namespace is_unit

variables {M : Type*} {N : Type*} [monoid M] [monoid N] {x : M}

lemma map' {f : M → N} (hf :is_monoid_hom f) {x : M} (h : is_unit x) :
  is_unit (f x) :=
h.map (monoid_hom.of hf)

end is_unit

lemma additive.is_add_hom [has_mul α] [has_mul β] {f : α → β} (hf : is_mul_hom f) :
  @is_add_hom (additive α) (additive β) _ _ f :=
{ map_add := is_mul_hom.map_mul hf }

lemma multiplicative.is_mul_hom [has_add α] [has_add β] {f : α → β} (hf : is_add_hom f) :
  @is_mul_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_mul := is_add_hom.map_add hf }

-- defeq abuse
lemma additive.is_add_monoid_hom [mul_one_class α] [mul_one_class β] {f : α → β}
  (hf : is_monoid_hom f) : @is_add_monoid_hom (additive α) (additive β) _ _ f :=
{ map_zero := hf.map_one,
  ..additive.is_add_hom hf.to_is_mul_hom }

lemma multiplicative.is_monoid_hom
  [add_zero_class α] [add_zero_class β] {f : α → β} (hf : is_add_monoid_hom f) :
  @is_monoid_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_one := is_add_monoid_hom.map_zero hf,
  ..multiplicative.is_mul_hom hf.to_is_add_hom }

lemma additive.is_add_group_hom [group α] [group β] {f : α → β} (hf : is_group_hom f) :
  @is_add_group_hom (additive α) (additive β) _ _ f :=
{ map_add := hf.to_is_mul_hom.map_mul }

lemma multiplicative.is_group_hom [add_group α] [add_group β] {f : α → β}
  (hf : is_add_group_hom f) : @is_group_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_mul := hf.to_is_add_hom.map_add }