/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.endomorphism
import category_theory.category.Cat
import algebra.category.Mon.basic

/-!
# Single-object category

Single object category with a given monoid of endomorphisms.
It is defined to facilitate transfering some definitions and lemmas (e.g., conjugacy etc.)
from category theory to monoids and groups.

## Main definitions

Given a type `α` with a monoid structure, `single_obj α` is `unit` type with `category` structure
such that `End (single_obj α).star` is the monoid `α`.  This can be extended to a functor `Mon ⥤
Cat`.

If `α` is a group, then `single_obj α` is a groupoid.

An element `x : α` can be reinterpreted as an element of `End (single_obj.star α)` using
`single_obj.to_End`.

## Implementation notes

- `category_struct.comp` on `End (single_obj.star α)` is `flip (*)`, not `(*)`. This way
  multiplication on `End` agrees with the multiplication on `α`.

- By default, Lean puts instances into `category_theory` namespace instead of
  `category_theory.single_obj`, so we give all names explicitly.
-/

universes u v w

namespace category_theory
/-- Type tag on `unit` used to define single-object categories and groupoids. -/
@[nolint unused_arguments has_inhabited_instance]
def single_obj (α : Type u) : Type := unit

namespace single_obj

variables (α : Type u)

/-- One and `flip (*)` become `id` and `comp` for morphisms of the single object category. -/
instance category_struct [has_one α] [has_mul α] : category_struct (single_obj α) :=
{ hom := λ _ _, α,
  comp := λ _ _ _ x y, y * x,
  id := λ _, 1 }

/-- Monoid laws become category laws for the single object category. -/
instance category [monoid α] : category (single_obj α) :=
{ comp_id' := λ _ _, one_mul,
  id_comp' := λ _ _, mul_one,
  assoc' := λ _ _ _ _ x y z, (mul_assoc z y x).symm }

lemma id_as_one [monoid α] (x : single_obj α) : 𝟙 x = 1 := rfl

lemma comp_as_mul [monoid α] {x y z : single_obj α} (f : x ⟶ y) (g : y ⟶ z) :
  f ≫ g = g * f := rfl

/--
Groupoid structure on `single_obj α`.

See https://stacks.math.columbia.edu/tag/0019.
-/
instance groupoid [group α] : groupoid (single_obj α) :=
{ inv := λ _ _ x, x⁻¹,
  inv_comp' := λ _ _, mul_right_inv,
  comp_inv' := λ _ _, mul_left_inv }

/-- The single object in `single_obj α`. -/
protected def star : single_obj α := unit.star

/-- The endomorphisms monoid of the only object in `single_obj α` is equivalent to the original
     monoid α. -/
def to_End [monoid α] : α ≃* End (single_obj.star α) :=
{ map_mul' := λ x y, rfl,
  .. equiv.refl α }

lemma to_End_def [monoid α] (x : α) : to_End α x = x := rfl

/-- There is a 1-1 correspondence between monoid homomorphisms `α → β` and functors between the
    corresponding single-object categories. It means that `single_obj` is a fully faithful
    functor.

See https://stacks.math.columbia.edu/tag/001F --
although we do not characterize when the functor is full or faithful.
-/
def map_hom (α : Type u) (β : Type v) [monoid α] [monoid β] :
  (α →* β) ≃ (single_obj α) ⥤ (single_obj β) :=
{ to_fun := λ f,
  { obj := id,
    map := λ _ _, ⇑f,
    map_id' := λ _, f.map_one,
    map_comp' := λ _ _ _ x y, f.map_mul y x },
  inv_fun := λ f,
    { to_fun := @functor.map _ _ _ _ f (single_obj.star α) (single_obj.star α),
      map_one' := f.map_id _,
      map_mul' := λ x y, f.map_comp y x },
  left_inv := λ ⟨f, h₁, h₂⟩, rfl,
  right_inv := λ f, by cases f; obviously }

lemma map_hom_id (α : Type u) [monoid α] : map_hom α α (monoid_hom.id α) = 𝟭 _ := rfl

lemma map_hom_comp {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β)
  {γ : Type w} [monoid γ] (g : β →* γ) :
  map_hom α γ (g.comp f) = map_hom α β f ⋙ map_hom β γ g :=
rfl

/-- Given a function `f : C → G` from a category to a group, we get a functor
    `C ⥤ G` sending any morphism `x ⟶ y` to `f y * (f x)⁻¹`. -/
@[simps] def difference_functor {C G} [category C] [group G] (f : C → G) : C ⥤ single_obj G :=
{ obj := λ _, (),
  map := λ x y _, f y * (f x)⁻¹,
  map_id' := by { intro, rw [single_obj.id_as_one, mul_right_inv] },
  map_comp' := by { intros, rw [single_obj.comp_as_mul, ←mul_assoc,
    mul_left_inj, mul_assoc, inv_mul_self, mul_one] } }

end single_obj

end category_theory

open category_theory

namespace monoid_hom

/-- Reinterpret a monoid homomorphism `f : α → β` as a functor `(single_obj α) ⥤ (single_obj β)`.
See also `category_theory.single_obj.map_hom` for an equivalence between these types. -/
@[reducible] def to_functor {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β) :
  (single_obj α) ⥤ (single_obj β) :=
single_obj.map_hom α β f

@[simp] lemma id_to_functor (α : Type u) [monoid α] : (id α).to_functor = 𝟭 _ := rfl
@[simp] lemma comp_to_functor {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α →* β)
  {γ : Type w} [monoid γ] (g : β →* γ) :
  (g.comp f).to_functor = f.to_functor ⋙ g.to_functor :=
rfl

end monoid_hom

namespace units

variables (α : Type u) [monoid α]

/--
The units in a monoid are (multiplicatively) equivalent to
the automorphisms of `star` when we think of the monoid as a single-object category. -/
def to_Aut : units α ≃* Aut (single_obj.star α) :=
(units.map_equiv (single_obj.to_End α)).trans $
  Aut.units_End_equiv_Aut _

@[simp] lemma to_Aut_hom (x : units α) : (to_Aut α x).hom = single_obj.to_End α x := rfl
@[simp] lemma to_Aut_inv (x : units α) :
  (to_Aut α x).inv = single_obj.to_End α (x⁻¹ : units α) :=
rfl
end units

namespace Mon

open category_theory

/-- The fully faithful functor from `Mon` to `Cat`. -/
def to_Cat : Mon ⥤ Cat :=
{ obj := λ x, Cat.of (single_obj x),
  map := λ x y f, single_obj.map_hom x y f }

instance to_Cat_full : full to_Cat :=
{ preimage := λ x y, (single_obj.map_hom x y).inv_fun,
  witness' := λ x y, by apply equiv.right_inv }

instance to_Cat_faithful : faithful to_Cat :=
{ map_injective' := λ x y, by apply equiv.injective }

end Mon


import tactic.tidy
import set_category.diagram_lemmas
import set_category.category_set
import help_functions
import set_category.limits.Equalizer
import set_category.limits.Product
import category_theory.types

namespace Pullback

open set
     diagram_lemmas
     classical
     function
     help_functions
     Equalizer
     Product
     category_theory
     category_set

universes v u

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

def is_pullback {X : Type v} [category X]
    {A₁ A₂ B : X}
    (f : A₁ ⟶ B) (g : A₂ ⟶ B)
    {P : X} (p₁ : P ⟶ A₁) (p₂ : P ⟶ A₂): Prop :=
    f ⊚ p₁ = g ⊚ p₂ ∧
    Π {Q : X} (q₁ : Q ⟶ A₁) (q₂ : Q ⟶ A₂),
        f ⊚ q₁ = g ⊚ q₂ →
            ∃! h : Q ⟶ P, q₁ = p₁ ⊚ h ∧ q₂ = p₂ ⊚ h

lemma equalizer_product_is_pullback_cat
    {X : Type u} [category X]
    {A₁ A₂ B P E : X}
    (f : A₁ ⟶ B) (g : A₂ ⟶ B)
    (π₁ : P ⟶ A₁) (π₂ : P ⟶ A₂)
    (pr : is_product A₁ A₂ π₁ π₂)
    (e : E ⟶ P)
    (eqauliz : is_equalizer (f ⊚ π₁) (g ⊚ π₂) e) :
    is_pullback f g
        (π₁ ⊚ e)
        (π₂ ⊚ e)
    :=
    ⟨ begin
        tidy
     end
    ,
    begin
        intros Q q₁ q₂ fq₁_gq₂,
        let p : Q ⟶ P := some (pr  Q q₁ q₂),
        have spec_p : q₁ = π₁ ⊚ p ∧ q₂ = π₂ ⊚ p := (some_spec (pr Q q₁ q₂)).1,

        have eq_comp : f ⊚ π₁ ⊚ p  = g ⊚ π₂ ⊚ p :=
            calc f ⊚ π₁ ⊚ p   = f ⊚ (π₁ ⊚ p)   : by tidy
                    ...         = f ⊚ q₁         : by rw ← spec_p.1
                    ...         = g ⊚ q₂         : fq₁_gq₂
                    ...         = g ⊚ (π₂ ⊚ p)  : by rw spec_p.2
                    ...         = g ⊚ π₂ ⊚ p    : by tidy,

        let h : Q ⟶ E := some (eqauliz.2 p eq_comp),
        have spec_h : p = e ⊚ h := (some_spec (eqauliz.2 p eq_comp)).1,
        use h,
        have h0 : q₁ = π₁ ⊚ e ⊚ h ∧ q₂ = π₂ ⊚ e ⊚ h :=
            ⟨
                by simp [spec_h , spec_p.1]
                ,
                by simp [spec_h , spec_p.2]
            ⟩ ,
        split,
        exact h0,
        assume (y : Q ⟶ E) (spec_y : q₁ = π₁ ⊚ e ⊚ y ∧ q₂ = π₂ ⊚ e ⊚ y),
        have s0 : π₁ ⊚ (e ⊚ h) = π₁ ⊚ (e ⊚ y) :=
            calc π₁ ⊚ (e ⊚ h) = π₁ ⊚ e ⊚ h      : by tidy
                ...            = q₁                : eq.symm h0.1
                ...            = π₁ ⊚ e ⊚ y      : spec_y.1
                ...            = π₁ ⊚ (e ⊚ y)    : by tidy,
        have s1 : π₂ ⊚ (e ⊚ h) = π₂ ⊚ (e ⊚ y) :=
            calc π₂ ⊚ (e ⊚ h) = π₂ ⊚ e ⊚ h      : by tidy
            ...                = q₂                : eq.symm h0.2
            ...                = π₂ ⊚ e ⊚ y      : spec_y.2
            ...                = π₂ ⊚ (e ⊚ y)    : by tidy,
        have eh_ey : e ⊚ h = e ⊚ y :=
            jointly_mono A₁ A₂ P π₁ π₂ pr s0 s1,

        haveI m_e : mono e := equalizer_is_mono (f ⊚ π₁) (g ⊚ π₂) e eqauliz,
        exact left_cancel e (eq.symm eh_ey)
    end ⟩

variables {A₁ A₂ B : Type u}
variables (f : A₁ ⟶ B) (g : A₂ ⟶ B)

lemma equalizer_product_is_pullback :
    let P := A₁ × A₂ in
    let π₁ : P → A₁ := λ ab, ab.1 in
    let π₂ : P → A₂ := λ ab, ab.2 in
    let E := equalizer_set (f ∘ π₁) (g ∘ π₂) in
    let e := E ↪ P in

    is_pullback f g
        (π₁ ∘ e)
        (π₂ ∘ e)
    :=
    let P := A₁ × A₂ in
    let π₁ : P → A₁ := λ ab, ab.1 in
    let π₂ : P → A₂ := λ ab, ab.2 in
    let E := equalizer_set (f ∘ π₁) (g ∘ π₂) in
    let e : E → P := E ↪ P in
    ⟨ begin
        tidy
    end
    ,
    begin
        intros Q q₁ q₂ fq₁_gq₂,
        have eq := eqaulizer_set_is_equalizer (f ∘ π₁) (g ∘ π₂),
        have pr := cartesian_product_is_product A₁ A₂ Q q₁ q₂,
        let p : Q → P := some pr,
        have spec_p : q₁ = π₁ ∘ p ∧ q₂ = π₂ ∘ p := (some_spec pr).1,

        have eq_comp : f ∘ π₁ ∘ p = g ∘ π₂ ∘ p :=
            spec_p.2 ▸ (spec_p.1 ▸ fq₁_gq₂),

        let h : Q → E := some (eq.2 p eq_comp),
        have spec_h : p = e ∘ h := (some_spec (eq.2 p eq_comp)).1,
        use h,
        split,
        have h0 : q₁ = π₁ ∘ e ∘ h ∧ q₂ = π₂ ∘ e ∘ h :=
            ⟨
                by simp [spec_h , spec_p.1]
                ,
                by simp [spec_h , spec_p.2]
            ⟩ ,
        exact h0,
        assume (y : Q → E) (hy : q₁ = π₁ ∘ e ∘ y ∧ q₂ = π₂ ∘ e ∘ y),
        have s0 : π₁ ∘ e ∘ h = π₁ ∘ e ∘ y :=
                spec_h ▸ (spec_p.1 ▸ hy.1),
        have s1 : π₂ ∘ e ∘ h = π₂ ∘ e ∘ y :=
                spec_h ▸ (spec_p.2 ▸ hy.2),
        have eh_ey : e ∘ h = e ∘ y :=
            jointly_mono A₁ A₂ (A₁ × A₂) prod.fst prod.snd
                (cartesian_product_is_product A₁ A₂) s0 s1,

        have elements : ∀ q, y q = h q :=
            assume q,
            have e0 : (e ∘ y) q = (e ∘ h) q :=
                by rw eh_ey,
            (inj_inclusion P E) e0,
        exact funext elements

    end ⟩

end Pullback


import Mathlib
import Qpf.Util.Vec

universe u v

/-- A curried function of `n` arguments in `α`, resulting in `β`, i.e., `α → ... → α → β` -/
abbrev CurriedFun (α : Type u) (β : Type v) : Nat → Type (max u v)
  | 0   => PUnit.{u+1} → β
  | 1   => α → β
  | n+1 => α → CurriedFun α β n

/-- A curried type function of `n` arguments, i.e., `Type u → Type u → ... → Type v` -/
abbrev CurriedTypeFun : Nat → Type ((max u v) + 1)
  := CurriedFun (Type u) (Type v)

/-- An uncurried type function, all `n` arguments are collected into a single `TypeVec n`
    Note that all arguments live in the same universe, but the result may be in a different universe
-/
abbrev TypeFun (n : Nat) : Type ((max u v) + 1) :=
  TypeVec.{u} n → Type v

namespace TypeFun
  def reverseArgs : TypeFun n → TypeFun n :=
    fun v α => v <| Vec.reverse α

  @[simp]
  theorem reverseArgs_involution (F : TypeFun n) :
    F.reverseArgs.reverseArgs = F :=
  by
    simp only [reverseArgs, Vec.reverse_involution]

  def curriedAux : {n : Nat} → TypeFun n → CurriedTypeFun n
    | 0,    F => fun _ => F !![]
    | 1,    F => fun a => F !![a]
    | _+2,  F => fun a => curriedAux fun αs => F (αs ::: a)

  def curried (F : TypeFun n) : CurriedTypeFun n
    := curriedAux (F.reverseArgs)

  def ofCurriedAux : {n : Nat} → CurriedTypeFun n → TypeFun n
    | 0,    F, _ => F PUnit.unit
    | 1,    F, α => F (α 0)
    | n+2,  F, α => ofCurriedAux (F α.last) α.drop

  def ofCurried (F : CurriedTypeFun n) : TypeFun n
    := (ofCurriedAux F).reverseArgs

  @[simp]
  theorem curriedAux_ofCurriedAux_involution {F : CurriedTypeFun n} :
    curriedAux (ofCurriedAux F) = F :=
  by
    cases n
    case zero => simp [curriedAux, ofCurriedAux]
    case succ n => {
      induction n
      <;> simp [curriedAux, ofCurriedAux, Vec.append1]

      case succ _ ih => {
        funext a;
        simp[reverseArgs_involution]
        apply @ih (F a);
      }
    }

  @[simp]
  theorem curried_ofCurried_involution {F : CurriedTypeFun n} :
    curried (ofCurried F) = F :=
  by
    simp only [curried, ofCurried, reverseArgs_involution]
    apply curriedAux_ofCurriedAux_involution

  @[simp]
  theorem ofCurriedAux_curriedAux_involution {F : TypeFun n} :
    ofCurriedAux (curriedAux F) = F :=
  by
    cases n
    case zero =>
      funext x;
      simp [curriedAux, ofCurriedAux, Matrix.vecEmpty]
      congr
      funext i
      contradiction
    case succ n => {
      induction n;
      case zero => {
        funext x;
        simp [curriedAux, ofCurriedAux];
        apply congrArg;
        funext i;
        cases i;
        . simp [Vec.append1, OfNat.ofNat]
        . contradiction
      }

      case succ _ ih => {
        funext x;
        simp [ofCurriedAux, curriedAux];
        let F' := fun α => F (α ::: x.last);
        have : F x = F' x.drop;
        . simp
        rw [this]
        rw [@ih F']
      }
    }

  @[simp]
  theorem ofCurried_curried_involution {F : TypeFun n} :
    ofCurried (curried F) = F :=
  by
    simp only [ofCurried, curried, ofCurriedAux_curriedAux_involution]
    apply reverseArgs_involution
end TypeFun


import category_theory.preadditive.functor_category
import algebra.homology.additive
import algebra.homology.homological_complex
import algebra.category.Group.limits
import analysis.normed.group.SemiNormedGroup.kernels
import analysis.normed.group.SemiNormedGroup.completion

import facts

universe variables v u
noncomputable theory
open opposite category_theory
open_locale nnreal

/-!

# Systems of complexes of seminormed groups

In this file we define systems of complexes of seminormed groups,
as in of Definition 9.3 of [Analytic].

## Main declarations

* `system_of_complexes`: a system of complexes of seminormed groups. See Definition 4.1
  of the blueprint.
* `admissible`: such a system is *admissible* if all maps that occur in the system
    are norm-nonincreasing. See Definition 4.2 of the blueprint.
* `is_bounded_exact`: an exactness criterion for such systems, See Definition 4.3 of the
  blueprint. It asks for a suitable interplay between the norms and the algebraic properties
  of the system.
* `is_weak_bounded_exact` : another exactness criterion for such systems. See Definition 4.4
   of the blueprint.

## TODO

It seems a bit ridiculous that this file has to import `locally_constant.Vhat`.

-/

-- TODO: at some point we can abstract the following definition over `SemiNormedGroup` and `ℝ≥0`.
-- But I don't think that is relevant for this project.

/-- A system of complexes of seminormed groups, indexed by `ℝ≥0`.
See also Definition 9.3 of [Analytic]. -/
@[derive [category_theory.category, category_theory.preadditive]]
def system_of_complexes : Type* := ℝ≥0ᵒᵖ ⥤ (cochain_complex SemiNormedGroup ℕ)

-- instance : has_shift system_of_complexes := has_shift.mk $ (shift _).congr_right

variables {M M' N : system_of_complexes.{u}} (f : M ⟶ M') (g : M' ⟶ N)

instance : has_coe_to_fun system_of_complexes (λ C, ℝ≥0 → ℕ → SemiNormedGroup) :=
⟨λ C c i, (C.obj $ op c).X i⟩

/-- `f.apply c i` is application of the natural transformation `f`: $f_c^i : M_c^i ⟶ N_c^i$. -/
def quiver.hom.apply (f : M ⟶ N) {c : ℝ≥0} {i : ℕ} : M c i ⟶ N c i :=
(f.app (op c)).f i

instance hom_to_fun : has_coe_to_fun (M ⟶ N) (λ f, Π {c : ℝ≥0} {i : ℕ}, M c i → N c i) :=
⟨λ f {c} {i} x, f.apply x⟩

lemma system_of_complexes.hom_apply (f : M ⟶ N) {c : ℝ≥0} {i : ℕ} (x : M c i) : f x = f.apply x :=
rfl

lemma system_of_complexes.map_sub (f : M ⟶ N) {c i} (m m' : M c i) : f (m-m') = f m - f m' :=
map_sub ((f.app (op c)).f i) m m'

/-- `f.apply c i` is application of the natural isomorphism `f`: $f_c^i : M_c^i ≅ N_c^i$. -/
def category_theory.iso.apply (f : M ≅ N) {c : ℝ≥0} {i : ℕ} : M c i ≅ N c i :=
homological_complex.hom.iso_app (f.app (op c)) i

namespace system_of_complexes

variables (C C₁ C₂ : system_of_complexes.{u})

/-- `res` is the restriction map `C c' i ⟶ C c i` for a system of complexes `C`,
and nonnegative reals `c ≤ c'`. -/
def res {C : system_of_complexes} {c' c : ℝ≥0} {i : ℕ} [h : fact (c ≤ c')] : C c' i ⟶ C c i :=
(C.map (hom_of_le h.out).op).f i

variables {c₁ c₂ c₃ : ℝ≥0} (i j : ℕ)

@[simp] lemma res_comp_res (h₁ : fact (c₂ ≤ c₁)) (h₂ : fact (c₃ ≤ c₂)) :
  @res C _ _ i h₁ ≫ @res C _ _ i h₂ = @res C _ _ i ⟨h₂.out.trans h₁.out⟩ :=
begin
  have := (category_theory.functor.map_comp C (hom_of_le h₁.out).op (hom_of_le h₂.out).op),
  rw [← op_comp] at this,
  delta res,
  erw this,
  refl,
end

@[simp] lemma res_res (h₁ : fact (c₂ ≤ c₁)) (h₂ : fact (c₃ ≤ c₂)) (x : C c₁ i) :
  @res C _ _ i h₂ (@res C _ _ i h₁ x) = @res C _ _ i ⟨h₂.out.trans h₁.out⟩ x :=
by { rw ← (C.res_comp_res i h₁ h₂), refl }

/-- `C.d` is the differential `C c i ⟶ C c (i+1)` for a system of complexes `C`. -/
def d (C : system_of_complexes) {c : ℝ≥0} (i j : ℕ) : C c i ⟶ C c j :=
(C.obj $ op c).d i j

lemma d_eq_zero (c : ℝ≥0) (h : i + 1 ≠ j) : (C.d i j : C c i ⟶ C c j) = 0 :=
(C.obj $ op c).shape _ _ h

lemma d_eq_zero_apply (c : ℝ≥0) (h : i + 1 ≠ j) (x : C c i) : (C.d i j x) = 0 :=
by { rw [d_eq_zero C i j c h], refl }

@[simp] lemma d_self_apply (c : ℝ≥0) (x : C c i) : (C.d i i x) = 0 :=
d_eq_zero_apply _ _ _ _ i.succ_ne_self _

lemma d_comp_d (c : ℝ≥0) (i j k : ℕ) : C.d i j ≫ (C.d j k : C c j ⟶ _) = 0 :=
(C.obj $ op c).d_comp_d _ _ _

@[simp] lemma d_d (c : ℝ≥0) (i j k : ℕ) (x : C c i) :
  C.d j k (C.d i j x) = 0 :=
show ((C.d i j) ≫ C.d j k) x = 0, by { rw d_comp_d, refl }

lemma d_comp_res (h : fact (c₂ ≤ c₁)) :
  C.d i j ≫ @res C _ _ _ h = @res C _ _ _ _ ≫ C.d i j :=
((C.map (hom_of_le h.out).op).comm _ _).symm

lemma d_res (h : fact (c₂ ≤ c₁)) (x) :
  C.d i j (@res C _ _ _ _ x) = @res C _ _ _ h (C.d i j x) :=
show (@res C _ _ _ _ ≫ C.d i j) x = (C.d i j ≫ @res C _ _ _ h) x,
by rw d_comp_res

section iso

variables (ϕ : M ≅ N) (c : ℝ≥0) (i)

lemma apply_hom_eq_hom_apply : (ϕ.apply.hom : M c i ⟶ N c i) = ϕ.hom.apply := rfl

lemma apply_inv_eq_inv_apply : (ϕ.apply.inv : N c i ⟶ M c i) = ϕ.inv.apply := rfl

@[simp] lemma hom_apply_comp_inv_apply :
  (ϕ.hom.apply : M c i ⟶ N c i) ≫ ϕ.inv.apply = 𝟙 _ :=
by rw [← apply_hom_eq_hom_apply, ← apply_inv_eq_inv_apply, iso.hom_inv_id]

@[simp] lemma inv_apply_comp_hom_apply :
  (ϕ.inv.apply : N c i ⟶ M c i) ≫ ϕ.hom.apply = 𝟙 _ :=
by rw [← apply_hom_eq_hom_apply, ← apply_inv_eq_inv_apply, iso.inv_hom_id]

@[simp] lemma inv_apply_hom_apply (x : M c i) :
  ϕ.inv.apply (ϕ.hom.apply x) = x :=
show ((ϕ.hom.apply : M c i ⟶ N c i) ≫ ϕ.inv.apply) x = x,
by simp only [hom_apply_comp_inv_apply, coe_id, id.def]

@[simp] lemma hom_apply_inv_apply (x : N c i) :
  ϕ.hom (ϕ.inv x) = x :=
show ((ϕ.inv.apply : N c i ⟶ M c i) ≫ ϕ.hom.apply) x = x,
by simp only [inv_apply_comp_hom_apply, coe_id, id.def]

end iso

/-- Convenience definition:
The identity morphism of an object in the system of complexes
when it is given by different indices that are not
definitionally equal. -/
def congr {c c' : ℝ≥0} {i i' : ℕ} (hc : c = c') (hi : i = i') :
  C c i ⟶ C c' i' :=
eq_to_hom $ by { subst hc, subst hi }

variables (M M' N)

lemma d_apply (f : M ⟶ N) {c : ℝ≥0} {i j : ℕ} (m : M c i) :
  N.d i j (f m) = f (M.d i j m) :=
begin
  show (_ ≫ N.d i j) m = (M.d i j ≫ _) m,
  congr' 1,
  exact (f.app (op c)).comm i j
end

lemma res_comp_apply (f : M ⟶ N) (c c' : ℝ≥0) [h : fact (c ≤ c')] (i : ℕ) :
  @res M c' c i _ ≫ f.apply = f.apply ≫ res :=
congr_fun (congr_arg homological_complex.hom.f (f.naturality (hom_of_le h.out).op)) i

lemma res_apply (f : M ⟶ N) (c c' : ℝ≥0) [h : fact (c ≤ c')] {i : ℕ} (m : M c' i) :
  @res N c' c _ _ (f m) = f (res m) :=
show (f.apply ≫ (@res N c' c _ _)) m = (@res M c' c _ _ ≫ (f.apply)) m,
by rw res_comp_apply

/-- A system of complexes is *admissible*
if all the differentials and restriction maps are norm-nonincreasing.

See Definition 9.3 of [Analytic]. -/
structure admissible (C : system_of_complexes) : Prop :=
(d_norm_noninc' : ∀ c i j (h : i + 1 = j), (C.d i j : C c i ⟶ C c j).norm_noninc)
(res_norm_noninc : ∀ c' c i h, (@res C c' c i h).norm_noninc)

lemma admissible.d_norm_noninc (hC : C.admissible) (c : ℝ≥0) (i j : ℕ) :
  (C.d i j : C c i ⟶ _).norm_noninc :=
begin
  by_cases h : i + 1 = j,
  { exact hC.d_norm_noninc' c i j h },
  { rw C.d_eq_zero i j c h, intro v, simp }
end

variables {M M'}

lemma admissible_of_isometry {f : M ⟶ M'} (hadm : M'.admissible)
  (hiso : ∀ c i, @isometry (M c i) (M' c i) _ _ f.apply) :
  M.admissible :=
begin
  refine ⟨λ c i j h x, _, λ c' c i h x, _⟩,
  { rw [← (add_monoid_hom_class.isometry_iff_norm _).1 (hiso c i) _,
      ← (add_monoid_hom_class.isometry_iff_norm _).1 (hiso c j) _, ← system_of_complexes.hom_apply f,
      ← d_apply],
    exact hadm.d_norm_noninc _ _ _ _ _ },
  { rw [← (add_monoid_hom_class.isometry_iff_norm _).1 (hiso c i) _,
      ← (add_monoid_hom_class.isometry_iff_norm _).1 (hiso c' i) _, ← system_of_complexes.hom_apply f,
      ← system_of_complexes.hom_apply f, ← res_apply],
    exact hadm.res_norm_noninc _ _ _ _ _  }
end

variables (M M')

/-- `is_bounded_exact k K m c₀` is a predicate on systems of complexes.

A system of complexes `C` is `(k,K)`-exact in degrees `≤ m` for `c ≥ c₀`*
if the following condition is satisfied:
For all `c ≥ c₀` and all `x : C (k * c) i` with `i ≤ m` there is some `y : C c (i-1)`
(which is defined to be `0` when `i = 0`) such that `∥(C.res x) - (C.d y)∥ ≤ K * ∥C.d x∥`.

See Definition 9.3 of [Analytic] (which coalesces the roles of `k` and `K`).

Implementation details:
* Because we have a differential `d i j : C c i ⟶ C c j` for all `i` and `j`,
  and because `d 0 0 = 0` and `0 - 1 = 0` in Lean's natural numbers,
  we automatically take care of the parenthetical condition about `i = 0`.
* We phrase the condition in a somewhat roundabout way, as
  ```
  ∃ (i₀ j : ℕ) (hi₀ : i₀ = i - 1) (hj : i + 1 = j)
    (y : C c i₀), ∥res x - C.d _ _ y∥ ≤ K * ∥C.d i j x∥
  ```
  This is a hack around an inconvenience known as dependent type theory hell. -/
def is_bounded_exact
  (k K : ℝ≥0) (m : ℕ) [hk : fact (1 ≤ k)] (c₀ : ℝ≥0) : Prop :=
∀ c (hc : fact (c₀ ≤ c)) i (hi : i ≤ m) (x : C (k * c) i),
∃ (i₀ j : ℕ) (hi₀ : i₀ = i - 1) (hj : i + 1 = j)
  (y : C c i₀), ∥res x - C.d _ _ y∥ ≤ K * ∥C.d i j x∥

/-- Weak version of `is_bounded_exact`. -/
def is_weak_bounded_exact
  (k K : ℝ≥0) (m : ℕ) [hk : fact (1 ≤ k)] (c₀ : ℝ≥0) : Prop :=
∀ c (hc : fact (c₀ ≤ c)) i (hi : i ≤ m) (x : C (k * c) i) (ε : ℝ) (hε : 0 < ε),
∃ (i₀ j : ℕ) (hi₀ : i₀ = i - 1) (hj : i + 1 = j)
  (y : C c i₀), ∥res x - C.d _ _ y∥ ≤ K * ∥C.d i j x∥ + ε

namespace is_weak_bounded_exact

variables {C C₁ C₂}
variables {k k' K K' : ℝ≥0} {m m' : ℕ} {c₀ c₀' : ℝ≥0} [fact (1 ≤ k)] [fact (1 ≤ k')]

lemma of_le (hC : C.is_weak_bounded_exact k K m c₀) (hC_adm : C.admissible)
  (hk : fact (k ≤ k')) (hK : fact (K ≤ K')) (hm : m' ≤ m) (hc₀ : fact (c₀ ≤ c₀')) :
  C.is_weak_bounded_exact k' K' m' c₀' :=
begin
  intros c hc i hi x ε ε_pos,
  haveI : fact (k ≤ k') := hk,
  obtain ⟨i', j, hi', hj, y, hy⟩ := hC c ⟨hc₀.out.trans hc.out⟩ i (hi.trans hm) (res x) ε ε_pos,
  use [i', j, hi', hj, y],
  simp only [res_res] at hy,
  refine le_trans hy _,
  rw d_res,
  apply add_le_add_right,
  exact mul_le_mul hK.out (hC_adm.res_norm_noninc _ _ _ _ (C.d _ _ x))
    (norm_nonneg _) ((zero_le K).trans hK.out)
end

lemma of_iso (h : C₁.is_weak_bounded_exact k K m c₀) (f : C₁ ≅ C₂)
  (hf : ∀ c i, @isometry (C₁ c i) (C₂ c i) _ _ (f.hom.apply : C₁ c i ⟶ C₂ c i)) :
  C₂.is_weak_bounded_exact k K m c₀ :=
begin
  intros c hc i hi x ε hε,
  obtain ⟨i', j, hi', hj, y, hy⟩ := h c hc i hi (f.inv.apply x) ε hε,
  refine ⟨i', j, hi', hj, f.hom y, _⟩,
  calc  ∥res x - C₂.d _ _ (f.hom y)∥
      = ∥res x - f.hom (C₁.d _ _ y)∥ : by rw d_apply
  ... = ∥f.hom (f.inv (res x)) - f.hom (C₁.d _ _ y)∥ : by rw hom_apply_inv_apply
  ... = ∥f.hom (f.inv (res x) - C₁.d _ _ y)∥ : by congr ; exact (system_of_complexes.map_sub _ _ _).symm
  ... = ∥f.inv (res x) - C₁.d _ _ y∥ : normed_add_group_hom.norm_eq_of_isometry (hf _ _) _
  ... = ∥res (f.inv x) - C₁.d _ _ y∥ : by rw res_apply
  ... ≤ K * ∥C₁.d _ _ (f.inv x)∥ + ε : hy
  ... = K * ∥C₂.d _ _ x∥ + ε : _,
  congr' 2,
  calc  ∥C₁.d i j (f.inv x)∥
      = ∥f.inv (C₂.d i j x)∥ : by rw d_apply
  ... = ∥f.hom (f.inv (C₂.d _ _ x))∥ : (normed_add_group_hom.norm_eq_of_isometry (hf _ _) _).symm
  ... = ∥C₂.d _ _ x∥ : by rw hom_apply_inv_apply
end

lemma iff_of_iso (f : C₁ ≅ C₂)
  (hf : ∀ c i, @isometry (C₁ c i) (C₂ c i) _ _ (f.hom.apply : C₁ c i ⟶ C₂ c i)) :
  C₁.is_weak_bounded_exact k K m c₀ ↔ C₂.is_weak_bounded_exact k K m c₀ :=
begin
  refine ⟨λ h, h.of_iso f hf, λ h, h.of_iso f.symm _⟩,
  -- TODO: factor this out into a lemma
  intros c n,
  apply add_monoid_hom_class.isometry_of_norm,
  intro v,
  rw ← normed_add_group_hom.norm_eq_of_isometry (hf c n),
  simp only [←apply_hom_eq_hom_apply, ←apply_inv_eq_inv_apply, iso.symm_hom, iso.inv_hom_id_apply],
end

end is_weak_bounded_exact

namespace is_bounded_exact

variables {C C₁ C₂}
variables {k k' K K' : ℝ≥0} {m m' : ℕ} {c₀ c₀' : ℝ≥0} [fact (1 ≤ k)] [fact (1 ≤ k')]

lemma of_le (hC : C.is_bounded_exact k K m c₀)
  (hC_adm : C.admissible) (hk : k ≤ k') (hK : K ≤ K') (hm : m' ≤ m) (hc₀ : c₀ ≤ c₀') :
  C.is_bounded_exact k' K' m' c₀' :=
begin
  intros c hc i hi x,
  haveI : fact (k ≤ k') := ⟨hk⟩,
  obtain ⟨i', j, hi', hj, y, hy⟩ := hC c ⟨hc₀.trans hc.out⟩ i (hi.trans hm) (res x),
  use [i', j, hi', hj, y],
  simp only [res_res] at hy,
  refine le_trans hy _,
  rw d_res,
  exact mul_le_mul hK (hC_adm.res_norm_noninc _ _ _ _ (C.d _ _ x)) (norm_nonneg _) ((zero_le K).trans hK)
end

lemma of_iso (h : C₁.is_bounded_exact k K m c₀) (f : C₁ ≅ C₂)
  (hf : ∀ c i, @isometry (C₁ c i) (C₂ c i) _ _ (f.hom.apply : C₁ c i ⟶ C₂ c i)) :
  C₂.is_bounded_exact k K m c₀ :=
begin
  intros c hc i hi x,
  obtain ⟨i', j, hi', hj, y, hy⟩ := h c hc i hi (f.inv.apply x),
  refine ⟨i', j, hi', hj, f.hom y, _⟩,
  calc  ∥res x - C₂.d _ _ (f.hom y)∥
      = ∥res x - f.hom (C₁.d _ _ y)∥ : by rw d_apply
  ... = ∥f.hom (f.inv (res x)) - f.hom (C₁.d _ _ y)∥ : by rw hom_apply_inv_apply
  ... = ∥f.hom (f.inv (res x) - C₁.d _ _ y)∥ : by congr ; exact (system_of_complexes.map_sub _ _ _).symm
  ... = ∥f.inv (res x) - C₁.d _ _ y∥ : normed_add_group_hom.norm_eq_of_isometry (hf _ _) _
  ... = ∥res (f.inv x) - C₁.d _ _ y∥ : by rw res_apply
  ... ≤ K * ∥C₁.d _ _ (f.inv x)∥ : hy
  ... = K * ∥C₂.d _ _ x∥ : congr_arg _ _,
  calc  ∥C₁.d i j (f.inv x)∥
      = ∥f.inv (C₂.d i j x)∥ : by rw d_apply
  ... = ∥f.hom (f.inv (C₂.d _ _ x))∥ : (normed_add_group_hom.norm_eq_of_isometry (hf _ _) _).symm
  ... = ∥C₂.d _ _ x∥ : by rw hom_apply_inv_apply
end

end is_bounded_exact

namespace is_weak_bounded_exact

variables {C C₁ C₂}
variables {k k' K K' : ℝ≥0} {m m' : ℕ} {c₀ c₀' : ℝ≥0} [fact (1 ≤ k)] [fact (1 ≤ k')]

lemma to_exact (hC : C.is_weak_bounded_exact k K m c₀)
  [∀ c i, separated_space (C c i)]
  {δ : ℝ≥0} (hδ : 0 < δ)
  (H : ∀ c ≥ c₀, ∀ i ≤ m, ∀ x : C (k * c) i, ∀ j, i+1 = j →
    C.d _ j x = 0 → ∃ (i₀ : ℕ) (hi₀ : i₀ = i - 1) (y : C c i₀), res x = C.d _ _ y) :
  C.is_bounded_exact k (K + δ) m c₀ :=
begin
  intros c hc i hi x,
  by_cases hdx : C.d _ (i+1) x = 0,
  { rcases H c hc.out i hi x _ rfl hdx with ⟨i₀, hi₀, y, hy⟩,
    exact ⟨i₀, _, hi₀, rfl, y, by simp [hy, hdx]⟩ },
  { obtain ⟨i', j, hi', rfl, y, hy⟩ :=
      hC c hc _ hi x (δ*∥C.d _ (i+1) x∥) (mul_pos (by exact_mod_cast hδ) $ norm_pos_iff'.mpr hdx),
    refine ⟨i', _, hi', rfl, y, _⟩,
    have : ((K + δ : ℝ≥0) : ℝ) * ∥C.d _ (i+1) x∥
      = K * ∥C.d _ (i+1) x∥ + δ * ∥C.d _ (i+1) x∥, apply_mod_cast add_mul,
    rwa this },
end

end is_weak_bounded_exact
section quotient

open normed_add_group_hom

variables {M M'}

/-- The quotient of a system of complexes. -/
def is_quotient (f : M ⟶ M') : Prop :=
∀ c i, (f.apply : M c i ⟶ M' c i).is_quotient

-- The next three lemmas restate lemmas about normed_add_group_hom.is_quotient in terms of the coercion
-- of `M ⟶ M'` to functions.

lemma is_quotient.surjective {f : M ⟶ M'} (h : is_quotient f) {c i} (m' : M' c i) :
  ∃ m : M c i, f m = m' := (h c i).surjective m'

lemma is_quotient.norm_lift {f : M ⟶ M'} (h : is_quotient f) {ε : ℝ} (hε : 0 < ε) {c i}
  (n : M' c i) : ∃ (m : M c i), f m = n ∧ ∥m∥ < ∥n∥ + ε :=
(h c i).norm_lift hε n

lemma is_quotient.norm_le {f : M ⟶ M'} (h : is_quotient f) {c i} (m : M c i) : ∥f m∥ ≤ ∥m∥ :=
(h c i).norm_le _

/-- The quotient of an admissible system of complexes is admissible. -/
lemma admissible_of_quotient {f : M ⟶ M'} (hquot : is_quotient f) (hadm : M.admissible) :
  M'.admissible :=
begin
  split,
  { intros c i j h m',
    refine le_of_forall_pos_le_add _,
    intros ε hε,
    obtain ⟨m, hm : f m = m' ∧ ∥m∥ < ∥m'∥ + ε⟩ := hquot.norm_lift hε m',
    rw [← hm.1, d_apply],
    calc ∥f (M.d _ _ m)∥ ≤ ∥M.d _ _ m∥ : hquot.norm_le _
      ... ≤ ∥m∥ : hadm.d_norm_noninc _ _ _ _ m
      ... ≤ ∥m'∥ + ε : le_of_lt hm.2
      ... = ∥f m∥ + ε : by rw [hm.1] },
  { intros c' c i hc m',
    letI h := hc,
    refine le_of_forall_pos_le_add _,
    intros ε hε,
    obtain ⟨m, hm⟩ := hquot.norm_lift hε m',
    rw [← hm.1, res_apply],
    calc ∥f (res m)∥ ≤ ∥res m∥ : hquot.norm_le _
      ... ≤ ∥m∥ : hadm.res_norm_noninc c' c _ hc m
      ... ≤ ∥m'∥ + ε : le_of_lt hm.2
      ... = ∥f m∥ + ε : by rw [hm.1] }
end

end quotient

-- move me
instance SemiNormedGroup.forget₂_Ab : has_forget₂ SemiNormedGroup Ab :=
{ forget₂ :=
  { obj := λ V, AddCommGroup.of V,
    map := λ _ _ f, f.to_add_monoid_hom },
  forget_comp := by tidy }

instance SemiNormedGroup.forget₂_Ab_additive : (forget₂ SemiNormedGroup Ab).additive := {}

def to_Ab (C : system_of_complexes) : ℝ≥0ᵒᵖ ⥤ cochain_complex Ab ℕ :=
C ⋙ functor.map_homological_complex (forget₂ _ _) _

end system_of_complexes

-- #lint- only unused_arguments def_lemma doc_blame


import tactic
import for_mathlib -- gives us new theorem `alg_hom.eq_of_id`

/-!

# Formally smooth morphisms

A ring morphism `A →+* B` between commutative rings `A` and `B` is *formally smooth*
if for every surjective square-zero extension of A-algebras `R' →+* R`
(meaning that the kernel I satisties I² = 0)
the natural map Hom_A(B,R') → Hom_A(B,R) is surjective.

-/

-- Let A and B be commutative rings
variables {A B : Type} [comm_ring A] [comm_ring B]

/-- A ring homomorphism `f : A → B` is *formally smooth* if for every surjective square zero
morphism `φ : R → R'` of A-algebras, the natural map Hom_A(B,R') → Hom_A(B, R) is
a surjection. -/
def is_formally_smooth {A B : Type} [comm_ring A] [comm_ring B] (f : A →+* B) : Prop :=
-- First let's make B into an A-algebra in the obvious way via f
let h : algebra A B := f.to_algebra in
-- The condition is: For all A-algebras R and R'
∀ {{R R' : Type}} [comm_ring R] [comm_ring R'], by exactI
∀ [algebra A R] [algebra A R'], by exactI
-- and for all A-algebra morphisms φ : R' → R with square zero
∀ {φ : R' →ₐ[A] R} (hφ1 : ∀ r : R, ∃ r' : R', φ r' = r)
  (hφ2 : ∀ x y : R', φ x = 0 → φ y = 0 → x * y = 0),
-- composing with φ is a surjection Hom_A(B,R') → Hom_A(B, R)
function.surjective (φ.comp : (B →ₐ[A] R') → (B →ₐ[A] R))

lemma is_formally_smooth_id : is_formally_smooth (ring_hom.id A : A →+* A) :=
λ R R' _ _ _ _ φ _ _ ψ, by resetI; exact ⟨algebra.of_id A R', subsingleton.elim _ _⟩

variables {C : Type} [comm_ring C]

lemma is_formally_smooth_comp {φ : A →+* B} (hφ : is_formally_smooth φ)
  {ψ : B →+* C} (hψ : is_formally_smooth ψ) : is_formally_smooth (ψ.comp φ) :=
begin
  intros R R' _ _ _ _ f hf1 hf2 g,
  resetI,
  specialize hφ hf1 hf2,
  letI : algebra A B := φ.to_algebra,
  letI : algebra A C := (ψ.comp φ).to_algebra,
  let ψ' : B →ₐ[A] C :=
  { commutes' := λ r, rfl, -- definitional abuse!
    ..ψ },
  let ρ := g.comp ψ',
  unfold function.surjective at hφ,
  specialize hφ ρ,
  cases hφ with σ hσ,
  -- last four lines can be done  with
  --  obtain ⟨σ, hσ⟩ := hφ (g.comp ψ'),
  -- use σ to make R' into a B-algebra
  letI : algebra B R' := σ.to_ring_hom.to_algebra,
  letI : algebra B R := ρ.to_ring_hom.to_algebra,
  let f' : R' →ₐ[B] R :=
  { commutes' := begin
-- alternate proof:
--      rw alg_hom.ext_iff at hσ,
--      exact hσ,
      intro r,
      change _ = ρ r,
      rw ← hσ,
      refl,
    end,
    ..f.to_ring_hom, },
  have hf1' : ∀ (r : R), ∃ (r' : R'), f' r' = r,
  exact hf1,
  have hf2' : ∀ (x y : R'), f x = 0 → f y = 0 → x * y = 0,
  exact hf2,
  specialize hψ hf1' hf2',
  letI : algebra B C := ψ.to_algebra,
  let g' : C →ₐ[B] R :=
  { commutes' := begin
    intro,
    refl, end,
    ..g },
  obtain ⟨τ, hτ⟩ := hψ g',
  let τ' : C →ₐ[A] R' :=
  { commutes' := begin intro r,
      convert τ.commutes (φ r),
      suffices : algebra.of_id A R' = σ.comp (algebra.of_id A B),
      { rw alg_hom.ext_iff at this,
        apply this, },
      apply subsingleton.elim,
    end,
    ..τ, },
  use τ',
  ext,
  change _ = g' x,
  rw ← hτ,
  refl,
end


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

! This file was ported from Lean 3 source module category_theory.monad.monadicity
! leanprover-community/mathlib commit 4bd8c855d6ba8f0d5eefbf80c20fa00ee034dec9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Equalizers
import Mathbin.CategoryTheory.Limits.Shapes.Reflexive
import Mathbin.CategoryTheory.Monad.Coequalizer
import Mathbin.CategoryTheory.Monad.Limits

/-!
# Monadicity theorems

We prove monadicity theorems which can establish a given functor is monadic. In particular, we
show three versions of Beck's monadicity theorem, and the reflexive (crude) monadicity theorem:

`G` is a monadic right adjoint if it has a right adjoint, and:

* `D` has, `G` preserves and reflects `G`-split coequalizers, see
  `category_theory.monad.monadic_of_has_preserves_reflects_G_split_coequalizers`
* `G` creates `G`-split coequalizers, see
  `category_theory.monad.monadic_of_creates_G_split_coequalizers`
  (The converse of this is also shown, see
   `category_theory.monad.creates_G_split_coequalizers_of_monadic`)
* `D` has and `G` preserves `G`-split coequalizers, and `G` reflects isomorphisms, see
  `category_theory.monad.monadic_of_has_preserves_G_split_coequalizers_of_reflects_isomorphisms`
* `D` has and `G` preserves reflexive coequalizers, and `G` reflects isomorphisms, see
  `category_theory.monad.monadic_of_has_preserves_reflexive_coequalizers_of_reflects_isomorphisms`

## Tags

Beck, monadicity, descent

## TODO

Dualise to show comonadicity theorems.
-/

universe v₁ v₂ u₁ u₂

namespace CategoryTheory

namespace Monad

open Limits

noncomputable section

-- Hide the implementation details in this namespace.
namespace MonadicityInternal

section

-- We use these parameters and notations to simplify the statements of internal constructions
-- here.
parameter {C : Type u₁}{D : Type u₂}

parameter [Category.{v₁} C][Category.{v₁} D]

parameter {G : D ⥤ C}[IsRightAdjoint G]

-- mathport name: exprF
-- An unfortunate consequence of the local notation is that it is only recognised if there is an
-- extra space after the reference.
local notation "F" => leftAdjoint G

-- mathport name: expradj
local notation "adj" => Adjunction.ofRightAdjoint G

/-- The "main pair" for an algebra `(A, α)` is the pair of morphisms `(F α, ε_FA)`. It is always a
reflexive pair, and will be used to construct the left adjoint to the comparison functor and show it
is an equivalence.
-/
instance main_pair_reflexive (A : adj.toMonad.Algebra) :
    IsReflexivePair (F.map A.a) (adj.counit.app (F.obj A.A)) :=
  by
  apply is_reflexive_pair.mk' (F.map (adj.Unit.app _)) _ _
  · rw [← F.map_comp, ← F.map_id]
    exact congr_arg (fun _ => F.map _) A.unit
  · rw [adj.left_triangle_components]
    rfl
#align category_theory.monad.monadicity_internal.main_pair_reflexive CategoryTheory.Monad.MonadicityInternal.main_pair_reflexive

/-- The "main pair" for an algebra `(A, α)` is the pair of morphisms `(F α, ε_FA)`. It is always a
`G`-split pair, and will be used to construct the left adjoint to the comparison functor and show it
is an equivalence.
-/
instance main_pair_G_split (A : adj.toMonad.Algebra) :
    G.IsSplitPair (F.map A.a) (adj.counit.app (F.obj A.A))
    where splittable := ⟨_, _, ⟨beckSplitCoequalizer A⟩⟩
#align category_theory.monad.monadicity_internal.main_pair_G_split CategoryTheory.Monad.MonadicityInternal.main_pair_G_split

/-- The object function for the left adjoint to the comparison functor. -/
def comparisonLeftAdjointObj (A : adj.toMonad.Algebra)
    [HasCoequalizer (F.map A.a) (adj.counit.app _)] : D :=
  coequalizer (F.map A.a) (adj.counit.app _)
#align category_theory.monad.monadicity_internal.comparison_left_adjoint_obj CategoryTheory.Monad.MonadicityInternal.comparisonLeftAdjointObj

/--
We have a bijection of homsets which will be used to construct the left adjoint to the comparison
functor.
-/
@[simps]
def comparisonLeftAdjointHomEquiv (A : adj.toMonad.Algebra) (B : D)
    [HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] :
    (comparison_left_adjoint_obj A ⟶ B) ≃ (A ⟶ (comparison adj).obj B) :=
  calc
    (comparison_left_adjoint_obj A ⟶ B) ≃ { f : F.obj A.A ⟶ B // _ } :=
      Cofork.IsColimit.homIso (colimit.isColimit _) B
    _ ≃ { g : A.A ⟶ G.obj B // G.map (F.map g) ≫ G.map (adj.counit.app B) = A.a ≫ g } :=
      by
      refine' (adj.homEquiv _ _).subtypeEquiv _
      intro f
      rw [← (adj.homEquiv _ _).Injective.eq_iff, adjunction.hom_equiv_naturality_left,
        adj.homEquiv_unit, adj.homEquiv_unit, G.map_comp]
      dsimp
      rw [adj.right_triangle_components_assoc, ← G.map_comp, F.map_comp, category.assoc,
        adj.counit_naturality, adj.left_triangle_components_assoc]
      apply eq_comm
    _ ≃ (A ⟶ (comparison adj).obj B) :=
      { toFun := fun g =>
          { f := _
            h' := g.Prop }
        invFun := fun f => ⟨f.f, f.h⟩
        left_inv := fun g => by ext; rfl
        right_inv := fun f => by ext; rfl }

#align category_theory.monad.monadicity_internal.comparison_left_adjoint_hom_equiv CategoryTheory.Monad.MonadicityInternal.comparisonLeftAdjointHomEquiv

/-- Construct the adjunction to the comparison functor.
-/
def leftAdjointComparison
    [∀ A : adj.toMonad.Algebra, HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] :
    adj.toMonad.Algebra ⥤ D :=
  by
  refine'
    @adjunction.left_adjoint_of_equiv _ _ _ _ (comparison adj)
      (fun A => comparison_left_adjoint_obj A) (fun A B => _) _
  · apply comparison_left_adjoint_hom_equiv
  · intro A B B' g h
    ext1
    dsimp [comparison_left_adjoint_hom_equiv]
    rw [← adj.homEquiv_naturality_right, category.assoc]
#align category_theory.monad.monadicity_internal.left_adjoint_comparison CategoryTheory.Monad.MonadicityInternal.leftAdjointComparison

/-- Provided we have the appropriate coequalizers, we have an adjunction to the comparison functor.
-/
@[simps counit]
def comparisonAdjunction
    [∀ A : adj.toMonad.Algebra, HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] :
    left_adjoint_comparison ⊣ comparison adj :=
  Adjunction.adjunctionOfEquivLeft _ _
#align category_theory.monad.monadicity_internal.comparison_adjunction CategoryTheory.Monad.MonadicityInternal.comparisonAdjunction

theorem comparisonAdjunction_unit_f_aux
    [∀ A : adj.toMonad.Algebra, HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))]
    (A : adj.toMonad.Algebra) :
    (comparison_adjunction.Unit.app A).f =
      adj.homEquiv A.A _ (coequalizer.π (F.map A.a) (adj.counit.app (F.obj A.A))) :=
  congr_arg (adj.homEquiv _ _) (Category.comp_id _)
#align category_theory.monad.monadicity_internal.comparison_adjunction_unit_f_aux CategoryTheory.Monad.MonadicityInternal.comparisonAdjunction_unit_f_aux

/-- This is a cofork which is helpful for establishing monadicity: the morphism from the Beck
coequalizer to this cofork is the unit for the adjunction on the comparison functor.
-/
@[simps pt]
def unitCofork (A : adj.toMonad.Algebra) [HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] :
    Cofork (G.map (F.map A.a)) (G.map (adj.counit.app (F.obj A.A))) :=
  Cofork.ofπ (G.map (coequalizer.π (F.map A.a) (adj.counit.app (F.obj A.A))))
    (by
      change _ = G.map _ ≫ _
      rw [← G.map_comp, coequalizer.condition, G.map_comp])
#align category_theory.monad.monadicity_internal.unit_cofork CategoryTheory.Monad.MonadicityInternal.unitCofork

@[simp]
theorem unitCofork_π (A : adj.toMonad.Algebra)
    [HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] :
    (unit_cofork A).π = G.map (coequalizer.π (F.map A.a) (adj.counit.app (F.obj A.A))) :=
  rfl
#align category_theory.monad.monadicity_internal.unit_cofork_π CategoryTheory.Monad.MonadicityInternal.unitCofork_π

theorem comparisonAdjunction_unit_f
    [∀ A : adj.toMonad.Algebra, HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))]
    (A : adj.toMonad.Algebra) :
    (comparison_adjunction.Unit.app A).f = (beckCoequalizer A).desc (unit_cofork A) :=
  by
  apply limits.cofork.is_colimit.hom_ext (beck_coequalizer A)
  rw [cofork.is_colimit.π_desc]
  dsimp only [beck_cofork_π, unit_cofork_π]
  rw [comparison_adjunction_unit_f_aux, ← adj.homEquiv_naturality_left A.a, coequalizer.condition,
    adj.homEquiv_naturality_right, adj.homEquiv_unit, category.assoc]
  apply adj.right_triangle_components_assoc
#align category_theory.monad.monadicity_internal.comparison_adjunction_unit_f CategoryTheory.Monad.MonadicityInternal.comparisonAdjunction_unit_f

/-- The cofork which describes the counit of the adjunction: the morphism from the coequalizer of
this pair to this morphism is the counit.
-/
@[simps]
def counitCofork (B : D) :
    Cofork (F.map (G.map (adj.counit.app B))) (adj.counit.app (F.obj (G.obj B))) :=
  Cofork.ofπ (adj.counit.app B) (adj.counit_naturality _)
#align category_theory.monad.monadicity_internal.counit_cofork CategoryTheory.Monad.MonadicityInternal.counitCofork

/-- The unit cofork is a colimit provided `G` preserves it.  -/
def unitColimitOfPreservesCoequalizer (A : adj.toMonad.Algebra)
    [HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))]
    [PreservesColimit (parallelPair (F.map A.a) (adj.counit.app (F.obj A.A))) G] :
    IsColimit (unit_cofork A) :=
  isColimitOfHasCoequalizerOfPreservesColimit G _ _
#align category_theory.monad.monadicity_internal.unit_colimit_of_preserves_coequalizer CategoryTheory.Monad.MonadicityInternal.unitColimitOfPreservesCoequalizer

/-- The counit cofork is a colimit provided `G` reflects it. -/
def counitCoequalizerOfReflectsCoequalizer (B : D)
    [ReflectsColimit
        (parallelPair (F.map (G.map (adj.counit.app B))) (adj.counit.app (F.obj (G.obj B)))) G] :
    IsColimit (counit_cofork B) :=
  isColimitOfIsColimitCoforkMap G _ (beckCoequalizer ((comparison adj).obj B))
#align category_theory.monad.monadicity_internal.counit_coequalizer_of_reflects_coequalizer CategoryTheory.Monad.MonadicityInternal.counitCoequalizerOfReflectsCoequalizer

theorem comparisonAdjunction_counit_app
    [∀ A : adj.toMonad.Algebra, HasCoequalizer (F.map A.a) (adj.counit.app (F.obj A.A))] (B : D) :
    comparison_adjunction.counit.app B = colimit.desc _ (counit_cofork B) :=
  by
  apply coequalizer.hom_ext
  change
    coequalizer.π _ _ ≫ coequalizer.desc ((adj.homEquiv _ B).symm (𝟙 _)) _ =
      coequalizer.π _ _ ≫ coequalizer.desc _ _
  simp
#align category_theory.monad.monadicity_internal.comparison_adjunction_counit_app CategoryTheory.Monad.MonadicityInternal.comparisonAdjunction_counit_app

end

end MonadicityInternal

open CategoryTheory.Adjunction

open MonadicityInternal

variable {C : Type u₁} {D : Type u₂}

variable [Category.{v₁} C] [Category.{v₁} D]

variable (G : D ⥤ C)

/--
If `G` is monadic, it creates colimits of `G`-split pairs. This is the "boring" direction of Beck's
monadicity theorem, the converse is given in `monadic_of_creates_G_split_coequalizers`.
-/
def createsGSplitCoequalizersOfMonadic [MonadicRightAdjoint G] ⦃A B⦄ (f g : A ⟶ B)
    [G.IsSplitPair f g] : CreatesColimit (parallelPair f g) G :=
  by
  apply monadic_creates_colimit_of_preserves_colimit _ _
  infer_instance
  · apply preserves_colimit_of_iso_diagram _ (diagramIsoParallelPair.{v₁} _).symm
    dsimp
    infer_instance
  · apply preserves_colimit_of_iso_diagram _ (diagramIsoParallelPair.{v₁} _).symm
    dsimp
    infer_instance
#align category_theory.monad.creates_G_split_coequalizers_of_monadic CategoryTheory.Monad.createsGSplitCoequalizersOfMonadic

variable [IsRightAdjoint G]

section BeckMonadicity

/-- To show `G` is a monadic right adjoint, we can show it preserves and reflects `G`-split
coequalizers, and `C` has them.
-/
def monadicOfHasPreservesReflectsGSplitCoequalizers
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], HasCoequalizer f g]
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], PreservesColimit (parallelPair f g) G]
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], ReflectsColimit (parallelPair f g) G] :
    MonadicRightAdjoint G :=
  by
  let L : (adjunction.of_right_adjoint G).toMonad.Algebra ⥤ D := left_adjoint_comparison
  letI i : is_right_adjoint (comparison (of_right_adjoint G)) := ⟨_, comparison_adjunction⟩
  constructor
  let this :
    ∀ X : (of_right_adjoint G).toMonad.Algebra,
      is_iso ((of_right_adjoint (comparison (of_right_adjoint G))).Unit.app X) :=
    by
    intro X
    apply is_iso_of_reflects_iso _ (monad.forget (of_right_adjoint G).toMonad)
    · change is_iso (comparison_adjunction.unit.app X).f
      rw [comparison_adjunction_unit_f]
      change
        is_iso
          (is_colimit.cocone_point_unique_up_to_iso (beck_coequalizer X)
              (unit_colimit_of_preserves_coequalizer X)).Hom
      refine' is_iso.of_iso (is_colimit.cocone_point_unique_up_to_iso _ _)
  let this : ∀ Y : D, is_iso ((of_right_adjoint (comparison (of_right_adjoint G))).counit.app Y) :=
    by
    intro Y
    change is_iso (comparison_adjunction.counit.app Y)
    rw [comparison_adjunction_counit_app]
    change is_iso (is_colimit.cocone_point_unique_up_to_iso _ _).Hom
    infer_instance
    apply counit_coequalizer_of_reflects_coequalizer _
    letI :
      G.is_split_pair ((left_adjoint G).map (G.map ((adjunction.of_right_adjoint G).counit.app Y)))
        ((adjunction.of_right_adjoint G).counit.app ((left_adjoint G).obj (G.obj Y))) :=
      monadicity_internal.main_pair_G_split ((comparison (adjunction.of_right_adjoint G)).obj Y)
    infer_instance
  exact adjunction.is_right_adjoint_to_is_equivalence
#align category_theory.monad.monadic_of_has_preserves_reflects_G_split_coequalizers CategoryTheory.Monad.monadicOfHasPreservesReflectsGSplitCoequalizers

/--
Beck's monadicity theorem. If `G` has a right adjoint and creates coequalizers of `G`-split pairs,
then it is monadic.
This is the converse of `creates_G_split_of_monadic`.
-/
def monadicOfCreatesGSplitCoequalizers
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], CreatesColimit (parallelPair f g) G] :
    MonadicRightAdjoint G :=
  by
  let this : ∀ ⦃A B⦄ (f g : A ⟶ B) [G.is_split_pair f g], has_colimit (parallel_pair f g ⋙ G) :=
    by
    intro A B f g i
    apply has_colimit_of_iso (diagramIsoParallelPair.{v₁} _)
    change has_coequalizer (G.map f) (G.map g)
    infer_instance
  apply monadic_of_has_preserves_reflects_G_split_coequalizers _
  · infer_instance
  · intro A B f g i
    apply has_colimit_of_created (parallel_pair f g) G
  · intro A B f g i
    infer_instance
  · intro A B f g i
    infer_instance
#align category_theory.monad.monadic_of_creates_G_split_coequalizers CategoryTheory.Monad.monadicOfCreatesGSplitCoequalizers

/-- An alternate version of Beck's monadicity theorem. If `G` reflects isomorphisms, preserves
coequalizers of `G`-split pairs and `C` has coequalizers of `G`-split pairs, then it is monadic.
-/
def monadicOfHasPreservesGSplitCoequalizersOfReflectsIsomorphisms [ReflectsIsomorphisms G]
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], HasCoequalizer f g]
    [∀ ⦃A B⦄ (f g : A ⟶ B) [G.IsSplitPair f g], PreservesColimit (parallelPair f g) G] :
    MonadicRightAdjoint G :=
  by
  apply monadic_of_has_preserves_reflects_G_split_coequalizers _
  · infer_instance
  · assumption
  · assumption
  · intro A B f g i
    apply reflects_colimit_of_reflects_isomorphisms
#align category_theory.monad.monadic_of_has_preserves_G_split_coequalizers_of_reflects_isomorphisms CategoryTheory.Monad.monadicOfHasPreservesGSplitCoequalizersOfReflectsIsomorphisms

end BeckMonadicity

section ReflexiveMonadicity

variable [HasReflexiveCoequalizers D] [ReflectsIsomorphisms G]

variable [∀ ⦃A B⦄ (f g : A ⟶ B) [IsReflexivePair f g], PreservesColimit (parallelPair f g) G]

/-- Reflexive (crude) monadicity theorem. If `G` has a right adjoint, `D` has and `G` preserves
reflexive coequalizers and `G` reflects isomorphisms, then `G` is monadic.
-/
def monadicOfHasPreservesReflexiveCoequalizersOfReflectsIsomorphisms : MonadicRightAdjoint G :=
  by
  let L : (adjunction.of_right_adjoint G).toMonad.Algebra ⥤ D := left_adjoint_comparison
  letI i : is_right_adjoint (comparison (adjunction.of_right_adjoint G)) :=
    ⟨_, comparison_adjunction⟩
  constructor
  let this :
    ∀ X : (adjunction.of_right_adjoint G).toMonad.Algebra,
      is_iso
        ((adjunction.of_right_adjoint (comparison (adjunction.of_right_adjoint G))).Unit.app X) :=
    by
    intro X
    apply is_iso_of_reflects_iso _ (monad.forget (adjunction.of_right_adjoint G).toMonad)
    · change is_iso (comparison_adjunction.unit.app X).f
      rw [comparison_adjunction_unit_f]
      change
        is_iso
          (is_colimit.cocone_point_unique_up_to_iso (beck_coequalizer X)
              (unit_colimit_of_preserves_coequalizer X)).Hom
      apply is_iso.of_iso (is_colimit.cocone_point_unique_up_to_iso _ _)
  let this :
    ∀ Y : D,
      is_iso ((of_right_adjoint (comparison (adjunction.of_right_adjoint G))).counit.app Y) :=
    by
    intro Y
    change is_iso (comparison_adjunction.counit.app Y)
    rw [comparison_adjunction_counit_app]
    change is_iso (is_colimit.cocone_point_unique_up_to_iso _ _).Hom
    infer_instance
    apply counit_coequalizer_of_reflects_coequalizer _
    apply reflects_colimit_of_reflects_isomorphisms
  exact adjunction.is_right_adjoint_to_is_equivalence
#align category_theory.monad.monadic_of_has_preserves_reflexive_coequalizers_of_reflects_isomorphisms CategoryTheory.Monad.monadicOfHasPreservesReflexiveCoequalizersOfReflectsIsomorphisms

end ReflexiveMonadicity

end Monad

end CategoryTheory


import .expr_base
import ...phys.time.time

namespace lang.time

universes u
variables
  (K : Type u) [field K] [inhabited K]
  {f : fm K TIME} {sp : spc K f}

/-
Duration
-/
structure duration_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

/-
Time
-/
structure time_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

mutual inductive duration_expr, time_expr {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)
with duration_expr : Type u
| lit (v : duration sp) : duration_expr
| var (v : duration_var sp) : duration_expr
| add_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| neg_dur (d : duration_expr) : duration_expr
| sub_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| sub_time_time (t1 : time_expr) (t2 : time_expr) : duration_expr
| smul_dur (k : K) (d : duration_expr) : duration_expr
with time_expr : Type u
| lit (p : time sp) : time_expr
| var (v : time_var sp) : time_expr
| add_dur_time (d : duration_expr) (t : time_expr) : time_expr

abbreviation duration_env {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) :=
  duration_var sp → duration sp

abbreviation duration_eval {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  duration_env sp → duration_expr sp → duration sp

abbreviation time_env {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  time_var sp → time sp

abbreviation time_eval {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  time_env sp → time_expr sp → time sp

/-
ANDREW:

FUNCTION_NAME' (added ') is the suggested implementation version discussed earlier.

-/

def add_dur_expr_dur_expr (v1 v2 : duration_expr sp) : duration_expr sp :=
  duration_expr.add_dur_dur v1 v2
/-
FROM TUESDAY - REMOVE SOON

def add_dur_expr_dur_expr' {ev : duration_env sp} (v1 v2 : duration_expr sp) : duration_expr sp :=
  begin
    cases v1,
    {
      cases v2,
      {
        exact (duration_expr.lit (v1 +ᵥ v2))
      },
      {
        exact (duration_expr.lit ((ev v2) +ᵥ v1))
      }
    },
    {
      cases v2,
      {
        exact (duration_expr.lit ((ev v1) +ᵥ v2))
      },
      {
        exact (duration_expr.lit ((ev v1) +ᵥ (ev v2)))
      }
    }

  end
def smul_dur_expr' {ev : duration_env sp} (k : K) (v : duration_expr sp) : duration_expr sp :=
  begin
    intros,
    induction v,
    case duration_expr.lit : l {
      exact duration_expr.lit(k•l)
    },
    case duration_expr.var : v {
      exact duration_expr.lit(ev v)
    }

  end-/
def smul_dur_expr (k : K) (v : duration_expr sp) : duration_expr sp :=
    duration_expr.smul_dur k v

def neg_dur_expr (v : duration_expr sp) : duration_expr sp :=
    duration_expr.neg_dur v
/-
def neg_dur_expr' {ev : duration_env sp} (v : duration_expr sp) : duration_expr sp :=
begin
    intros,
    induction v,
    case duration_expr.lit : l {
      exact duration_expr.lit(-l)
    },
    case duration_expr.var : v {
      exact duration_expr.lit(-ev v)
    }

end
-/
def sub_dur_expr_dur_expr (v1 v2 : duration_expr sp) : duration_expr sp :=    -- v1-v2
    duration_expr.sub_dur_dur v1 v2
/-
def sub_dur_expr_dur_expr' {ev : duration_env sp} (v1 v2 : duration_expr sp) : duration_expr sp :=    -- v1-v2
begin
    intros,
    cases v1,
    {
      cases v2,
      {
        exact (duration_expr.lit (v1 -ᵥ v2))
      },
      {
        exact (duration_expr.lit (v1 -ᵥ ev v2))
      }
    },
    {
      cases v2,
      {
        exact (duration_expr.lit ((ev v1) -ᵥ v2))
      },
      {
        exact (duration_expr.lit ((ev v1) -ᵥ (ev v2)))
      }
    }

end-/
-- See unframed file for template for proving vector_space

instance has_add_dur_expr : has_add (duration_expr sp) := ⟨ add_dur_expr_dur_expr K ⟩
lemma add_assoc_dur_expr : ∀ a b c : duration_expr sp, a + b + c = a + (b + c) := sorry
instance add_semigroup_dur_expr : add_semigroup (duration_expr sp) := ⟨ add_dur_expr_dur_expr K, add_assoc_dur_expr K⟩

def dur_expr_zero  := duration_expr.lit (mk_duration sp 0)
instance has_zero_dur_expr : has_zero (duration_expr sp) := ⟨dur_expr_zero K⟩

lemma zero_add_dur_expr : ∀ a : duration_expr sp, 0 + a = a := sorry
lemma add_zero_dur_expr : ∀ a : duration_expr sp, a + 0 = a := sorry
instance add_monoid_dur_expr : add_monoid (duration_expr sp) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    -- has_zero
    dur_expr_zero K,
    -- new structure
    @zero_add_dur_expr K _ _ f sp,
    add_zero_dur_expr K
⟩

instance has_neg_dur_expr : has_neg (duration_expr sp) := ⟨neg_dur_expr K⟩
instance has_sub_dur_expr : has_sub (duration_expr sp) := ⟨ sub_dur_expr_dur_expr K⟩
lemma sub_eq_add_neg_dur_expr : ∀ a b : duration_expr sp, a - b = a + -b := sorry
instance sub_neg_monoid_dur_expr : sub_neg_monoid (duration_expr sp) := ⟨
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K,
    zero_add_dur_expr K,
    add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,                                                       -- new
⟩

lemma add_left_neg_dur_expr : ∀ a : duration_expr sp, -a + a = 0 := sorry
instance : add_group (duration_expr sp) := ⟨
    -- sub_neg_monoid
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K, zero_add_dur_expr K, add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,
    -- new
    add_left_neg_dur_expr K,
⟩

lemma add_comm_dur_expr : ∀ a b : duration_expr sp, a + b = b + a := sorry
instance add_comm_semigroup_dur_expr : add_comm_semigroup (duration_expr sp) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    add_comm_dur_expr K,
⟩

instance add_comm_monoid_dur_expr : add_comm_monoid (duration_expr sp) := ⟨
-- add_monoid
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    -- has_zero
    dur_expr_zero K,
    -- new structure
    zero_add_dur_expr K,
    add_zero_dur_expr K,
-- add_comm_semigroup (minus repeats)
    add_comm_dur_expr K,
⟩

instance has_scalar_dur_expr : has_scalar K (duration_expr sp) := ⟨
smul_dur_expr K,
⟩

lemma one_smul_dur_expr : ∀ b : duration_expr sp, (1 : K) • b = b := sorry
lemma mul_smul_dur_expr : ∀ (x y : K) (b : duration_expr sp), (x * y) • b = x • y • b := sorry
instance mul_action_dur_expr : mul_action K (duration_expr sp) := ⟨
one_smul_dur_expr K,
mul_smul_dur_expr K,
⟩

lemma smul_add_dur_expr : ∀(r : K) (x y : duration_expr sp), r • (x + y) = r • x + r • y := sorry
lemma smul_zero_dur_expr : ∀(r : K), r • (0 : duration_expr sp) = 0 := sorry
instance distrib_mul_action_K_dur_exprKx : distrib_mul_action K (duration_expr sp) := ⟨
smul_add_dur_expr K,
smul_zero_dur_expr K,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_dur_expr : ∀ (a b : K) (x : duration_expr sp), (a + b) • x = a • x + b • x := sorry
lemma zero_smul_dur_expr : ∀ (x : duration_expr sp), (0 : K) • x = 0 := sorry
instance semimodule_K_durationK : semimodule K (duration_expr sp) := ⟨ add_smul_dur_expr K, zero_smul_dur_expr  K⟩

instance add_comm_group_dur_expr : add_comm_group (duration_expr sp) := ⟨
-- add_group
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K, zero_add_dur_expr K, add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,
    add_left_neg_dur_expr K,
-- commutativity
    add_comm_dur_expr K,
⟩

instance : vector_space K (duration_expr sp) := sorry

/-
    ********************
    *** Affine space ***
    ********************
-/

/-
Affine operations
-/
instance : has_add (duration_expr sp) := ⟨add_dur_expr_dur_expr K⟩
instance : has_zero (duration_expr sp) := ⟨dur_expr_zero K⟩
instance : has_neg (duration_expr sp) := ⟨neg_dur_expr K⟩

/-
Lemmas needed to implement affine space API
-/
/-
kernel failed to type check declaration 'sub_time_expr_time_expr' this is usually due to a
buggy tactic or a bug in the builtin elaborator

ANDREW - THIS LOOKS VERY BAD!
-/

def sub_time_expr_time_expr {f : fm K TIME} {sp : spc K f } (p1 p2 : time_expr sp) : duration_expr sp :=
    sorry--duration_expr.sub_time_time p1 p2
def add_time_expr_dur_expr {f : fm K TIME} {sp : spc K f } (p : time_expr sp) (v : duration_expr sp) : time_expr sp :=
    time_expr.add_dur_time v p
def add_dur_expr_time_expr {f : fm K TIME} {sp : spc K f } (v : duration_expr sp) (p : time_expr sp) : time_expr sp :=
    time_expr.add_dur_time v p

def aff_dur_expr_group_action : duration_expr sp → time_expr sp → time_expr sp := add_dur_expr_time_expr K
instance : has_vadd (duration_expr sp) (time_expr sp) := ⟨aff_dur_expr_group_action K⟩

lemma zero_dur_expr_vadd'_a1 : ∀ p : time_expr sp, (0 : duration_expr sp) +ᵥ p = p := sorry
lemma dur_expr_add_assoc'_a1 : ∀ (g1 g2 : duration_expr sp) (p : time_expr sp), g1 +ᵥ (g2 +ᵥ p) = (g1 + g2) +ᵥ p := sorry
instance dur_expr_add_action: add_action (duration_expr sp) (time_expr sp) :=
⟨ aff_dur_expr_group_action K, zero_dur_expr_vadd'_a1 K, dur_expr_add_assoc'_a1  K⟩

def aff_time_expr_group_sub : time_expr sp → time_expr sp → duration_expr sp := sub_time_expr_time_expr K
instance time_expr_has_vsub : has_vsub (duration_expr sp) (time_expr sp) := ⟨ aff_time_expr_group_sub K ⟩

instance : nonempty (time_expr sp) := ⟨time_expr.lit (mk_time sp  0)⟩

lemma time_expr_vsub_vadd_a1 : ∀ (p1 p2 : (time_expr sp)), (p1 -ᵥ p2) +ᵥ p2 = p1 := sorry
lemma time_expr_vadd_vsub_a1 : ∀ (g : duration_expr sp) (p : time_expr sp), g +ᵥ p -ᵥ p = g := sorry
instance aff_time_expr_torsor : add_torsor (duration_expr sp) (time_expr sp) :=
⟨
    aff_dur_expr_group_action K,
    zero_dur_expr_vadd'_a1 K,    -- add_action
    dur_expr_add_assoc'_a1 K,   -- add_action
    aff_time_expr_group_sub K,    -- has_vsub
    time_expr_vsub_vadd_a1 K,     -- add_torsor
    time_expr_vadd_vsub_a1 K,     -- add_torsor
⟩

/-
Transform
-/
structure transform_var {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) extends var

inductive transform_expr {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) : Type u
| lit (p : time_transform sp1 sp2) : transform_expr
| var (v : transform_var sp1 sp2) : transform_expr

abbreviation transform_env {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2)  :=
  transform_var sp1 sp2 → time_transform sp1 sp2

abbreviation transform_eval  {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) :=
  transform_env sp1 sp2 → transform_expr sp1 sp2 → time_transform sp1 sp2

/-
We need a notation of a space
expression, rooted at TIME but
enabling the imposition of any
affine coordinatization on it,
these rooted at TIME.std_frame.
Thus we also need a notation of
frames.
-/

/-
TIME
std_space [TIME]
FRAME [ TIME ], STD_FRAME [ TIME ]
SPACE [ FRAME [ TIME ] ]
Point_lit [acspace] coord
Duration_lit [acspace] coord
Point_var [acspace] pvar
Duration_var [acspace] dvar

+  : d s -> d s -> d s
•  : K -> d s -> d s
+ᵥ : d s -> t s -> t s
-ᵥ : t s -> t s -> d s

Here s is an affine coordinate
space on TIME. Otherwise we've
got time points and durations,
within, but not across, spaces.
-/

/-
Overall environment

--omitting transforms from environment for now, which will make
--env.env, cmd, and etc. , even more complicated in terms of types
--TODO: Go ahead and complete the environment. Thanks! --Kevin
-/

variables {f2 : fm K TIME} (sp2 : spc K f2)

structure env {K : Type u} [field K] [inhabited K]
        {f : fm K TIME} (sp : spc K f) {f2 : fm K TIME} {sp2 : spc K f2} :=
  (d : duration_env sp )
  (t : time_env sp )
  (tr : transform_env sp sp2)

#check sp.tr sp2

open time

def env.init : env sp :=
  ⟨
    (λv, ⟨mk_vectr sp 1⟩),
    (λv, ⟨mk_point sp 0⟩),
    (λv, sp.time_tr sp2)
  ⟩

structure eval {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) {f2 : fm K TIME} {sp2 : spc K f2} :=
  (d : duration_eval sp )
  (t : time_eval sp )
  (tr : transform_eval sp sp2)

def eval.init : eval sp :=
  ⟨
    (λenv_,λexpr_, ⟨mk_vectr sp 1⟩),
    (λenv_,λexpr_, ⟨mk_point sp 0⟩),
    (λenv_,λexpr_, sp.time_tr sp2),
  ⟩
end lang.time


import .basic
open pfun topological_space set
noncomputable theory
universes u v w

variables {k : ℕ∞} {E : euclidean_space.{u}}

/- topological manifolds -/
structure chart (X : Top) (E : euclidean_space) :=
  (iso : X ≃ₜ. E.to_Top)
  (h1 : is_open iso.to_fun.dom)
  (h2 : is_open iso.inv_fun.dom)

namespace chart
variable {X : Top}
def to_fun (c : chart X E) : X →. E := c.iso.to_fun
def inv_fun (c : chart X E) : E →. X := c.iso.inv_fun
def domain (c : chart X E) : set X := dom c.to_fun
def codomain (c : chart X E) : set E := dom c.inv_fun

def restrict {s : set X} (hs : is_open s) (c : chart X E) : chart (X.restrict s) E :=
⟨(phomeo.restrict_phomeo s).trans c.iso, omitted, omitted⟩

end chart

def compatible_charts {X : Top} (k : ℕ∞) (c₁ c₂ : chart X E) : Prop :=
is_smooth k (c₂.to_fun ∘. c₁.inv_fun) ∧
is_smooth k (c₁.to_fun ∘. c₂.inv_fun)

structure topological_manifold (E : euclidean_space) :=
  (carrier : Top)
  (struct2 : t2_space carrier)
  (struct3 : second_countable_topology carrier)
  (charts : set (chart carrier E))
  (cover : ⋃₀ (chart.domain '' charts) = univ)

namespace topological_manifold
instance : has_coe (topological_manifold E) Top :=
⟨topological_manifold.carrier⟩

def restrict (X : topological_manifold E) {s : set X} (hs : is_open s) :
  topological_manifold E :=
⟨X.carrier.restrict s, omitted, omitted, chart.restrict hs '' X.charts, omitted⟩

end topological_manifold

structure differentiable_manifold (k : ℕ∞) (E : euclidean_space) extends topological_manifold E :=
  (compatible : ∀{{c₁ c₂}}, c₁ ∈ charts → c₂ ∈ charts → compatible_charts k c₁ c₂)

namespace euclidean_space

  def to_differentiable_manifold (E : euclidean_space) (k : ℕ∞) : differentiable_manifold k E :=
  ⟨⟨E.to_Top, omitted, omitted, {⟨phomeo.rfl, is_open_univ, is_open_univ⟩}, omitted⟩, omitted⟩

end euclidean_space

namespace differentiable_manifold

instance : has_coe (differentiable_manifold k E) Top :=
⟨λX, X.to_topological_manifold.carrier⟩

/- a maximal atlas is a set of charts which is compatible with all charts of X -/
def max_atlas (X : differentiable_manifold k E) : set (chart X.carrier E) :=
{ c | ∀c' ∈ X.charts, compatible_charts k c c' }

/- examples and constructions -/
def restrict (X : differentiable_manifold k E) {s : set X} (hs : is_open s) :
  differentiable_manifold k E :=
⟨X.to_topological_manifold.restrict hs, omitted⟩

def sphere (n : ℕ) : differentiable_manifold ⊤ (euclidean_space.standard_euclidean_space n) :=
sorry --⟨⟨⟨subtype _, _⟩, _, _, _, _⟩, omitted⟩

/- smooth maps-/
variables {X : differentiable_manifold k E} {Y : differentiable_manifold k E} {Z : differentiable_manifold k E}

def respects_charts (f : X → Y) (A : set (chart X.carrier E)) (B : set (chart Y.carrier E)) : Prop :=
∀(c ∈ A) (c' ∈ B), is_smooth k (chart.to_fun c' ∘. pfun.lift f ∘. chart.inv_fun c)

structure smooth_map (X Y : differentiable_manifold k E) :=
  (map : X → Y)
  (smooth : respects_charts map X.max_atlas Y.max_atlas)

infix ` →ₛ `:25 := smooth_map

def incl (X : differentiable_manifold k E) {s : set X} (hs : is_open s) :
  restrict X hs →ₛ X :=
⟨subtype.val, omitted⟩

lemma respects_charts_local (f : X → Y) (A : set (chart X.carrier E)) (B : set (chart Y.carrier E))
  (h : ∀x : X, ∃(s : set X) (hs : is_open s), x ∈ s ∧
    respects_charts (f ∘ (incl X hs).map) (chart.restrict hs '' A) B) : respects_charts f A B :=
omitted

lemma respects_charts_subset (f : X → Y) (A A' : set (chart X.carrier E)) (B B' : set (chart Y.carrier E))
  (hA : ⋃₀ (chart.domain '' A') ⊆ ⋃₀ (chart.domain '' A)) (hB : ⋃₀ (chart.domain '' B') ⊆ ⋃₀ (chart.domain '' B))
  (h : respects_charts f A B) : respects_charts f A' B' :=
omitted

namespace smooth_map

def id : X →ₛ X := ⟨id, omitted⟩
def comp (g : Y →ₛ Z) (f : X →ₛ Y) : X →ₛ Z := ⟨g.map ∘ f.map, omitted⟩

end smooth_map

end differentiable_manifold


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

Evaluate expressions in the language of (semi-)rings.
Based on http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf .
-/
import algebra.group_power tactic.norm_num

namespace tactic
namespace ring

def horner {α} [comm_semiring α] (a x : α) (n : ℕ) (b : α) := a * x ^ n + b

meta structure cache :=
(α : expr)
(univ : level)
(comm_semiring_inst : expr)

meta def mk_cache (e : expr) : tactic cache :=
do α ← infer_type e,
   c ← mk_app ``comm_semiring [α] >>= mk_instance,
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   return ⟨α, u, c⟩

meta def cache.cs_app (c : cache) (n : name) : list expr → expr :=
(@expr.const tt n [c.univ] c.α c.comm_semiring_inst).mk_app

meta def cache.mk_app (c : cache) (n inst : name) (l : list expr) : tactic expr :=
do m ← mk_instance ((expr.const inst [c.univ] : expr) c.α),
   return $ (@expr.const tt n [c.univ] c.α m).mk_app l

meta inductive horner_expr : Type
| const (e : expr) : horner_expr
| xadd (e : expr) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr) : horner_expr

meta def horner_expr.e : horner_expr → expr
| (horner_expr.const e) := e
| (horner_expr.xadd e _ _ _ _) := e

meta instance : has_coe horner_expr expr := ⟨horner_expr.e⟩

meta def horner_expr.xadd' (c : cache) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr): horner_expr :=
horner_expr.xadd (c.cs_app ``horner [a, x, n.1, b]) a x n b

open horner_expr

meta def horner_expr.to_string : horner_expr → string
| (const e) := to_string e
| (xadd e a x (_, n) b) :=
    "(" ++ a.to_string ++ ") * (" ++ to_string x ++ ")^"
        ++ to_string n ++ " + " ++ b.to_string

meta def horner_expr.pp : horner_expr → tactic format
| (const e) := pp e
| (xadd e a x (_, n) b) := do
  pa ← a.pp, pb ← b.pp, px ← pp x,
  return $ "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ to_string n ++ " + " ++ pb

meta instance : has_to_tactic_format horner_expr := ⟨horner_expr.pp⟩

meta def horner_expr.refl_conv (e : horner_expr) : tactic (horner_expr × expr) :=
do p ← mk_eq_refl e, return (e, p)

theorem zero_horner {α} [comm_semiring α] (x n b) :
  @horner α _ 0 x n b = b :=
by simp [horner]

theorem horner_horner {α} [comm_semiring α] (a₁ x n₁ n₂ b n')
  (h : n₁ + n₂ = n') :
  @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b :=
by simp [h.symm, horner, pow_add, mul_assoc]

meta def eval_horner (c : cache) : horner_expr → expr → expr × ℕ → horner_expr → tactic (horner_expr × expr)
| ha@(const a) x n b :=
  if a.to_nat = some 0 then
    return (b, c.cs_app ``zero_horner [x, n.1, b])
  else (xadd' c ha x n b).refl_conv
| ha@(xadd a a₁ x₁ n₁ b₁) x n b :=
  if x₁ = x ∧ b₁.e.to_nat = some 0 then do
    (n', h) ← mk_app ``has_add.add [n₁.1, n.1] >>= norm_num,
    return (xadd' c a₁ x (n', n₁.2 + n.2) b,
      c.cs_app ``horner_horner [a₁, x, n₁.1, n.1, b, n', h])
  else (xadd' c ha x n b).refl_conv

theorem const_add_horner {α} [comm_semiring α] (k a x n b b') (h : k + b = b') :
  k + @horner α _ a x n b = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_const {α} [comm_semiring α] (a x n b k b') (h : b + k = b') :
  @horner α _ a x n b + k = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_horner_lt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₁ + k = n₂) (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_gt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₂ + k = n₁) (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_eq {α} [comm_semiring α] (a₁ x n b₁ a₂ b₂ a' b' t)
  (h₁ : a₁ + a₂ = a') (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
  @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t :=
by simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm]

meta def eval_add (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e, p) ← mk_app ``has_add.add [e₁, e₂] >>= norm_num,
  return (const e, p)
| he₁@(const e₁) he₂@(xadd e₂ a x n b) :=
  if e₁.to_nat = some 0 then  do
    p ← mk_app ``zero_add [e₂],
    return (he₂, p)
  else do
    (b', h) ← eval_add he₁ b,
    return (xadd' c a x n b',
      c.cs_app ``const_add_horner [e₁, a, x, n.1, b, b', h])
| he₁@(xadd e₁ a x n b) he₂@(const e₂) :=
  if e₂.to_nat = some 0 then do
    p ← mk_app ``add_zero [e₁],
    return (he₁, p)
  else do
    (b', h) ← eval_add b he₂,
    return (xadd' c a x n b',
      c.cs_app ``horner_add_const [a, x, n.1, b, e₂, b', h])
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (b', h) ← eval_add b₁ he₂,
    return (xadd' c a₁ x₁ n₁ b',
      c.cs_app ``horner_add_const [a₁, x₁, n₁.1, b₁, e₂, b', h])
  else if x₁ ≠ x₂ then do
    (b', h) ← eval_add he₁ b₂,
    return (xadd' c a₂ x₂ n₂ b',
      c.cs_app ``const_add_horner [e₁, a₂, x₂, n₂.1, b₂, b', h])
  else if n₁.2 < n₂.2 then do
    let k := n₂.2 - n₁.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₁.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0)),
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_add_horner_lt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else if n₁ ≠ n₂ then do
    let k := n₁.2 - n₂.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₂.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0)) a₂,
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₂ b',
      c.cs_app ``horner_add_horner_gt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    (a', h₁) ← eval_add a₁ a₂,
    (b', h₂) ← eval_add b₁ b₂,
    (t, h₃) ← eval_horner c a' x₁ n₁ b',
    return (t, c.cs_app ``horner_add_horner_eq
      [a₁, x₁, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_neg {α} [comm_ring α] (a x n b a' b')
  (h₁ : -a = a') (h₂ : -b = b') :
  -@horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner]

meta def eval_neg (c : cache) : horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_neg.neg [e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_neg a,
  (b', h₂) ← eval_neg b,
  p ← c.mk_app ``horner_neg ``comm_ring [a, x, n.1, b, a', b', h₁, h₂],
  return (xadd' c a' x n b', p)

theorem horner_const_mul {α} [comm_semiring α] (c a x n b a' b')
  (h₁ : c * a = a') (h₂ : c * b = b') :
  c * @horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]

theorem horner_mul_const {α} [comm_semiring α] (a x n b c a' b')
  (h₁ : a * c = a') (h₂ : b * c = b') :
  @horner α _ a x n b * c = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]

meta def eval_const_mul (c : cache) (k : expr) :
  horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_mul.mul [k, e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_const_mul a,
  (b', h₂) ← eval_const_mul b,
  return (xadd' c a' x n b',
    c.cs_app ``horner_const_mul [k, a, x, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t :=
by rw [← h₂, ← h₁];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

theorem horner_mul_horner {α} [comm_semiring α]
  (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = haa)
  (h₃ : a₁ * b₂ = ab) (h₄ : b₁ * b₂ = bb)
  (H : haa + horner ab x n₁ bb = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t :=
by rw [← H, ← h₂, ← h₁, ← h₃, ← h₄];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

meta def eval_mul (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e', p) ← mk_app ``has_mul.mul [e₁, e₂] >>= norm_num,
  return (const e', p)
| (const e₁) e₂ :=
  match e₁.to_nat with
  | (some 0) := do
    α0 ← expr.of_nat c.α 0,
    p ← mk_app ``zero_mul [e₂],
    return (const α0, p)
  | (some 1) := do
    p ← mk_app ``one_mul [e₂],
    return (e₂, p)
  | _ := eval_const_mul c e₁ e₂
  end
| e₁ he₂@(const e₂) := do
  p₁ ← mk_app ``mul_comm [e₁, e₂],
  (e', p₂) ← eval_mul he₂ e₁,
  p ← mk_eq_trans p₁ p₂, return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (a', h₁) ← eval_mul a₁ he₂,
    (b', h₂) ← eval_mul b₁ he₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_mul_const [a₁, x₁, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁ ≠ x₂ then do
    (a', h₁) ← eval_mul he₁ a₂,
    (b', h₂) ← eval_mul he₁ b₂,
    return (xadd' c a' x₂ n₂ b',
      c.cs_app ``horner_const_mul [e₁, a₂, x₂, n₂.1, b₂, a', b', h₁, h₂])
  else do
    (aa, h₁) ← eval_mul he₁ a₂,
    α0 ← expr.of_nat c.α 0,
    (haa, h₂) ← eval_horner c aa x₁ n₂ (const α0),
    if b₂.e.to_nat = some 0 then
      return (haa, c.cs_app ``horner_mul_horner_zero
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      (ab, h₃) ← eval_mul a₁ b₂,
      (bb, h₄) ← eval_mul b₁ b₂,
      (t, H) ← eval_add c haa (xadd' c ab x₁ n₁ bb),
      return (t, c.cs_app ``horner_mul_horner
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])

theorem horner_pow {α} [comm_semiring α] (a x n m n' a')
  (h₁ : n * m = n') (h₂ : a ^ m = a') :
  @horner α _ a x n 0 ^ m = horner a' x n' 0 :=
by simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]

meta def eval_pow (c : cache) : horner_expr → expr × ℕ → tactic (horner_expr × expr)
| e (_, 0) := do
  α1 ← expr.of_nat c.α 1,
  p ← mk_app ``pow_zero [e],
  return (const α1, p)
| e (_, 1) := do
  p ← mk_app ``pow_one [e],
  return (e, p)
| (const e) (e₂, m) := do
  (e', p) ← mk_app ``monoid.pow [e, e₂] >>= norm_num.derive,
  return (const e', p)
| he@(xadd e a x n b) m :=
  let N : expr := expr.const `nat [] in
  match b.e.to_nat with
  | some 0 := do
    (n', h₁) ← mk_app ``has_mul.mul [n.1, m.1] >>= norm_num,
    (a', h₂) ← eval_pow a m,
    α0 ← expr.of_nat c.α 0,
    return (xadd' c a' x (n', n.2 * m.2) (const α0),
      c.cs_app ``horner_pow [a, x, n.1, m.1, n', a', h₁, h₂])
  | _ := do
    e₂ ← expr.of_nat N (m.2-1),
    l ← mk_app ``monoid.pow [e, e₂],
    (tl, hl) ← eval_pow he (e₂, m.2-1),
    (t, p₂) ← eval_mul c tl he,
    hr ← mk_eq_refl e,
    p₂ ← c.mk_app ``norm_num.subst_into_prod ``has_mul [l, e, tl, e, t, hl, hr, p₂],
    p₁ ← mk_app ``pow_succ' [e, e₂],
    p ← mk_eq_trans p₁ p₂,
    return (t, p)
  end

theorem horner_atom {α} [comm_semiring α] (x : α) : x = horner 1 x 1 0 :=
by simp [horner]

meta def eval_atom (c : cache) (e : expr) : tactic (horner_expr × expr) :=
do α0 ← expr.of_nat c.α 0,
   α1 ← expr.of_nat c.α 1,
   n1 ← expr.of_nat (expr.const `nat []) 1,
   return (xadd' c (const α1) e (n1, 1) (const α0), c.cs_app ``horner_atom [e])

lemma subst_into_pow {α} [monoid α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : (r : ℕ) = tr) (prt : tl ^ tr = t) : l ^ r = t :=
by simp [prl, prr, prt]

lemma unfold_sub {α} [add_group α] (a b c : α)
  (h : a + -b = c) : a - b = c := h

lemma unfold_div {α} [division_ring α] (a b c : α)
  (h : a * b⁻¹ = c) : a / b = c := h

meta def eval (c : cache) : expr → tactic (horner_expr × expr)
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_sum ``has_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| `(%%e₁ - %%e₂) := do
  e₂' ← mk_app ``has_neg.neg [e₂],
  e ← mk_app ``has_add.add [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_sub ``add_group [e₁, e₂, e', p],
  return (e', p')
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg c e₁,
  p ← c.mk_app ``norm_num.subst_into_neg ``has_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(%%e₁ * %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_mul c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_prod ``has_mul [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(has_inv.inv %%_) := (do
    (e', p) ← norm_num.derive e,
    e'.to_rat,
    return (const e', p)) <|> eval_atom c e
| `(%%e₁ / %%e₂) := do
  e₂' ← mk_app ``has_inv.inv [e₂],
  e ← mk_app ``has_mul.mul [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_div ``division_ring [e₁, e₂, e', p],
  return (e', p')
| e@`(@has_pow.pow _ _ %%P %%e₁ %%e₂) := do
  (e₂', p₂) ← eval e₂,
  match e₂'.e.to_nat, P with
  | some k, `(monoid.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    return (e', p)
  | some k, `(nat.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p₃ ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    p₄ ← mk_app ``nat.pow_eq_pow [e₁, e₂] >>= mk_eq_symm,
    p ← mk_eq_trans p₄ p₃,
    return (e', p)
  | _, _ := eval_atom c e
  end
| e := match e.to_nat with
  | some n := (const e).refl_conv
  | none := eval_atom c e
  end

meta def eval' (c : cache) (e : expr) : tactic (expr × expr) :=
do (e', p) ← eval c e, return (e', p)

theorem horner_def' {α} [comm_semiring α] (a x n b) : @horner α _ a x n b = x ^ n * a + b :=
by simp [horner, mul_comm]

theorem mul_assoc_rev {α} [semigroup α] (a b c : α) : a * (b * c) = a * b * c :=
by simp [mul_assoc]

theorem pow_add_rev {α} [monoid α] (a b : α) (m n : ℕ) : a ^ m * a ^ n = a ^ (m + n) :=
by simp [pow_add]

theorem pow_add_rev_right {α} [monoid α] (a b : α) (m n : ℕ) : b * a ^ m * a ^ n = b * a ^ (m + n) :=
by simp [pow_add, mul_assoc]

theorem add_neg_eq_sub {α} [add_group α] (a b : α) : a + -b = a - b := rfl

@[derive has_reflect]
inductive normalize_mode | raw | SOP | horner

meta def normalize (mode := normalize_mode.horner) (e : expr) : tactic (expr × expr) := do
pow_lemma ← simp_lemmas.mk.add_simp ``pow_one,
let lemmas := match mode with
| normalize_mode.SOP :=
  [``horner_def', ``add_zero, ``mul_one, ``mul_add, ``mul_sub,
   ``mul_assoc_rev, ``pow_add_rev, ``pow_add_rev_right,
   ``mul_neg_eq_neg_mul_symm, ``add_neg_eq_sub]
| normalize_mode.horner :=
  [``horner.equations._eqn_1, ``add_zero, ``one_mul, ``pow_one,
   ``neg_mul_eq_neg_mul_symm, ``add_neg_eq_sub]
| _ := []
end,
lemmas ← lemmas.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
(_, e', pr) ← ext_simplify_core () {}
  simp_lemmas.mk (λ _, failed) (λ _ _ _ _ e, do
    c ← mk_cache e,
    (new_e, pr) ← match mode with
    | normalize_mode.raw := eval' c
    | normalize_mode.horner := trans_conv (eval' c) (simplify lemmas [])
    | normalize_mode.SOP :=
      trans_conv (eval' c) $
      trans_conv (simplify lemmas []) $
      simp_bottom_up' (λ e, norm_num e <|> pow_lemma.rewrite e)
    end e,
    guard (¬ new_e =ₐ e),
    return ((), new_e, some pr, ff))
   (λ _ _ _ _ _, failed) `eq e,
return (e', pr)

end ring

namespace interactive
open interactive interactive.types lean.parser
open tactic.ring

local postfix `?`:9001 := optional

/-- Tactic for solving equations in the language of rings.
  This version of `ring` fails if the target is not an equality
  that is provable by the axioms of commutative (semi)rings. -/
meta def ring1 : tactic unit :=
do `(%%e₁ = %%e₂) ← target,
  c ← mk_cache e₁,
  (e₁', p₁) ← eval c e₁,
  (e₂', p₂) ← eval c e₂,
  is_def_eq e₁' e₂',
  p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
  tactic.exact p

meta def ring.mode : lean.parser ring.normalize_mode :=
with_desc "(SOP|raw|horner)?" $
do mode ← ident?, match mode with
| none         := return ring.normalize_mode.horner
| some `horner := return ring.normalize_mode.horner
| some `SOP    := return ring.normalize_mode.SOP
| some `raw    := return ring.normalize_mode.raw
| _            := failed
end

/-- Tactic for solving equations in the language of rings.
  Attempts to prove the goal outright if there is no `at`
  specifier and the target is an equality, but if this
  fails it falls back to rewriting all ring expressions
  into a normal form. When writing a normal form,
  `ring SOP` will use sum-of-products form instead of horner form. -/
meta def ring (SOP : parse ring.mode) (loc : parse location) : tactic unit :=
match loc with
| interactive.loc.ns [none] := ring1
| _ := failed
end <|>
do ns ← loc.get_locals,
   tt ← tactic.replace_at (normalize SOP) ns loc.include_goal
      | fail "ring failed to simplify",
   when loc.include_goal $ try tactic.reflexivity

end interactive
end tactic


import Smt

theorem hypothetical_syllogism (p q r : Prop) : (p → q) → (q → r) → p → r := by
  smt


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import deprecated.subgroup
import deprecated.group
import ring_theory.subring.basic

/-!
# Unbundled subrings (deprecated)

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 subrings. Instead of using this file, please use
`subring`, defined in `ring_theory.subring.basic`, for subrings of rings.

## Main definitions

`is_subring (S : set R) : Prop` : the predicate that `S` is the underlying set of a subring
of the ring `R`. The bundled variant `subring R` should be used in preference to this.

## Tags

is_subring
-/
universes u v

open group

variables {R : Type u} [ring R]

/-- `S` is a subring: a set containing 1 and closed under multiplication, addition and additive
inverse. -/
structure is_subring (S : set R) extends is_add_subgroup S, is_submonoid S : Prop.

/-- Construct a `subring` from a set satisfying `is_subring`. -/
def is_subring.subring {S : set R} (hs : is_subring S) : subring R :=
{ carrier := S,
  one_mem' := hs.one_mem,
  mul_mem' := hs.mul_mem,
  zero_mem' := hs.zero_mem,
  add_mem' := hs.add_mem,
  neg_mem' := hs.neg_mem }

namespace ring_hom

lemma is_subring_preimage {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) {s : set S} (hs : is_subring s) : is_subring (f ⁻¹' s) :=
{ ..is_add_group_hom.preimage f.to_is_add_group_hom hs.to_is_add_subgroup,
  ..is_submonoid.preimage f.to_is_monoid_hom hs.to_is_submonoid, }

lemma is_subring_image {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) {s : set R} (hs : is_subring s) : is_subring (f '' s) :=
{ ..is_add_group_hom.image_add_subgroup f.to_is_add_group_hom hs.to_is_add_subgroup,
  ..is_submonoid.image f.to_is_monoid_hom hs.to_is_submonoid, }

lemma is_subring_set_range {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) : is_subring (set.range f) :=
{ ..is_add_group_hom.range_add_subgroup f.to_is_add_group_hom,
  ..range.is_submonoid f.to_is_monoid_hom, }

end ring_hom

variables {cR : Type u} [comm_ring cR]

lemma is_subring.inter {S₁ S₂ : set R} (hS₁ : is_subring S₁) (hS₂ : is_subring S₂) :
  is_subring (S₁ ∩ S₂) :=
{ ..is_add_subgroup.inter hS₁.to_is_add_subgroup hS₂.to_is_add_subgroup,
  ..is_submonoid.inter hS₁.to_is_submonoid hS₂.to_is_submonoid }

lemma is_subring.Inter {ι : Sort*} {S : ι → set R} (h : ∀ y : ι, is_subring (S y)) :
  is_subring (set.Inter S) :=
{ ..is_add_subgroup.Inter (λ i, (h i).to_is_add_subgroup),
  ..is_submonoid.Inter (λ i, (h i).to_is_submonoid) }

lemma is_subring_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set R} (h : ∀ i, is_subring (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subring (⋃i, s i) :=
{ to_is_add_subgroup := is_add_subgroup_Union_of_directed
    (λ i, (h i).to_is_add_subgroup) directed,
  to_is_submonoid := is_submonoid_Union_of_directed (λ i, (h i).to_is_submonoid) directed }

namespace ring

/-- The smallest subring containing a given subset of a ring, considered as a set. This function
is deprecated; use `subring.closure`. -/
def closure (s : set R) := add_group.closure (monoid.closure s)

variable {s : set R}

local attribute [reducible] closure

theorem exists_list_of_mem_closure {a : R} (h : a ∈ closure s) :
  (∃ L : list (list R), (∀ l ∈ L, ∀ x ∈ l, x ∈ s ∨ x = (-1:R)) ∧ (L.map list.prod).sum = a) :=
add_group.in_closure.rec_on h
  (λ x hx, match x, monoid.exists_list_of_mem_closure hx with
    | _, ⟨L, h1, rfl⟩ := ⟨[L], list.forall_mem_singleton.2 (λ r hr, or.inl (h1 r hr)), zero_add _⟩
    end)
  ⟨[], list.forall_mem_nil _, rfl⟩
  (λ b _ ih, match b, ih with
    | _, ⟨L1, h1, rfl⟩ := ⟨L1.map (list.cons (-1)),
      λ L2 h2, match L2, list.mem_map.1 h2 with
        | _, ⟨L3, h3, rfl⟩ := list.forall_mem_cons.2 ⟨or.inr rfl, h1 L3 h3⟩
        end,
      by simp only [list.map_map, (∘), list.prod_cons, neg_one_mul];
      exact list.rec_on L1 neg_zero.symm (λ hd tl ih,
        by rw [list.map_cons, list.sum_cons, ih, list.map_cons, list.sum_cons, neg_add])⟩
    end)
  (λ r1 r2 hr1 hr2 ih1 ih2, match r1, r2, ih1, ih2 with
    | _, _, ⟨L1, h1, rfl⟩, ⟨L2, h2, rfl⟩ := ⟨L1 ++ L2, list.forall_mem_append.2 ⟨h1, h2⟩,
      by rw [list.map_append, list.sum_append]⟩
    end)

@[elab_as_eliminator]
protected theorem in_closure.rec_on {C : R → Prop} {x : R} (hx : x ∈ closure s)
  (h1 : C 1) (hneg1 : C (-1)) (hs : ∀ z ∈ s, ∀ n, C n → C (z * n))
  (ha : ∀ {x y}, C x → C y → C (x + y)) : C x :=
begin
  have h0 : C 0 := add_neg_self (1:R) ▸ ha h1 hneg1,
  rcases exists_list_of_mem_closure hx with ⟨L, HL, rfl⟩, clear hx,
  induction L with hd tl ih, { exact h0 },
  rw list.forall_mem_cons at HL,
  suffices : C (list.prod hd),
  { rw [list.map_cons, list.sum_cons],
    exact ha this (ih HL.2) },
  replace HL := HL.1, clear ih tl,
  suffices : ∃ L : list R,
    (∀ x ∈ L, x ∈ s) ∧ (list.prod hd = list.prod L ∨ list.prod hd = -list.prod L),
  { rcases this with ⟨L, HL', HP | HP⟩,
    { rw HP, clear HP HL hd, induction L with hd tl ih, { exact h1 },
      rw list.forall_mem_cons at HL',
      rw list.prod_cons,
      exact hs _ HL'.1 _ (ih HL'.2) },
    rw HP, clear HP HL hd, induction L with hd tl ih, { exact hneg1 },
    rw [list.prod_cons, neg_mul_eq_mul_neg],
    rw list.forall_mem_cons at HL',
    exact hs _ HL'.1 _ (ih HL'.2) },
  induction hd with hd tl ih,
  { exact ⟨[], list.forall_mem_nil _, or.inl rfl⟩ },
  rw list.forall_mem_cons at HL,
  rcases ih HL.2 with ⟨L, HL', HP | HP⟩; cases HL.1 with hhd hhd,
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inl $
      by rw [list.prod_cons, list.prod_cons, HP]⟩ },
  { exact ⟨L, HL', or.inr $ by rw [list.prod_cons, hhd, neg_one_mul, HP]⟩ },
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inr $
      by rw [list.prod_cons, list.prod_cons, HP, neg_mul_eq_mul_neg]⟩ },
  { exact ⟨L, HL', or.inl $ by rw [list.prod_cons, hhd, HP, neg_one_mul, neg_neg]⟩ }
end

lemma closure.is_subring : is_subring (closure s) :=
{ one_mem := add_group.mem_closure $ is_submonoid.one_mem $ monoid.closure.is_submonoid _,
  mul_mem := λ a b ha hb, add_group.in_closure.rec_on hb
    ( λ c hc, add_group.in_closure.rec_on ha
      ( λ d hd, add_group.subset_closure ((monoid.closure.is_submonoid _).mul_mem hd hc))
      ( (zero_mul c).symm ▸ (add_group.closure.is_add_subgroup _).zero_mem)
      ( λ d hd hdc, neg_mul_eq_neg_mul d c ▸ (add_group.closure.is_add_subgroup _).neg_mem hdc)
      ( λ d e hd he hdc hec, (add_mul d e c).symm ▸
        ((add_group.closure.is_add_subgroup _).add_mem hdc hec)))
    ( (mul_zero a).symm ▸ (add_group.closure.is_add_subgroup _).zero_mem)
    ( λ c hc hac, neg_mul_eq_mul_neg a c ▸ (add_group.closure.is_add_subgroup _).neg_mem hac)
    ( λ c d hc hd hac had, (mul_add a c d).symm ▸
      (add_group.closure.is_add_subgroup _).add_mem hac had),
  ..add_group.closure.is_add_subgroup _}

theorem mem_closure {a : R} : a ∈ s → a ∈ closure s :=
add_group.mem_closure ∘ @monoid.subset_closure _ _ _ _

theorem subset_closure : s ⊆ closure s :=
λ _, mem_closure

theorem closure_subset {t : set R} (ht : is_subring t) : s ⊆ t → closure s ⊆ t :=
(add_group.closure_subset ht.to_is_add_subgroup) ∘ (monoid.closure_subset ht.to_is_submonoid)

theorem closure_subset_iff {s t : set R} (ht : is_subring t) : closure s ⊆ t ↔ s ⊆ t :=
(add_group.closure_subset_iff ht.to_is_add_subgroup).trans
  ⟨set.subset.trans monoid.subset_closure, monoid.closure_subset ht.to_is_submonoid⟩

theorem closure_mono {s t : set R} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset closure.is_subring $ set.subset.trans H subset_closure

lemma image_closure {S : Type*} [ring S] (f : R →+* S) (s : set R) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { rw [f.map_one], apply closure.is_subring.to_is_submonoid.one_mem },
    { rw [f.map_neg, f.map_one],
      apply closure.is_subring.to_is_add_subgroup.neg_mem,
      apply closure.is_subring.to_is_submonoid.one_mem },
    { rw [f.map_mul],
      apply closure.is_subring.to_is_submonoid.mul_mem;
      solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [f.map_add], apply closure.is_subring.to_is_add_submonoid.add_mem, assumption' },
  end
  (closure_subset (ring_hom.is_subring_image _ closure.is_subring) $
    set.image_subset _ subset_closure)

end ring


import group_theory.perm.basic

variables {α β γ : Type*}

namespace equiv

@[simp] lemma symm_trans (f : α ≃ β) (g : β ≃ γ) : (f.trans g).symm = (g.symm).trans f.symm := rfl

end equiv


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

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

/-!
# Transporting existence of specific limits across equivalences

For now, we only treat the case of initial and terminal objects, but other special shapes can be
added in the future.
-/

open CategoryTheory CategoryTheory.Limits

namespace CategoryTheory

universe v₁ v₂ u₁ u₂

variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D]

theorem hasInitial_of_equivalence (e : D ⥤ C) [IsEquivalence e] [HasInitial C] : HasInitial D :=
  Adjunction.hasColimitsOfShape_of_equivalence e
#align category_theory.has_initial_of_equivalence CategoryTheory.hasInitial_of_equivalence

theorem Equivalence.hasInitial_iff (e : C ≌ D) : HasInitial C ↔ HasInitial D :=
  ⟨fun (_ : HasInitial C) => hasInitial_of_equivalence e.inverse,
    fun (_ : HasInitial D) => hasInitial_of_equivalence e.functor⟩
#align category_theory.equivalence.has_initial_iff CategoryTheory.Equivalence.hasInitial_iff

theorem hasTerminal_of_equivalence (e : D ⥤ C) [IsEquivalence e] [HasTerminal C] : HasTerminal D :=
  Adjunction.hasLimitsOfShape_of_equivalence e
#align category_theory.has_terminal_of_equivalence CategoryTheory.hasTerminal_of_equivalence

theorem Equivalence.hasTerminal_iff (e : C ≌ D) : HasTerminal C ↔ HasTerminal D :=
  ⟨fun (_ : HasTerminal C) => hasTerminal_of_equivalence e.inverse,
    fun (_ : HasTerminal D) => hasTerminal_of_equivalence e.functor⟩
#align category_theory.equivalence.has_terminal_iff CategoryTheory.Equivalence.hasTerminal_iff

end CategoryTheory