/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u

namespace Mathlib

namespace list

theorem rotate_mod {α : Type u} (l : List α) (n : ℕ) : rotate l (n % length l) = rotate l n := sorry

@[simp] theorem rotate_nil {α : Type u} (n : ℕ) : rotate [] n = [] :=
  nat.cases_on n (Eq.refl (rotate [] 0)) fun (n : ℕ) => Eq.refl (rotate [] (Nat.succ n))

@[simp] theorem rotate_zero {α : Type u} (l : List α) : rotate l 0 = l := sorry

@[simp] theorem rotate'_nil {α : Type u} (n : ℕ) : rotate' [] n = [] :=
  nat.cases_on n (Eq.refl (rotate' [] 0)) fun (n : ℕ) => Eq.refl (rotate' [] (Nat.succ n))

@[simp] theorem rotate'_zero {α : Type u} (l : List α) : rotate' l 0 = l :=
  list.cases_on l (Eq.refl (rotate' [] 0))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (rotate' (l_hd :: l_tl) 0)

theorem rotate'_cons_succ {α : Type u} (l : List α) (a : α) (n : ℕ) :
    rotate' (a :: l) (Nat.succ n) = rotate' (l ++ [a]) n :=
  sorry

@[simp] theorem length_rotate' {α : Type u} (l : List α) (n : ℕ) :
    length (rotate' l n) = length l :=
  sorry

theorem rotate'_eq_take_append_drop {α : Type u} {l : List α} {n : ℕ} :
    n ≤ length l → rotate' l n = drop n l ++ take n l :=
  sorry

theorem rotate'_rotate' {α : Type u} (l : List α) (n : ℕ) (m : ℕ) :
    rotate' (rotate' l n) m = rotate' l (n + m) :=
  sorry

@[simp] theorem rotate'_length {α : Type u} (l : List α) : rotate' l (length l) = l := sorry

@[simp] theorem rotate'_length_mul {α : Type u} (l : List α) (n : ℕ) :
    rotate' l (length l * n) = l :=
  sorry

theorem rotate'_mod {α : Type u} (l : List α) (n : ℕ) : rotate' l (n % length l) = rotate' l n :=
  sorry

theorem rotate_eq_rotate' {α : Type u} (l : List α) (n : ℕ) : rotate l n = rotate' l n := sorry

theorem rotate_cons_succ {α : Type u} (l : List α) (a : α) (n : ℕ) :
    rotate (a :: l) (Nat.succ n) = rotate (l ++ [a]) n :=
  sorry

@[simp] theorem mem_rotate {α : Type u} {l : List α} {a : α} {n : ℕ} : a ∈ rotate l n ↔ a ∈ l :=
  sorry

@[simp] theorem length_rotate {α : Type u} (l : List α) (n : ℕ) : length (rotate l n) = length l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (length (rotate l n) = length l)) (rotate_eq_rotate' l n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (rotate' l n) = length l)) (length_rotate' l n)))
      (Eq.refl (length l)))

theorem rotate_eq_take_append_drop {α : Type u} {l : List α} {n : ℕ} :
    n ≤ length l → rotate l n = drop n l ++ take n l :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (n ≤ length l → rotate l n = drop n l ++ take n l))
        (rotate_eq_rotate' l n)))
    rotate'_eq_take_append_drop

theorem rotate_rotate {α : Type u} (l : List α) (n : ℕ) (m : ℕ) :
    rotate (rotate l n) m = rotate l (n + m) :=
  sorry

@[simp] theorem rotate_length {α : Type u} (l : List α) : rotate l (length l) = l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (rotate l (length l) = l)) (rotate_eq_rotate' l (length l))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (rotate' l (length l) = l)) (rotate'_length l))) (Eq.refl l))

@[simp] theorem rotate_length_mul {α : Type u} (l : List α) (n : ℕ) : rotate l (length l * n) = l :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (rotate l (length l * n) = l)) (rotate_eq_rotate' l (length l * n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (rotate' l (length l * n) = l)) (rotate'_length_mul l n)))
      (Eq.refl l))

theorem prod_rotate_eq_one_of_prod_eq_one {α : Type u} [group α] {l : List α} (hl : prod l = 1)
    (n : ℕ) : prod (rotate l n) = 1 :=
  sorry

end Mathlib


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

import topology.sheaves.sheaf_condition.pairwise_intersections

/-!
# functors between categories of sheaves

Show that the pushforward of a sheaf is a sheaf, and define
the pushforward functor from the category of C-valued sheaves
on X to that of sheaves on Y, given a continuous map between
topological spaces X and Y.

TODO: pullback for presheaves and sheaves
-/

noncomputable theory

universes w v u

open category_theory
open category_theory.limits
open topological_space

variables {C : Type u} [category.{v} C]
variables {X Y : Top.{w}} (f : X ⟶ Y)
variables ⦃ι : Type w⦄ {U : ι → opens Y}

namespace Top
namespace presheaf.sheaf_condition_pairwise_intersections

lemma map_diagram :
  pairwise.diagram U ⋙ opens.map f = pairwise.diagram ((opens.map f).obj ∘ U) :=
begin
  apply functor.hext,
  abstract obj_eq {intro i, cases i; refl},
  intros i j g, apply subsingleton.helim,
  iterate 2 {rw map_diagram.obj_eq},
end

lemma map_cocone : (opens.map f).map_cocone (pairwise.cocone U)
                     == pairwise.cocone ((opens.map f).obj ∘ U) :=
begin
  unfold functor.map_cocone cocones.functoriality, dsimp, congr,
  iterate 2 {rw map_diagram, rw opens.map_supr},
  apply subsingleton.helim, rw [map_diagram, opens.map_supr],
  apply proof_irrel_heq,
end

theorem pushforward_sheaf_of_sheaf {F : presheaf C X}
  (h : F.is_sheaf_pairwise_intersections) :
  (f _* F).is_sheaf_pairwise_intersections :=
λ ι U, begin
  convert h ((opens.map f).obj ∘ U) using 2,
  rw ← map_diagram, refl,
  change F.map_cone ((opens.map f).map_cocone _).op == _,
  congr, iterate 2 {rw map_diagram}, apply map_cocone,
end

end presheaf.sheaf_condition_pairwise_intersections

namespace sheaf

open presheaf

/--
The pushforward of a sheaf (by a continuous map) is a sheaf.
-/
theorem pushforward_sheaf_of_sheaf
  {F : X.presheaf C} (h : F.is_sheaf) : (f _* F).is_sheaf :=
by rw is_sheaf_iff_is_sheaf_pairwise_intersections at h ⊢;
   exact sheaf_condition_pairwise_intersections.pushforward_sheaf_of_sheaf f h

/--
The pushforward functor.
-/
def pushforward (f : X ⟶ Y) : X.sheaf C ⥤ Y.sheaf C :=
{ obj := λ ℱ, ⟨f _* ℱ.1, pushforward_sheaf_of_sheaf f ℱ.2⟩,
  map := λ _ _ g, ⟨pushforward_map f g.1⟩ }

end sheaf

end Top


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Stochastic computation graphs.
-/
import .det .rand .util .id .sprog .env .reference

namespace certigrad

inductive operator (ishapes : list S) (oshape : S) : Type
| det : det.op ishapes oshape → operator
| rand : rand.op ishapes oshape → operator

namespace operator

def to_dist (m : env) : Π {parents : list reference} {oshape : S}, operator parents^.p2 oshape → sprog [oshape]
| parents _ (det op)   := sprog.ret ⟦op^.f (env.get_ks parents m)⟧
| parents _ (rand op) := sprog.prim op (env.get_ks parents m)

end operator

structure node : Type := (ref : reference) (parents : list (ID × S)) (op : operator parents^.p2 ref.2)
structure graph : Type := (nodes : list node) (costs : list ID) (targets inputs : list reference)

def uniq_ids : Π (nodes : list node) (inputs : env), Prop
| [] inputs := true
| (⟨ref, op, parents⟩ :: nodes) inputs :=
¬ env.has_key ref inputs ∧ ∀ (x : T ref.2), uniq_ids nodes (env.insert ref x inputs)

namespace graph

open sprog

def to_dist {fshapes : list S} (k : env → dvec T fshapes) : env → list node → sprog fshapes
| m []            := ret (k m)
| m (⟨ref, parents, op⟩::nodes) := bind (operator.to_dist m op)
                                        (λ (x : dvec T [ref.2]), to_dist (env.insert ref x^.head m) nodes)

open list

lemma envs_match_helper {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node),
    ∀ (n : node) (x : T n^.ref.2),
      uniq_ids (n :: nodes) inputs →
      (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
      ∀  (m : env),
         (∀ (r : reference), env.has_key r (env.insert n^.ref x inputs) → env.get r m = env.get r (env.insert n^.ref x inputs)) → k₁ m = k₂ m :=
assume inputs nodes n x H_uids H_k_eq,
assume (m : env) H_next_envs_agree,
  have H_envs_agree : ∀ (ref' : reference), env.has_key ref' inputs → env.get ref' m = env.get ref' inputs, from
    assume (ref' : reference) (H_inputs_contains_ref' : env.has_key ref' inputs),
    show env.get ref' m = env.get ref' inputs, from
    have H_next_contains_name : env.has_key ref' (env.insert n^.ref x inputs), from env.has_key_insert H_inputs_contains_ref',
    have H_next_agree : env.get ref' m = env.get ref' (env.insert n^.ref x inputs), from H_next_envs_agree _ H_next_contains_name,
    have H_ref'_neq_ref : ref' ≠ n^.ref,
      begin
      cases n with ref parents op, dsimp [uniq_ids] at H_uids,
      dsimp, intro H_eq, subst H_eq, exact H_uids^.left H_inputs_contains_ref'
      end,
    begin rw env.get_insert_diff _ _ H_ref'_neq_ref at H_next_agree, exact H_next_agree end,
  H_k_eq _ H_envs_agree

lemma to_dist_k_congr {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) (inputs : env) (nodes : list node) :
  k₁ = k₂ →  graph.to_dist k₁ inputs nodes = graph.to_dist k₂ inputs nodes := by { intro H, rw H }

lemma to_dist_congr {fshapes : list S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node),
      uniq_ids nodes inputs →
      (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
      to_dist k₁ inputs nodes = to_dist k₂ inputs nodes

-- Case 1
| inputs [] H_uids H_k_eq :=
show to_dist k₁ inputs [] = to_dist k₂ inputs [], from
show sprog.ret (k₁ inputs) = sprog.ret (k₂ inputs), from
have H_inputs_eq : ∀ (ref : reference), env.has_key ref inputs → env.get ref inputs = env.get ref inputs, from
  assume (ref : reference) (H_inputs_contain : env.has_key ref inputs), rfl,
by rw (H_k_eq _ H_inputs_eq)

-- Case 2
| inputs (⟨ref, parents, op⟩::nodes) H_uids H_k_eq :=
show to_dist k₁ inputs (⟨ref, parents, op⟩ :: nodes) = to_dist k₂ inputs (⟨ref, parents, op⟩ :: nodes), from
show bind (operator.to_dist inputs op) (λ (x : dvec T [ref.2]), to_dist k₁ (env.insert ref x^.head inputs) nodes)
     =
     bind (operator.to_dist inputs op) (λ (x : dvec T [ref.2]), to_dist k₂ (env.insert ref x^.head inputs) nodes), from
suffices ∀ (x : dvec T [ref.2]), to_dist k₁ (env.insert ref x^.head inputs) nodes = to_dist k₂ (env.insert ref x^.head inputs) nodes, from
  congr_arg _ (funext this),
assume (x : dvec T [ref.2]),
show to_dist k₁ (env.insert ref x^.head inputs) nodes = to_dist k₂ (env.insert ref x^.head inputs) nodes, from
to_dist_congr _ _ (H_uids^.right _) (envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq)

lemma graph_to_dist_inputs_congr {fshapes : list S} (k : env → dvec T fshapes) (inputs₁ inputs₂ : env) (nodes : list node) :
  inputs₁ = inputs₂ → graph.to_dist k inputs₁ nodes = graph.to_dist k inputs₂ nodes := assume H, by rw H

end graph

noncomputable def is_gintegrable {shapes : list S} (k : env → dvec T shapes) {shape : S} : Π (m : env) (nodes : list node) (f : dvec T shapes → T shape), Prop
| _ [] f := true

| m (⟨ref, parents, operator.det op⟩ :: nodes) f := is_gintegrable (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f

| m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
  let m' := (λ (y : T ref.2), env.insert ref y m) in
  T.is_integrable (λ x, op^.pdf (env.get_ks parents m) x ⬝ E (graph.to_dist k (m' x) nodes) f) ∧
  ∀ x, is_gintegrable (m' x) nodes f

open list

noncomputable def is_gdifferentiable (k : env → dvec T [[]]) : Π (tgt : reference) (m : env) (nodes : list node) (f : dvec T [[]] → ℝ), Prop
| tgt _ [] f := true

| tgt m (⟨ref, parents, operator.det op⟩ :: nodes) f :=
let θ := env.get tgt m,
    x := op^.f (env.get_ks parents m),
    g := (λ (v : dvec T parents^.p2) (θ : T tgt.2), E (graph.to_dist k (env.insert ref (det.op.f op v) (env.insert tgt θ m)) nodes) dvec.head) in

T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), g (env.get_ks parents (env.insert tgt θ m)) θ₀) θ
∧ T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), g (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx) θ)
                                                       (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ
∧ is_gdifferentiable tgt (env.insert ref x m) nodes f
∧ ∀ {idx : ℕ}, idx ∈ riota (length parents) → tgt = dnth parents idx → is_gdifferentiable ref (env.insert ref x m) nodes f

| tgt m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
let g : dvec T [ref.2] → T tgt.2 → ℝ :=
           (λ (x : dvec T [ref.2]) (θ₀ : T tgt.2), E (graph.to_dist k (env.insert ref x^.head (env.insert tgt θ₀ m)) nodes) dvec.head),
   θ : T tgt.2 := env.get tgt m,
   m' := (λ (y : T ref.2), env.insert ref y m) in

T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), E (sprog.prim op (env.get_ks parents (env.insert tgt θ m))) (λ (y : dvec T [ref.snd]), g y θ₀)) θ
∧ T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ m)) idx))
                                                                       (λ (y : dvec T [ref.snd]), g y θ))
                                                       (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ
∧ ∀ (y : T ref.2), is_gdifferentiable tgt (env.insert ref y m) nodes f

lemma is_gintegrable_k_congr {fshapes : list S} {fshape : S} (k₁ k₂ : env → dvec T fshapes) : Π (inputs : env) (nodes : list node) (f : dvec T fshapes → T fshape),
  uniq_ids nodes inputs →
  (∀ (m : env), (∀ (ref : reference), env.has_key ref inputs → env.get ref m = env.get ref inputs) → k₁ m = k₂ m) →
  is_gintegrable k₁ inputs nodes f → is_gintegrable k₂ inputs nodes f

| inputs [] f H_uids H_k_eq H_gint₁ := trivial

| inputs (⟨ref, parents, operator.det op⟩ :: nodes) f H_uids H_k_eq H_gint₁ :=
begin
dsimp [is_gintegrable] at H_gint₁,
dsimp [is_gintegrable],
apply is_gintegrable_k_congr _ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq) H_gint₁
end

| inputs (⟨ref, parents, operator.rand op⟩ :: nodes) f H_uids H_k_eq H_gint₁ :=
begin
dsimp [is_gintegrable] at H_gint₁,
dsimp [is_gintegrable],
split,
{
assertv H_dist_congr : ∀ x, graph.to_dist k₁ (env.insert ref x inputs) nodes = graph.to_dist k₂ (env.insert ref x inputs) nodes :=
assume x,
graph.to_dist_congr k₁ k₂ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq),
simp only [H_dist_congr] at H_gint₁,
exact H_gint₁^.left
},

{
intro x,
apply is_gintegrable_k_congr _ _ _ (H_uids^.right _) (graph.envs_match_helper k₁ k₂ _ _ _ _ H_uids H_k_eq) (H_gint₁^.right x)
}

end

-- TODO(dhs): this seems like it could be provable given is_gintegrable and compute_grad_slow_correct
noncomputable def is_nabla_gintegrable (k : env → dvec T [[]]) : Π (tgt : reference) (m : env) (nodes : list node) (f : dvec T [[]] → ℝ), Prop
| tgt m [] f := true

| tgt m (⟨ref, parents, operator.det op⟩ :: nodes) f :=
  is_nabla_gintegrable tgt (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f
  ∧ ∀ {idx : ℕ}, idx ∈ riota (length parents) → tgt = dnth parents idx → is_nabla_gintegrable ref (env.insert ref (op^.f (env.get_ks parents m)) m) nodes f

| tgt m (⟨ref, parents, operator.rand op⟩ :: nodes) f :=
  T.is_integrable (λ (x : T ref.2), op^.pdf (env.get_ks parents m) x ⬝ ∇ (λ (θ₀ : T tgt.2), E (graph.to_dist k (env.insert ref x (env.insert tgt θ₀ m)) nodes) f) (env.get tgt m))

∧ T.is_integrable
    (λ (x : T (ref.snd)),
       rand.op.pdf op (env.get_ks parents m) x ⬝ sumr
         (map
            (λ (idx : ℕ),
               E
                 (graph.to_dist k
                    (env.insert ref x m)
                    nodes)
                 dvec.head ⬝ ∇
                 (λ (θ₀ : T (tgt.snd)),
                    T.log (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents m) idx) x))
                 (env.get tgt m))
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))))

  ∧ ∀ (y : T ref.2), is_nabla_gintegrable tgt (env.insert ref y m) nodes f

--  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head →

end certigrad


open function

#print surjective

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

lemma surjective_comp {g : β → γ} {f : α → β}
  (hg : surjective g) (hf : surjective f) : surjective (g ∘ f) :=
λ z,
let ⟨y, iy⟩ := hg z,
    ⟨x, ix⟩ := hf y in
  ⟨x, show g(f(x)) = z, by simp *⟩

#print surjective_comp


import ..lovelib

/-! # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself. Abstract syntax trees __reflect__ internal data
structures, e.g., for expressions (terms). The prover's C++ internals are
exposed through Lean interfaces, which we can use for

* accessing the current context and goal;
* unifying expressions;
* querying and modifying the environment;
* setting attributes.

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-!

## Well-founded and non-well-founded recursion

The recursive functions we've written are structurally recursive.
But sometimes this feels like too strong of a restriction.
-/

def list.map {α β : Type} (f : α → β) : list α → list β
| [] := []
| (h::t) := f h :: list.map t

lemma list.map_length {α β : Type} (f : α → β): ∀ l :
  list α, list.length (list.map f l) = list.length l
| [] := rfl
| (h::t) := by simp [list.map, list.map_length]

def list.multimap₁ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) := f h :: list.multimap₁ (list.map f t)

def list.multimap₂ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.sizeof (list.map f t) < 1 + list.sizeof t := sorry,
  f h :: list.multimap₂ (list.map f t)

#eval list.multimap₂ (λ x, x + 1) [0, 0, 0, 0]

def list.multimap₃ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.length (list.map f t) < list.length t + 1 :=
    by simp [list.map_length, nat.lt_succ_self],
  f h :: list.multimap₃ (list.map f t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩]}

/-!
Proving well-foundedness can be arbitrarily hard.
-/

def f : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then f (n/2)
       else f (3*n + 1)

/-!
All functions in "standard" Lean must terminate, otherwise we could prove false.

But maybe all we want to do is *compute* with the function, and not worry about
proving anything about it.

The keyword *meta* lets us do exactly this.
Like *noncomputable*, *meta* is sticky: anything that references a meta declaration
must be meta itself.
All it does is disable the well-foundedness checker.
-/

meta def g : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then g (n/2)
       else g (3*n + 1)

#eval (list.iota 100).map g

meta def oops : false := oops

/-!

Note that this use of the word "meta" is somewhat misleading.
Nothing is "about Lean" yet, we've just defined a language extension.
Morally speaking, meta definitions are ones that we intend for "computation
purposes only."

## What are tactics, really?

Recall that when we write a tactic proof, it's generating a proof term under the hood.

Between each tactic we can inspect a *proof state*, which has a context and goal.

A tactic behaves like a function from proof state to proof state.
-/

lemma test_lemma : ∀ x, x = 3 → x + 10 = 13 :=
begin
  intros x hx,
  cases hx,
  refl
end

#print test_lemma

/-
But tactics can fail. So they're not total functions.
And tactics can also fail to terminate.
-/

-- example (x y z : ℕ) : x + y + z = z + y + x :=
-- by simp [add_comm x y, add_comm y x]

/-!

So it feels like we have something like

    meta def simp : simp_args → tactic_state → option tactic_state

Which is actually not so far from the truth!

We've mentioned the difference between `#reduce` and `#eval`.
`#eval` is for data only. It doesn't care about proof terms, instead interpreting
expressions in the Lean virtual machine.

It replaces certain data types and operations with more efficient implementations,
e.g. arithmetic on `nat`.

It also replaces certain *constants* with actual data.

-/

#print tactic_state
#print tactic_state.get_options

/-

So a tactic in Lean is like a function `tactic_state → tactic_state`.
It can use these uninterpreted constants like `get_options`.
In a `begin...end` block, Lean generates the initial tactic state.
Then it sequentially calls the tactics in the block, producing a new tactic state.
When a tactic leaves a state that has no goals, the proof is done.

There are some hiccups here.
* "State"? Sounds imperative!
* Stringing together `option`-valued functions sounds annoying.
* How do we write these? Can we read and write to the state at the same time?

These questions aren't unique to Lean -- these are common functional programming issues.
They have a solution: *monads*.

## Monads

Extra reference: https://leanprover.github.io/programming_in_lean/#07_Monads.html

Monads are an abstraction of "programming with side effects."
The side effects we'll be interested in are state and failure.

In general, a __monad__ is a type constructor `m` that depends on some type
parameter `α` (i.e., `m α`) equipped with two distinguished operations:

    `pure {α : Type} : α → m α`
    `bind {α β : Type} : m α → (α → m β) → m β`

Consider the following programming task:

    Implement a function `sum_2_5_7 ns` that sums up the second, fifth, and
    seventh items of a list `ns` of natural numbers. Use `option ℕ` for the
    result so that if the list has fewer than seven elements, you can return
    `option.none`.

A straightforward solution follows: -/

def sum_2_5_7 (ns : list ℕ) : option ℕ :=
match list.nth ns 1 with
| option.none    := option.none
| option.some n2 :=
  match list.nth ns 4 with
  | option.none    := option.none
  | option.some n5 :=
    match list.nth ns 6 with
    | option.none    := option.none
    | option.some n7 := option.some (n2 + n5 + n7)
    end
  end
end

/-!
`option` is a monad with failure. `some v` is the success case,
`none` is the failure case.

If `v : ℕ`, then `pure v = some v`. `bind` is `connect`:
-/

def connect {α : Type} {β : Type} :
  option α → (α → option β) → option β
| option.none     f := option.none
| (option.some a) f := f a

def sum_2_5_7₂ (ns : list ℕ) : option ℕ :=
connect (list.nth ns 1)
  (λn2, connect (list.nth ns 4)
     (λn5, connect (list.nth ns 6)
        (λn7, option.some (n2 + n5 + n7))))

def sum_2_5_7₆ (ns : list ℕ) : option ℕ :=
do
  n2 ← list.nth ns 1,
  n5 ← list.nth ns 4,
  n7 ← list.nth ns 6,
  pure (n2 + n5 + n7)

/-!

Programming with state is also monadic.

`action σ α` is the type of functions that take in a state of type `σ`
and produce a value of type `α`, along with a possibly updated state.
-/

def action (σ α : Type) : Type :=
σ → α × σ

def action.read {σ : Type} : action σ σ :=
λ s, (s, s)

def action.write {σ : Type} (s : σ) : action σ unit :=
λ _, ((), s)

def action.pure {σ α : Type} (a : α) : action σ α :=
λ s, (a, s)

def action.bind {σ : Type} {α β : Type} (ma : action σ α)
    (f : α → action σ β) :
  action σ β :=
λ s, match ma s with
| (a, s') := f a s'
end

@[instance] def action.monad {σ : Type} :
  monad (action σ) :=
{ pure       := @action.pure σ,
  bind       := @action.bind σ }

def nat_action : action ℕ string :=
do
  first_val ← action.read,
  action.write (first_val * 2),
  new_val ← action.read,
  pure (to_string first_val ++ " ---> " ++ to_string new_val)

#eval nat_action 3

/-!

## The tactic monad

tactic α := tactic_state → result tactic_state α

A tactic can read and/or modify the tactic state, and either succeeds
(producing a value of type α) or fails with an exception message.

-/

#print tactic
#print result

#check tactic.local_context

open tactic

meta def my_first_tactic : tactic unit :=
do
  l ← local_context,
  trace l

meta def show_true : tactic unit :=
do applyc `trivial

example (a b c : ℕ) (h : a + b + c = 0) : true :=
begin
  my_first_tactic,
  show_true
end

run_cmd my_first_tactic

meta def apply_and : tactic unit :=
do
  trace "applying and.intro",
  applyc `and.intro

example : true ∧ true :=
begin
  apply_and,
  show_true, show_true
end

meta def apply_and_or_intro : tactic unit :=
do applyc `and.intro <|>
do intro `nv, skip

example : false → true ∧ true :=
begin
  apply_and_or_intro,
  apply_and_or_intro,
  show_true, show_true
end

meta def my_repeat : tactic unit → tactic unit :=
λ t, (do t, my_repeat t) <|> skip

example : false → true ∧ true :=
begin
  my_repeat apply_and_or_intro,
  my_repeat show_true
end

/-!

## Built-in data types

To be properly "meta," our tactics should be able to express
and manipulate Lean programs (= terms).
We see these in Lean as traditional data types. But, like `tactic_state`
and others, the runtime representation of these is different.

-/

#check declaration
#check tactic.get_decl

#check name
#print name

#check `nat
#check `nat.succ

#print prefix name

#check expr
#print expr

#check expr.to_raw_fmt

open tactic

run_cmd do
  d ← get_decl `nat.succ,
  trace d.type.to_raw_fmt

/-!

A closed expression (e.g. the type or body of a declaration in the environment)
should have no occurrences of `local_const` or `mvar`.
`elet` and `macro` can always be expanded.

Bound variables (`var`) are indexed by natural numbers, not names!
The names and types are stored in the binders (`lam` or `pi`).
`var 0` refers to "the variable bound by the closest binder."
`var 1` refers to "the variable bound by the second-closest binder."
And so on.

But often we aren't dealing with closed expressions.
If we get the type of the goal in the middle of a proof, it will probably refer
to things in the local context.
These are represented as local constants, `local_const`.
They have a unique name, pretty-printing name, binder info, and type.

-/

meta def expr.local_unique_name : expr → name
| (expr.local_const nm ppnm bi tp) := nm
| _ := default _

example (a a a : ℕ) : true := by do
  lc ← local_context,
  trace lc,
  trace (lc.map expr.local_unique_name),
  triv

/-!

Things that are already defined in our environment can be accessed as `const`s.
A `const` has a name and list of universe parameters.

Often we won't build these by hand, but use `tactic.mk_const`.
-/

#check expr.const `nat []
run_cmd do
  e ← mk_const `nat,
  trace e.to_raw_fmt

/-!
Building expressions by hand is rather cumbersome. There are ways around this.
`tactic.mk_app` will fill in implicit arguments for you.
-/

#check tactic.mk_app

run_cmd do
  z ← mk_const `nat.zero,
  a ← mk_app `nat.add [z, z],
  trace a,
  if a = z then trace "eq" else trace "neq"

/-!
We can also write *quoted* expressions, like quoted names.
-/

#check `(0 + 0)

/-!
We can insert expressions into quoted expressions using antiquotes:
-/

meta def trace_add_expr (e : expr) : tactic unit :=
trace `(0 + %%e)

run_cmd trace_add_expr `(44)

run_cmd trace_add_expr `(nat)

/-!
Sometimes expr quoting fails. In these cases, we might have to use `pexpr`s.
A pre-expression corresponds to unelaborated, input-level syntax:
implicit arguments have not been filled in yet.

`tactic.to_expr` performs *elaboration*: it turns a `pexpr` into an `expr`.
-/

meta def trace_add_expr' (e : expr) : tactic unit :=
trace `(%%e + %%e)

meta def trace_add_expr' (e : expr) : tactic unit := do
  e ← to_expr ``(%%e + %%e),
  trace e

run_cmd trace_add_expr' `(44)

run_cmd trace_add_expr' `(nat)

/-!
We can walk through expressions, normally and monadically:
-/

#check @expr.fold

#eval expr.fold `(1 + 0) "" (λ e _ s, s ++ ", " ++ to_string e)

#check @expr.mfold

run_cmd expr.mfold `(1 + 0) () (λ e _ _, tactic.trace e)

/-!
One of the most important operations on `expr` is type inference.
-/

run_cmd do
  t ← infer_type `(λ x : ℕ, x + 1),
  trace t

/-!

*Declarations* are stored in the *environment*.
A declaration is an axiom, constant, theorem, or definition.

-/

#check tactic.get_env
#check environment.fold
#check environment.mfold

run_cmd do
  e ← get_env,
  environment.mfold e () (λ d _, tactic.trace (declaration.to_name d))

/-!
## Working with goals and hypotheses

We already saw the tactic `local_context` for getting hypotheses.
`target` returns the type of the goal.
`get_local` retrieves a single hypothesis by name.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  admit

/-!
`tactic.assert` adds a new hypothesis, creating a new goal for its proof.

There are lots of variants.
-/

example (a b c : ℕ) : true :=
by do
  ac ← get_local `a,
  bc ← get_local `b,
  tactic.assert `new_hyp `(%%ac + %%bc = 0),
  trace_state,
  admit,
  admit

#check tactic.assert
#check tactic.assertv
#check @tactic.note
#check @tactic.note_anon

/-!

To modify the goal, we have our familiar `apply` tactic,
in a few variants:

-/

#check tactic.apply
#check tactic.applyc
#check tactic.exact

/-!
There are lots of ways to call the simplifier...
-/

#check tactic.simplify
#check tactic.simp_target
#check tactic.simp_hyp

/-!
If you want the familiar begin..end block syntax, there's
yet another form of quotation: e.g.

    `[simp [lemma1, lemma2] at h]

is of type `tactic unit`.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  `[simp]

/-! ## Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/-! Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def tactic.destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/-! Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by tactic.destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by tactic.destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by tactic.destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/-!
## Interactive parsing

Writing
    destruct_and `h
with the quoted name `h` is ugly. We don't want to do this in our tactic proofs.
And indeed, most of the time, we don't have to:
there's no quoting in `apply h`, `simp [h]`, etc.

There's some trickery going on here at the parser level.
`begin...end` and `by` blocks are parsed in "interactive tactic mode."
When we wrote `by destruct_and` above, Lean first looked for a declaration
called `tactic.interactive.destruct_and`. When it failed to find such a tactic,
it fell back on resolving `destruct_and` in the normal way.
-/

#check @tactic.apply
#check @tactic.interactive.apply

/-!
Instead of taking arguments of type `expr`, `name`, etc., interactive mode tactics
take parser commands.

`setup_tactic_parser` is equivalent to
```
open _root_.lean
open _root_.lean.parser
open _root_.interactive _root_.interactive.types
local postfix `?`:9001 := optional
local postfix *:9001 := many .
```
-/

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and (h : parse ident) : tactic unit :=
tactic.destruct_and h

/-!
`parse ident` is definitionally equal to `name`, but in interactive mode,
we can write it unquoted.
We put this in the `_root_` namespace to escape the `LoVe` namespace.
-/

lemma abc_bc' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and h

#check parse parser.pexpr
#check parse pexpr_list
#check parse ident*
#check parse ident?

end interactive_mode

meta def tactic.destruct_and_anon : tactic unit :=
do
  lc ← local_context,
  lc.mfirst (λ h, destruct_and_helper h)

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and' (h : parse ident?) : tactic unit :=
match h with
| some h' := tactic.destruct_and h'
| none    := tactic.destruct_and_anon
end

lemma abc_bc'' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and'

/-!
Interactive-mode tactics are *always* `tactic unit`.
-/

end interactive_mode

/-!

## Goal management

We know that tactics ultimately need to build a proof term.
How does this actually happen?

At the beginning of a begin...end block where the goal is to prove `T`,
Lean creates a *metavariable* `?m1 : T`.
Tactics that update the goal, like `applyc`,
(partially) assign values to the goal metavariable.
These values can contain new metavariables.

-/

example : true ∧ false :=
by do
  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  let orig_goal := gs.head,
  trace "------",

  applyc `and.intro,

  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  trace "------",

  orig_goal ← instantiate_mvars orig_goal,
  trace orig_goal.to_raw_fmt

/-!
`get_goals` returns a list of metavariables (of type `epxr`),
representing the remaining proof obligations.
*Unifying* these metavariables with other terms will create partial assignments.

(This is a very low-level technique, we don't usually do this in practice!)
-/

example : true :=
by do
  [g] ← get_goals,
  trace g,
  unify g `(trivial),
  gs ← get_goals,
  trace gs,
  set_goals [],
  gs ← get_goals,
  trace gs

/-!
Note that this can also get us in "trouble": we can tell the system we've
finished a proof when we really haven't.
-/

meta def _root_.tactic.interactive.oops : tactic unit :=
do
  mv ← mk_meta_var `(true),
  set_goals [mv]

example : false :=
begin
  oops,
  trivial,
end

/-!

Metavariable assignments are stored in the tactic state.
So the ultimate goal of a begin...end block is:
"write a function tactic_state → tactic_state that assigns the initial goal
metavariable to a term that does not contain any metavariables."

-/

/-!

## Proof by reflection

YOu may have noticed that we can't prove anything about the tactics we write.
But there's a middle ground: sometimes with a bit of meta "wrapper code,"
we can turn proofs about syntax-like operations into actual proof terms.

The general strategy looks like this:
* represent the syntax of some class of formulas in (non-meta) Lean
* define an interpretation function from these formulas to Prop
* define some operation on this syntax, and prove it correct with respect to the interpretation
* write a small bit of meta code that turns a goal into a statement about your reflected syntax

The idea is that the goal left after applying your correctness theorem can be proved by computation.

This is commonly used for evaluation or normalization functions.
`ring`, for example, can be implemented by defining the syntax of ring expressions
and verifying a normalization algorithm:
if
`ring_syntax : Type`,
`interp {α : Type} [ring α] : ring_syntax → α`,
`normalize : ring_syntax → ring_syntax`, then
`∀ r1 r2 : ring_syntax, interp r1 = interp r2 ↔ normalize r1 = normalize r2`.

The meta code looks at a goal `c + a*b = b*a + c`,
constructs `ring_syntax` objects `r1` and `r2` representing both sides,
and changes the goal to showing that `normalize r1 = normalize r2`.
This can be proved by `refl`.

-/

inductive bexpr
| atom : bool → bexpr
| and : bexpr → bexpr → bexpr
| or : bexpr → bexpr → bexpr
| imp : bexpr → bexpr → bexpr
| not : bexpr → bexpr

open bexpr

def interp : bexpr → Prop
| (atom tt) := true
| (atom ff) := false
| (and a b) := interp a ∧ interp b
| (or a b) := interp a ∨ interp b
| (imp a b) := interp a → interp b
| (not b) := ¬ interp b

def normalize : bexpr → bool
| (atom b) := b
| (and a b) := normalize a && normalize b
| (or a b) := normalize a || normalize b
| (imp a b) := (bnot (normalize a)) || normalize b
| (not b) := bnot (normalize b)

theorem normalize_correct (b : bexpr) : normalize b = tt ↔ interp b :=
begin
  induction' b; try {simp [normalize, interp] at *},
  case and : { finish },
  case or : { finish },
  case not : { simpa using not_iff_not.mpr ih },
  case atom: { cases b; simp [normalize, interp] },
  case imp :
  { have h_not : normalize b = ff ↔ ¬ interp b := by simpa using not_iff_not.mpr ih_b,
    finish },
end

meta def bexpr_of_expr : expr → option expr
| `(true) := some `(bexpr.atom tt)
| `(false) := some `(bexpr.atom ff)
| `(%%a ∧ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.and %%(a) %%(b))
| `(%%a ∨ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.or %%(a) %%(b))
| `(%%a → %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.imp %%(a) %%(b))
| `(¬ %%a) := do a ← bexpr_of_expr a, some `(bexpr.not %%(a))
| _ := none

meta def _root_.tactic.interactive.change_goal : tactic unit :=
do
  t ← target,
  match bexpr_of_expr t with
  | some t' := do apply `(iff.mp (normalize_correct %%(t'))), skip
  | none := fail "goal is not a bexpr pattern"
  end

example : (true → true) ∨ false :=
begin
  change_goal,
  refl
end

/-!
You could imagine doing the same with, say, a SAT solver.

Modify `bexpr` to cover all propositional formulas: `atom : ℕ → bexpr`.
Add an argument to `interp`: `dict : ℕ → Prop` assigning atoms to propositions.
`normalize` becomes `is_tautology : bexpr → bool`.
`normalize_correct` becomes
  `is_tautology_correct (b : bexpr) : is_tautology b = tt ↔ ∀ dict, interp dict b`
`bexpr_of_expr` will also have to return a dictionary.

-/

end LoVe


import tactic
import data.real.basic
import data.set
import data.set.lattice
import tactic
import logics

namespace tactic.interactive
open lean.parser tactic interactive
open tactic expr

local postfix *:9001 := many

/- Tente de réécrire le but ou une hypothèse avec un lemme du type "definitions.***"
dans le sens direct, puis dans le sens réciproque -/
-- Ammélioration : utilisation parse location, cf mathlib doc
-- Amélioration vitale : cibler une occurence de la définition
-- Amélioration : pouvoir passer deux hypothèses (ou plus) qui seront combinées en P ∧ Q ; problème =
-- comment les combiner dans le bon ordre ?
-- Amélioration : essayer successivement toutes les versions d'un lemme,
-- terminant par un numéro, e g intersection_2, intersection_ensemble
meta def defi (name : parse ident) (at_hypo : parse (optional (tk "at" *> ident)))
                            : tactic unit :=
do
    let name := "definitions" <.> to_string name,
    trace ("J'appelle le lemme " ++ to_string name ++ ","),
    expr ← mk_const name,
    -- expr ← get_local name,
    -- expr ← (to_expr ``(%%name)),
    match at_hypo with
    | none :=  do {rewrite_target expr, trace "sur le but, sens direct"}
            <|>  do {rewrite_target expr {symm := tt},
                    trace "sur le but, sens réciproque"}
 --   | `(tk "at" %%hypo) := skip,
    | some hypo := do e ← get_local hypo,
                    do {rewrite_hyp expr e,
                 trace ("sur l'hypothèse " ++ (to_string hypo) ++", sens direct")}
                <|>  do {rewrite_hyp expr e {symm := tt},
                 trace ("sur l'hypothèse " ++ (to_string hypo) ++", sens réciproque")}
    end

-- à AMELIORER : essayer simp only si ça rate
meta def applique (names : parse ident*) : tactic unit :=
match names with
    | [H1,H2] := do
         nom_hyp ← get_unused_name `H,
        n1 ← get_local H1,
        n2 ← get_local H2,
        «have» nom_hyp none ``(%%n1 %%n2)
    | _ := fail "Il faut deux paramètres exactement"
    end

-- à AMELIORER
meta def appliquetheo (names : parse ident*) : tactic unit :=
match names with
    | [name,H2] := do
         nom_hyp ← get_unused_name `H,
        let name := "theoremes" <.> to_string name,
        n1 ← mk_const name,
        n2 ← get_local H2,
    «have» nom_hyp none ``(%%n1 %%n2)
    | _ := fail "Il faut deux paramètres exactement"
    end

end tactic.interactive

------------- Lemmes définitionnels ---------------
namespace definitions

------------ Théorie des ensembles --------------
section theorie_des_ensembles

variables {X : Type} {Y : Type}
-- mem_compl_iff
--lemma complement {A : set X} {x : X} : x ∈ - A ↔ ¬ x ∈ A :=
--iff.rfl

lemma complement {A : set X} {x : X} : x ∈ set.univ \ A ↔ x ∉ A :=
by finish

lemma complement_1 {A : set X} {x : X} : x ∈ set.compl A ↔ x ∉ A :=
by finish

lemma complement_2 {A B : set X} {x : X} : x ∈ B \ A ↔ (x ∈ B ∧ x ∉ A) :=
iff.rfl

lemma inclusion (A B : set X) : A ⊆ B ↔ ∀ {{x:X}}, x ∈ A → x ∈ B :=
iff.rfl

lemma intersection_deux  (A B : set X) (x : X) :  x ∈ A ∩ B ↔ ( x ∈ A ∧ x ∈ B) :=
iff.rfl

-- bof : ce n'est pas une définition, mais une caractérisation
lemma intersection_ensemble  (A B C : set X) : C ⊆ A ∩ B ↔ C ⊆ A ∧ C ⊆ B :=
begin
    exact ball_and_distrib
end

lemma intersection_quelconque (I : Type) (O : I → set X)  (x : X) : (x ∈ set.Inter O) ↔ (∀ i:I, x ∈ O i) :=
set.mem_Inter

-- Les deux lemmes suivants seront à regroupé au sein d'une même tactique : essayer le premier,
-- en cas d'échec essayer le second. Un seul bouton dans l'interface graphique
lemma union  (A : set X) (B : set X) (x : X) :  x ∈ A ∪ B ↔ ( x ∈ A ∨ x ∈ B) :=
iff.rfl

lemma union_quelconque (I : Type) (O : I → set X)  (x : X) : (x ∈ set.Union O) ↔ (∃ i:I, x ∈ O i) :=
set.mem_Union

-- mem_image_iff_bex
lemma image  (A : set X)  (f : X → Y) (b : Y) : b ∈ f '' A ↔  ∃ a, a ∈ A ∧ f(a) = b :=
begin
    tidy,
end

lemma image_reciproque  {B : set Y}  {f : X → Y} {a : X} :
                             a ∈ f ⁻¹' B ↔  f a ∈ B :=
                             iff.rfl

lemma ensemble_egal {A A' : set X} : (A = A') ↔ ( ∀ x, x ∈ A ↔ x ∈ A' ) :=
by exact set.ext_iff

lemma double_inclusion {A A' : set X} : (A = A') ↔ (A ⊆ A' ∧ A' ⊆ A) :=
begin
    exact le_antisymm_iff
end

end theorie_des_ensembles

-------------------- LOGIQUE -----------------------
section logique
lemma double_implication (P Q : Prop) : (P ↔ Q) ↔ (P → Q) ∧ (Q → P) := by tautology

end logique

set_option trace.simplify.rewrite true
-- set_option pp.all true
------------------ Nombres -------------------
section nombres
lemma minimum (a b m :ℝ) : m = min a b ↔ (m=a ∨ m=b) ∧ m ≤ a ∧ m ≤ b :=
begin
by_cases a ≤ b,
    simp only [h, min_eq_left],
    split, intro H, rw H, finish,
    finish,

push_neg at h,
have H : min a b = b, by exact min_eq_right_of_lt h,
rw H,
    split,
    intro H', split,
        finish,
    rw H', split, linarith only [h],
    exact le_refl b,
rintro ⟨ H1, H2, H3 ⟩,
cases H1 with Ha Hb,
    exfalso,
    rw Ha at H3,
    linarith only [h, H3],
assumption
end

end nombres
------------------ Topologie -------------------

------------------------------------------------
end definitions


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

/-!
# Matrices over a category.

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

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

`Mat_ C` has finite biproducts.

## The additive envelope

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

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

## Future work

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

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

-/

open category_theory category_theory.preadditive
open_locale big_operators classical
noncomputable theory

namespace category_theory

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

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ :=
(ι : Type)
[F : fintype ι]
(X : ι → C)

attribute [instance] Mat_.F

namespace Mat_

variables {C}

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

namespace hom

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

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

end hom

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

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

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

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

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

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

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

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

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

end

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

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

open category_theory.limits

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

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

end Mat_

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

local attribute [simp] Mat_.id_apply eq_to_hom_map

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

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

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

end functor

namespace Mat_

variables (C)

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

namespace embedding

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

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

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

end embedding

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

open category_theory.limits

variables {C}

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

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

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

variables [has_finite_biproducts D]

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

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

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

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

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

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

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

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

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

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

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

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

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

end Mat_

universe u

/-- A type synonym for `Fintype`, which we will equip with a category structure
where the morphisms are matrices with components in `R`. -/
@[nolint unused_arguments, derive inhabited]
def Mat (R : Type u) := Fintype.{u}

instance (R : Type u) : has_coe_to_sort (Mat R) (Type u) := bundled.has_coe_to_sort

open_locale classical matrix

instance (R : Type u) [semiring R] : category (Mat R) :=
{ hom := λ X Y, matrix X Y R,
  id := λ X, 1,
  comp := λ X Y Z f g, f ⬝ g,
  assoc' := by { intros, simp [matrix.mul_assoc], }, }

namespace Mat

section
variables (R : Type u) [semiring R]

lemma id_def (M : Mat R) :
  𝟙 M = λ i j, if h : i = j then 1 else 0 :=
rfl

lemma id_apply (M : Mat R) (i j : M) :
  (𝟙 M : matrix M M R) i j = if h : i = j then 1 else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat R) (i : M) :
  (𝟙 M : matrix M M R) i i = 1 :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat R) (i j : M) (h : i ≠ j) :
  (𝟙 M : matrix M M R) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N, f i j * g j k := rfl

@[simp] lemma comp_apply {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N, f i j * g j k := rfl

instance (M N : Mat R) : inhabited (M ⟶ N) := ⟨λ (i : M) (j : N), (0 : R)⟩

end

variables (R : Type) [ring R]

open opposite

/-- Auxiliary definition for `category_theory.Mat.equivalence_single_obj`. -/
@[simps]
def equivalence_single_obj_inverse : Mat_ (single_obj Rᵐᵒᵖ) ⥤ Mat R :=
{ obj := λ X, Fintype.of X.ι,
  map := λ X Y f i j, mul_opposite.unop (f i j),
  map_id' := λ X, by { ext i j, simp [id_def, Mat_.id_def], split_ifs; refl, }, }

instance : faithful (equivalence_single_obj_inverse R) :=
{ map_injective' := λ X Y f g w, begin
    ext i j,
    apply_fun mul_opposite.unop using mul_opposite.unop_injective,
    exact (congr_fun (congr_fun w i) j),
  end }

instance : full (equivalence_single_obj_inverse R) :=
{ preimage := λ X Y f i j, mul_opposite.op (f i j), }

instance : ess_surj (equivalence_single_obj_inverse R) :=
{ mem_ess_image := λ X,
  ⟨{ ι := X, X := λ _, punit.star }, ⟨eq_to_iso (by { dsimp, cases X, congr, })⟩⟩, }

/-- The categorical equivalence between the category of matrices over a ring,
and the category of matrices over that ring considered as a single-object category. -/
def equivalence_single_obj : Mat R ≌ Mat_ (single_obj Rᵐᵒᵖ) :=
begin
  haveI := equivalence.of_fully_faithfully_ess_surj (equivalence_single_obj_inverse R),
  exact (equivalence_single_obj_inverse R).as_equivalence.symm,
end

instance : preadditive (Mat R) :=
{ add_comp' := by { intros, ext, simp [add_mul, finset.sum_add_distrib], },
  comp_add' := by { intros, ext, simp [mul_add, finset.sum_add_distrib], }, }

-- TODO show `Mat R` has biproducts, and that `biprod.map` "is" forming a block diagonal matrix.

end Mat

end category_theory


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebraic_topology.dold_kan.functor_n
import algebraic_topology.dold_kan.decomposition
import category_theory.idempotents.homological_complex
import category_theory.idempotents.karoubi_karoubi

/-!

# N₁ and N₂ reflects isomorphisms

In this file, it is shown that the functors
`N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ)` and
`N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ))`
reflect isomorphisms for any preadditive category `C`.

-/

open category_theory
open category_theory.category
open category_theory.idempotents
open opposite
open_locale simplicial

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]

open morph_components

instance : reflects_isomorphisms (N₁ : simplicial_object C ⥤ karoubi (chain_complex C ℕ)) :=
⟨λ X Y f, begin
  introI,
  /- restating the result in a way that allows induction on the degree n -/
  suffices : ∀ (n : ℕ), is_iso (f.app (op [n])),
  { haveI : ∀ (Δ : simplex_categoryᵒᵖ), is_iso (f.app Δ) := λ Δ, this Δ.unop.len,
    apply nat_iso.is_iso_of_is_iso_app, },
  /- restating the assumption in a more practical form -/
  have h₁ := homological_complex.congr_hom (karoubi.hom_ext.mp (is_iso.hom_inv_id (N₁.map f))),
  have h₂ := homological_complex.congr_hom (karoubi.hom_ext.mp (is_iso.inv_hom_id (N₁.map f))),
  have h₃ := λ n, karoubi.homological_complex.p_comm_f_assoc (inv (N₁.map f)) (n) (f.app (op [n])),
  simp only [N₁_map_f, karoubi.comp_f, homological_complex.comp_f,
    alternating_face_map_complex.map_f, N₁_obj_p, karoubi.id_eq, assoc] at h₁ h₂ h₃,
  /- we have to construct an inverse to f in degree n, by induction on n -/
  intro n,
  induction n with n hn,
  /- degree 0 -/
  { use (inv (N₁.map f)).f.f 0,
    have h₁₀ := h₁ 0,
    have h₂₀ := h₂ 0,
    dsimp at h₁₀ h₂₀,
    simp only [id_comp, comp_id] at h₁₀ h₂₀,
    tauto, },
  /- induction step -/
  { haveI := hn,
    use φ
      { a := P_infty.f (n+1) ≫ (inv (N₁.map f)).f.f (n+1),
        b := λ i, inv (f.app (op [n])) ≫ X.σ i, },
    simp only [morph_components.id, ← id_φ, ← pre_comp_φ, pre_comp, ← post_comp_φ,
      post_comp, P_infty_f_naturality_assoc, is_iso.hom_inv_id_assoc, assoc,
      is_iso.inv_hom_id_assoc, simplicial_object.σ_naturality, h₁, h₂, h₃],
    tauto, },
end⟩

lemma compatibility_N₂_N₁_karoubi :
  N₂ ⋙ (karoubi_chain_complex_equivalence C ℕ).functor =
  karoubi_functor_category_embedding simplex_categoryᵒᵖ C ⋙ N₁ ⋙
  (karoubi_chain_complex_equivalence (karoubi C) ℕ).functor ⋙
  functor.map_homological_complex (karoubi_karoubi.equivalence C).inverse _ :=
begin
  refine category_theory.functor.ext (λ P, _) (λ P Q f, _),
  { refine homological_complex.ext _ _,
    { ext n,
      { dsimp,
        simp only [karoubi_P_infty_f, comp_id, P_infty_f_naturality, id_comp], },
      { refl, }, },
    { rintros _ n (rfl : n+1 = _),
      ext,
      have h := (alternating_face_map_complex.map P.p).comm (n+1) n,
      dsimp [N₂, karoubi_chain_complex_equivalence, karoubi_karoubi.inverse,
        karoubi_homological_complex_equivalence.functor.obj] at ⊢ h,
      simp only [karoubi.comp_f, assoc, karoubi.eq_to_hom_f, eq_to_hom_refl, id_comp, comp_id,
        karoubi_alternating_face_map_complex_d, karoubi_P_infty_f,
        ← homological_complex.hom.comm_assoc, ← h, app_idem_assoc], }, },
  { ext n,
    dsimp [karoubi_karoubi.inverse, karoubi_functor_category_embedding,
      karoubi_functor_category_embedding.map],
    simp only [karoubi.comp_f, karoubi_P_infty_f, homological_complex.eq_to_hom_f,
      karoubi.eq_to_hom_f, assoc, comp_id, P_infty_f_naturality, app_p_comp,
      karoubi_chain_complex_equivalence_functor_obj_X_p, N₂_obj_p_f, eq_to_hom_refl,
      P_infty_f_naturality_assoc, app_comp_p, P_infty_f_idem_assoc], },
end

/-- We deduce that `N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ))`
reflects isomorphisms from the fact that
`N₁ : simplicial_object (karoubi C) ⥤ karoubi (chain_complex (karoubi C) ℕ)` does. -/
instance : reflects_isomorphisms
  (N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ)) := ⟨λ X Y f,
begin
  introI,
  -- The following functor `F` reflects isomorphism because it is
  -- a composition of four functors which reflects isomorphisms.
  -- Then, it suffices to show that `F.map f` is an isomorphism.
  let F := karoubi_functor_category_embedding simplex_categoryᵒᵖ C ⋙ N₁ ⋙
    (karoubi_chain_complex_equivalence (karoubi C) ℕ).functor ⋙
    functor.map_homological_complex (karoubi_karoubi.equivalence C).inverse
      (complex_shape.down ℕ),
  haveI : is_iso (F.map f),
  { dsimp only [F],
    rw [← compatibility_N₂_N₁_karoubi, functor.comp_map],
    apply functor.map_is_iso, },
  exact is_iso_of_reflects_iso f F,
end⟩

end dold_kan

end algebraic_topology


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.endomorphism
import Mathlib.algebra.group_power.default
import Mathlib.PostPort

universes u v v₁ u₁

namespace Mathlib

/-!
# Conjugate morphisms by isomorphisms

An isomorphism `α : X ≅ Y` defines
- a monoid isomorphism `conj : End X ≃* End Y` by `α.conj f = α.inv ≫ f ≫ α.hom`;
- a group isomorphism `conj_Aut : Aut X ≃* Aut Y` by `α.conj_Aut f = α.symm ≪≫ f ≪≫ α`.

For completeness, we also define `hom_congr : (X ≅ X₁) → (Y ≅ Y₁) → (X ⟶ Y) ≃ (X₁ ⟶ Y₁)`, cf. `equiv.arrow_congr`.
-/

namespace category_theory

namespace iso

/-- If `X` is isomorphic to `X₁` and `Y` is isomorphic to `Y₁`, then
there is a natural bijection between `X ⟶ Y` and `X₁ ⟶ Y₁`. See also `equiv.arrow_congr`. -/
def hom_congr {C : Type u} [category C] {X : C} {Y : C} {X₁ : C} {Y₁ : C} (α : X ≅ X₁) (β : Y ≅ Y₁) : (X ⟶ Y) ≃ (X₁ ⟶ Y₁) :=
  equiv.mk (fun (f : X ⟶ Y) => inv α ≫ f ≫ hom β) (fun (f : X₁ ⟶ Y₁) => hom α ≫ f ≫ inv β) sorry sorry

@[simp] theorem hom_congr_apply {C : Type u} [category C] {X : C} {Y : C} {X₁ : C} {Y₁ : C} (α : X ≅ X₁) (β : Y ≅ Y₁) (f : X ⟶ Y) : coe_fn (hom_congr α β) f = inv α ≫ f ≫ hom β :=
  rfl

theorem hom_congr_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {X₁ : C} {Y₁ : C} {Z₁ : C} (α : X ≅ X₁) (β : Y ≅ Y₁) (γ : Z ≅ Z₁) (f : X ⟶ Y) (g : Y ⟶ Z) : coe_fn (hom_congr α γ) (f ≫ g) = coe_fn (hom_congr α β) f ≫ coe_fn (hom_congr β γ) g := sorry

@[simp] theorem hom_congr_refl {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) : coe_fn (hom_congr (refl X) (refl Y)) f = f := sorry

@[simp] theorem hom_congr_trans {C : Type u} [category C] {X₁ : C} {Y₁ : C} {X₂ : C} {Y₂ : C} {X₃ : C} {Y₃ : C} (α₁ : X₁ ≅ X₂) (β₁ : Y₁ ≅ Y₂) (α₂ : X₂ ≅ X₃) (β₂ : Y₂ ≅ Y₃) (f : X₁ ⟶ Y₁) : coe_fn (hom_congr (α₁ ≪≫ α₂) (β₁ ≪≫ β₂)) f = coe_fn (equiv.trans (hom_congr α₁ β₁) (hom_congr α₂ β₂)) f := sorry

@[simp] theorem hom_congr_symm {C : Type u} [category C] {X₁ : C} {Y₁ : C} {X₂ : C} {Y₂ : C} (α : X₁ ≅ X₂) (β : Y₁ ≅ Y₂) : equiv.symm (hom_congr α β) = hom_congr (symm α) (symm β) :=
  rfl

/-- An isomorphism between two objects defines a monoid isomorphism between their
monoid of endomorphisms. -/
def conj {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) : End X ≃* End Y :=
  mul_equiv.mk (equiv.to_fun (hom_congr α α)) (equiv.inv_fun (hom_congr α α)) sorry sorry sorry

theorem conj_apply {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : End X) : coe_fn (conj α) f = inv α ≫ f ≫ hom α :=
  rfl

@[simp] theorem conj_comp {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : End X) (g : End X) : coe_fn (conj α) (f ≫ g) = coe_fn (conj α) f ≫ coe_fn (conj α) g :=
  mul_equiv.map_mul (conj α) g f

@[simp] theorem conj_id {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) : coe_fn (conj α) 𝟙 = 𝟙 :=
  mul_equiv.map_one (conj α)

@[simp] theorem refl_conj {C : Type u} [category C] {X : C} (f : End X) : coe_fn (conj (refl X)) f = f := sorry

@[simp] theorem trans_conj {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) {Z : C} (β : Y ≅ Z) (f : End X) : coe_fn (conj (α ≪≫ β)) f = coe_fn (conj β) (coe_fn (conj α) f) :=
  hom_congr_trans α α β β f

@[simp] theorem symm_self_conj {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : End X) : coe_fn (conj (symm α)) (coe_fn (conj α) f) = f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (conj (symm α)) (coe_fn (conj α) f) = f)) (Eq.symm (trans_conj α (symm α) f))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (conj (α ≪≫ symm α)) f = f)) (self_symm_id α)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (conj (refl X)) f = f)) (refl_conj f))) (Eq.refl f)))

@[simp] theorem self_symm_conj {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : End Y) : coe_fn (conj α) (coe_fn (conj (symm α)) f) = f :=
  symm_self_conj (symm α) f

@[simp] theorem conj_pow {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : End X) (n : ℕ) : coe_fn (conj α) (f ^ n) = coe_fn (conj α) f ^ n :=
  monoid_hom.map_pow (mul_equiv.to_monoid_hom (conj α)) f n

/-- `conj` defines a group isomorphisms between groups of automorphisms -/
def conj_Aut {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) : Aut X ≃* Aut Y :=
  mul_equiv.trans (mul_equiv.symm (Aut.units_End_equiv_Aut X))
    (mul_equiv.trans (units.map_equiv (conj α)) (Aut.units_End_equiv_Aut Y))

theorem conj_Aut_apply {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) : coe_fn (conj_Aut α) f = symm α ≪≫ f ≪≫ α := sorry

@[simp] theorem conj_Aut_hom {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) : hom (coe_fn (conj_Aut α) f) = coe_fn (conj α) (hom f) :=
  rfl

@[simp] theorem trans_conj_Aut {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) {Z : C} (β : Y ≅ Z) (f : Aut X) : coe_fn (conj_Aut (α ≪≫ β)) f = coe_fn (conj_Aut β) (coe_fn (conj_Aut α) f) := sorry

@[simp] theorem conj_Aut_mul {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) (g : Aut X) : coe_fn (conj_Aut α) (f * g) = coe_fn (conj_Aut α) f * coe_fn (conj_Aut α) g :=
  mul_equiv.map_mul (conj_Aut α) f g

@[simp] theorem conj_Aut_trans {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) (g : Aut X) : coe_fn (conj_Aut α) (f ≪≫ g) = coe_fn (conj_Aut α) f ≪≫ coe_fn (conj_Aut α) g :=
  conj_Aut_mul α g f

@[simp] theorem conj_Aut_pow {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) (n : ℕ) : coe_fn (conj_Aut α) (f ^ n) = coe_fn (conj_Aut α) f ^ n :=
  monoid_hom.map_pow (mul_equiv.to_monoid_hom (conj_Aut α)) f n

@[simp] theorem conj_Aut_gpow {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) (n : ℤ) : coe_fn (conj_Aut α) (f ^ n) = coe_fn (conj_Aut α) f ^ n :=
  monoid_hom.map_gpow (mul_equiv.to_monoid_hom (conj_Aut α)) f n

end iso

namespace functor

theorem map_hom_congr {C : Type u} [category C] {D : Type u₁} [category D] (F : C ⥤ D) {X : C} {Y : C} {X₁ : C} {Y₁ : C} (α : X ≅ X₁) (β : Y ≅ Y₁) (f : X ⟶ Y) : map F (coe_fn (iso.hom_congr α β) f) = coe_fn (iso.hom_congr (map_iso F α) (map_iso F β)) (map F f) := sorry

theorem map_conj {C : Type u} [category C] {D : Type u₁} [category D] (F : C ⥤ D) {X : C} {Y : C} (α : X ≅ Y) (f : End X) : map F (coe_fn (iso.conj α) f) = coe_fn (iso.conj (map_iso F α)) (map F f) :=
  map_hom_congr F α α f

theorem map_conj_Aut {C : Type u} [category C] {D : Type u₁} [category D] (F : C ⥤ D) {X : C} {Y : C} (α : X ≅ Y) (f : Aut X) : map_iso F (coe_fn (iso.conj_Aut α) f) = coe_fn (iso.conj_Aut (map_iso F α)) (map_iso F f) := sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.strong_epi
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes v₁ u₁ l

namespace Mathlib

/-!
# Definitions and basic properties of regular monomorphisms and epimorphisms.

A regular monomorphism is a morphism that is the equalizer of some parallel pair.

We give the constructions
* `split_mono → regular_mono` and
* `regular_mono → mono`
as well as the dual constructions for regular epimorphisms. Additionally, we give the
construction
* `regular_epi ⟶ strong_epi`.

-/

namespace category_theory

/-- A regular monomorphism is a morphism which is the equalizer of some parallel pair. -/
class regular_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  Z : C
  left : Y ⟶ Z
  right : Y ⟶ Z
  w : f ≫ left = f ≫ right
  is_limit : limits.is_limit (limits.fork.of_ι f w)

theorem regular_mono.w_assoc {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    [c : regular_mono f] {X' : C} (f' : regular_mono.Z f ⟶ X') :
    f ≫ regular_mono.left ≫ f' = f ≫ regular_mono.right ≫ f' :=
  sorry

/-- Every regular monomorphism is a monomorphism. -/
protected instance regular_mono.mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [regular_mono f] : mono f :=
  limits.mono_of_is_limit_parallel_pair regular_mono.is_limit

protected instance equalizer_regular {C : Type u₁} [category C] {X : C} {Y : C} (g : X ⟶ Y)
    (h : X ⟶ Y) [limits.has_limit (limits.parallel_pair g h)] :
    regular_mono (limits.equalizer.ι g h) :=
  regular_mono.mk Y g h (limits.equalizer.condition g h)
    (limits.fork.is_limit.mk
      (limits.fork.of_ι (limits.equalizer.ι g h) (limits.equalizer.condition g h))
      (fun (s : limits.fork g h) => limits.limit.lift (limits.parallel_pair g h) s) sorry sorry)

/-- Every split monomorphism is a regular monomorphism. -/
protected instance regular_mono.of_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_mono f] : regular_mono f :=
  regular_mono.mk Y 𝟙 (retraction f ≫ f) (limits.cone_of_split_mono._proof_1 f)
    (limits.split_mono_equalizes f)

/-- If `f` is a regular mono, then any map `k : W ⟶ Y` equalizing `regular_mono.left` and
    `regular_mono.right` induces a morphism `l : W ⟶ X` such that `l ≫ f = k`. -/
def regular_mono.lift' {C : Type u₁} [category C] {X : C} {Y : C} {W : C} (f : X ⟶ Y)
    [regular_mono f] (k : W ⟶ Y) (h : k ≫ regular_mono.left = k ≫ regular_mono.right) :
    Subtype fun (l : W ⟶ X) => l ≫ f = k :=
  limits.fork.is_limit.lift' regular_mono.is_limit k h

/--
The second leg of a pullback cone is a regular monomorphism if the right component is too.

See also `pullback.snd_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_fst_of_regular` for the flipped version.
-/
def regular_of_is_pullback_snd_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C}
    {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [hr : regular_mono h] (comm : f ≫ h = g ≫ k)
    (t : limits.is_limit (limits.pullback_cone.mk f g comm)) : regular_mono g :=
  sorry

/--
The first leg of a pullback cone is a regular monomorphism if the left component is too.

See also `pullback.fst_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_snd_of_regular` for the flipped version.
-/
def regular_of_is_pullback_fst_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C}
    {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [hr : regular_mono k] (comm : f ≫ h = g ≫ k)
    (t : limits.is_limit (limits.pullback_cone.mk f g comm)) : regular_mono f :=
  regular_of_is_pullback_snd_of_regular sorry (limits.pullback_cone.flip_is_limit t)

/-- A regular monomorphism is an isomorphism if it is an epimorphism. -/
def is_iso_of_regular_mono_of_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [regular_mono f] [e : epi f] : is_iso f :=
  limits.is_iso_limit_cone_parallel_pair_of_epi regular_mono.is_limit

/-- A regular epimorphism is a morphism which is the coequalizer of some parallel pair. -/
class regular_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  W : C
  left : W ⟶ X
  right : W ⟶ X
  w : left ≫ f = right ≫ f
  is_colimit : limits.is_colimit (limits.cofork.of_π f w)

theorem regular_epi.w_assoc {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y}
    [c : regular_epi f] {X' : C} (f' : Y ⟶ X') :
    regular_epi.left ≫ f ≫ f' = regular_epi.right ≫ f ≫ f' :=
  sorry

/-- Every regular epimorphism is an epimorphism. -/
protected instance regular_epi.epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [regular_epi f] : epi f :=
  limits.epi_of_is_colimit_parallel_pair regular_epi.is_colimit

protected instance coequalizer_regular {C : Type u₁} [category C] {X : C} {Y : C} (g : X ⟶ Y)
    (h : X ⟶ Y) [limits.has_colimit (limits.parallel_pair g h)] :
    regular_epi (limits.coequalizer.π g h) :=
  regular_epi.mk X g h (limits.coequalizer.condition g h)
    (limits.cofork.is_colimit.mk
      (limits.cofork.of_π (limits.coequalizer.π g h) (limits.coequalizer.condition g h))
      (fun (s : limits.cofork g h) => limits.colimit.desc (limits.parallel_pair g h) s) sorry sorry)

/-- Every split epimorphism is a regular epimorphism. -/
protected instance regular_epi.of_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [split_epi f] : regular_epi f :=
  regular_epi.mk X 𝟙 (f ≫ section_ f) (limits.cocone_of_split_epi._proof_1 f)
    (limits.split_epi_coequalizes f)

/-- If `f` is a regular epi, then every morphism `k : X ⟶ W` coequalizing `regular_epi.left` and
    `regular_epi.right` induces `l : Y ⟶ W` such that `f ≫ l = k`. -/
def regular_epi.desc' {C : Type u₁} [category C] {X : C} {Y : C} {W : C} (f : X ⟶ Y) [regular_epi f]
    (k : X ⟶ W) (h : regular_epi.left ≫ k = regular_epi.right ≫ k) :
    Subtype fun (l : Y ⟶ W) => f ≫ l = k :=
  limits.cofork.is_colimit.desc' regular_epi.is_colimit k h

/--
The second leg of a pushout cocone is a regular epimorphism if the right component is too.

See also `pushout.snd_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_fst_of_regular` for the flipped version.
-/
def regular_of_is_pushout_snd_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C}
    {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [gr : regular_epi g] (comm : f ≫ h = g ≫ k)
    (t : limits.is_colimit (limits.pushout_cocone.mk h k comm)) : regular_epi h :=
  sorry

/--
The first leg of a pushout cocone is a regular epimorphism if the left component is too.

See also `pushout.fst_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_snd_of_regular` for the flipped version.
-/
def regular_of_is_pushout_fst_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C}
    {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [fr : regular_epi f] (comm : f ≫ h = g ≫ k)
    (t : limits.is_colimit (limits.pushout_cocone.mk h k comm)) : regular_epi k :=
  regular_of_is_pushout_snd_of_regular sorry (limits.pushout_cocone.flip_is_colimit t)

/-- A regular epimorphism is an isomorphism if it is a monomorphism. -/
def is_iso_of_regular_epi_of_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [regular_epi f] [m : mono f] : is_iso f :=
  limits.is_iso_limit_cocone_parallel_pair_of_epi regular_epi.is_colimit

protected instance strong_epi_of_regular_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [regular_epi f] : strong_epi f :=
  sorry

end Mathlib


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.concrete_category.basic

/-!
# The category of pointed types

This defines `Pointed`, the category of pointed types.

## TODO

* Monoidal structure
* Upgrade `Type_to_Pointed` to an equivalence
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of pointed types. -/
structure Pointed : Type.{u + 1} :=
(X : Type.{u})
(point : X)

namespace Pointed

instance : has_coe_to_sort Pointed Type* := ⟨X⟩

attribute [protected] Pointed.X

/-- Turns a point into a pointed type. -/
def of {X : Type*} (point : X) : Pointed := ⟨X, point⟩

@[simp] lemma coe_of {X : Type*} (point : X) : ↥(of point) = X := rfl

alias of ← prod.Pointed

instance : inhabited Pointed := ⟨of ((), ())⟩

/-- Morphisms in `Pointed`. -/
@[ext] protected structure hom (X Y : Pointed.{u}) : Type u :=
(to_fun : X → Y)
(map_point : to_fun X.point = Y.point)

namespace hom

/-- The identity morphism of `X : Pointed`. -/
@[simps] def id (X : Pointed) : hom X X := ⟨id, rfl⟩

instance (X : Pointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Pointed`. -/
@[simps] def comp {X Y Z : Pointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_point, g.map_point]⟩

end hom

instance large_category : large_category Pointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Pointed :=
{ forget := { obj := Pointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Constructs a isomorphism between pointed types from an equivalence that preserves the point
between them. -/
@[simps] def iso.mk {α β : Pointed} (e : α ≃ β) (he : e α.point = β.point) : α ≅ β :=
{ hom := ⟨e, he⟩,
  inv := ⟨e.symm, e.symm_apply_eq.2 he.symm⟩,
  hom_inv_id' := Pointed.hom.ext _ _ e.symm_comp_self,
  inv_hom_id' := Pointed.hom.ext _ _ e.self_comp_symm }

end Pointed

/-- `option` as a functor from types to pointed types. This is the free functor. -/
@[simps] def Type_to_Pointed : Type.{u} ⥤ Pointed.{u} :=
{ obj := λ X, ⟨option X, none⟩,
  map := λ X Y f, ⟨option.map f, rfl⟩,
  map_id' := λ X, Pointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Pointed.hom.ext _ _ (option.map_comp_map _ _).symm }

/-- `Type_to_Pointed` is the free functor. -/
def Type_to_Pointed_forget_adjunction : Type_to_Pointed ⊣ forget Pointed :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, f.to_fun ∘ option.some,
                        inv_fun := λ f, ⟨λ o, o.elim Y.point f, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_point.symm, refl },
                        right_inv := λ f, funext $ λ _, rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl }, }


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Extends the theory on functors, applicatives and monads.
-/

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

notation a ` $< `:1 f:1 := f a

section functor
variables {f : Type u → Type v} [functor f] [is_lawful_functor f]

run_cmd mk_simp_attr `functor_norm

@[functor_norm] protected theorem map_map (m : α → β) (g : β → γ) (x : f α) :
  g <$> (m <$> x) = (g ∘ m) <$> x :=
(comp_map _ _ _).symm

@[simp] theorem id_map' (x : f α) : (λa, a) <$> x = x := id_map _

end functor

section applicative
variables {F : Type u → Type v} [applicative F]

def mzip_with
  {α₁ α₂ φ : Type u}
  (f : α₁ → α₂ → F φ) :
  Π (ma₁ : list α₁) (ma₂: list α₂), F (list φ)
| (x :: xs) (y :: ys) := (::) <$> f x y <*> mzip_with xs ys
| _ _ := pure []

def mzip_with'  (f : α → β → F γ) : list α → list β → F punit
| (x :: xs) (y :: ys) := f x y *> mzip_with' xs ys
| [] _ := pure punit.star
| _ [] := pure punit.star

protected def option.traverse {α β : Type*} (f : α → F β) : option α → F (option β)
| none := pure none
| (some x) := some <$> f x

protected def list.traverse {α β : Type*} (f : α → F β) : list α → F (list β)
| [] := pure []
| (x :: xs) := list.cons <$> f x <*> list.traverse xs

variables [is_lawful_applicative F]

attribute [functor_norm] seq_assoc pure_seq_eq_map

@[simp] theorem pure_id'_seq (x : F α) : pure (λx, x) <*> x = x :=
pure_id_seq x

variables  [is_lawful_applicative F]

attribute [functor_norm] seq_assoc pure_seq_eq_map

@[functor_norm] theorem seq_map_assoc (x : F (α → β)) (f : γ → α) (y : F γ) :
  (x <*> (f <$> y)) = (λ(m:α→β), m ∘ f) <$> x <*> y :=
begin
  simp [(pure_seq_eq_map _ _).symm],
  simp [seq_assoc, (comp_map _ _ _).symm, (∘)],
  simp [pure_seq_eq_map]
end

@[functor_norm] theorem map_seq (f : β → γ) (x : F (α → β)) (y : F α) :
  (f <$> (x <*> y)) = ((∘) f) <$> x <*> y :=
by simp [(pure_seq_eq_map _ _).symm]; simp [seq_assoc]

end applicative

-- TODO: setup `functor_norm` for `monad` laws
section monad
variables {m : Type u → Type v} [monad m] [is_lawful_monad m]

open list

def list.mpartition {f : Type → Type} [monad f] {α : Type} (p : α → f bool) :
  list α → f (list α × list α)
| [] := pure ([],[])
| (x :: xs) :=
mcond (p x) (prod.map (cons x) id <$> list.mpartition xs)
            (prod.map id (cons x) <$> list.mpartition xs)

lemma map_bind (x : m α) {g : α → m β} {f : β → γ} : f <$> (x >>= g) = (x >>= λa, f <$> g a) :=
by rw [← bind_pure_comp_eq_map,bind_assoc]; simp [bind_pure_comp_eq_map]

lemma seq_bind_eq (x : m α) {g : β → m γ} {f : α → β} : (f <$> x) >>= g = (x >>= g ∘ f) :=
show bind (f <$> x) g = bind x (g ∘ f),
by rw [← bind_pure_comp_eq_map, bind_assoc]; simp [pure_bind]

lemma seq_eq_bind_map {x : m α} {f : m (α → β)} : f <*> x = (f >>= (<$> x)) :=
(bind_map_eq_seq m f x).symm

end monad

section alternative
variables {F : Type → Type v} [alternative F]

def succeeds {α} (x : F α) : F bool := (x $> tt) <|> pure ff

def mtry {α} (x : F α) : F unit := (x $> ()) <|> pure ()

@[simp] theorem guard_true {h : decidable true} :
  @guard F _ true h = pure () := by simp [guard]

@[simp] theorem guard_false {h : decidable false} :
  @guard F _ false h = failure := by simp [guard]

end alternative

class is_comm_applicative (m : Type* → Type*) [applicative m] extends is_lawful_applicative m : Prop :=
(commutative_prod : ∀{α β} (a : m α) (b : m β), prod.mk <$> a <*> b = (λb a, (a, b)) <$> b <*> a)

lemma is_comm_applicative.commutative_map
  {m : Type* → Type*} [applicative m] [is_comm_applicative m]
  {α β γ} (a : m α) (b : m β) {f : α → β → γ} :
  f <$> a <*> b = flip f <$> b <*> a :=
calc f <$> a <*> b = (λp:α×β, f p.1 p.2) <$> (prod.mk <$> a <*> b) :
    by simp [seq_map_assoc, map_seq, seq_assoc, seq_pure, map_map]
  ... = (λb a, f a b) <$> b <*> a :
    by rw [is_comm_applicative.commutative_prod];
        simp [seq_map_assoc, map_seq, seq_assoc, seq_pure, map_map]


import MyNat.Definition
/-!
## Tactic : by_cases

## Summary

`by_cases h : P` does a cases split on whether `P` is true or false.

## Details

Some logic goals cannot be proved with `intro` and `apply` and `exact`.
The simplest example is the law of the excluded middle `¬ ¬ P → P`.
You can prove this using truth tables but not with `intro`, `apply` etc.
To do a truth table proof, the tactic `by_cases h : P` will turn a goal of
`⊢ ¬ ¬ P → P` into two goals

```
P : Prop,
h : P
⊢ ¬¬P → P

P : Prop,
h : ¬P
⊢ ¬¬P → P
```

Each of these can now be proved using `intro`, `apply`, `exact` and `exfalso`.
Remember though that in these simple logic cases, high-powered logic
tactics like `cc` and `tauto!` will just prove everything.
-/


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

import tactic.monotonicity
import order.basic

open tactic interactive (parse) interactive (loc.ns)
     interactive.types (texpr location) lean.parser (tk)

local postfix `?`:9001 := optional

/--
    But : change _ = _  `name`   `at` h
    c'est en deux temps :
        1. change _ = _ motif at
        2. rw name

    même syntaxe que bidule  tk parse `using` appliquer change avant

-/
meta def apply_fun_name (e : pexpr) (h : name) (M : option pexpr) : tactic unit :=
do {
  H ← get_local h,
  t ← infer_type H,
  match t with
  | `(%%l = %%r) := do
      ltp ← infer_type l,
      mv ← mk_mvar,
      to_expr ``(congr_arg (%%e : %%ltp → %%mv) %%H) >>= note h,
      clear H
  | _ := skip
  end,
  -- let's try to force β-reduction at `h`
  try (tactic.interactive.dsimp tt [] [] (loc.ns [h])
         {eta := false, beta := true})
} <|> fail ("failed to apply " ++ to_string e ++ " at " ++ to_string h)

namespace tactic.interactive
/--
Apply a function to some local assumptions which are either equalities
or inequalities. For instance, if the context contains `h : a = b` and
some function `f` then `apply_fun f at h` turns `h` into
`h : f a = f b`. When the assumption is an inequality `h : a ≤ b`, a side
goal `monotone f` is created, unless this condition is provided using
`apply_fun f at h using P` where `P : monotone f`, or the `mono` tactic
can prove it.

Typical usage is:
```lean
open function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : injective $ g ∘ f) :
  injective f :=
begin
  intros x x' h,
  apply_fun g at h,
  exact H h
end
```
 -/
meta def apply_fun (q : parse texpr) (locs : parse location)
  (lem : parse (tk "using" *> texpr)?) : tactic unit :=
--do e ← tactic.i_to_expr q,
   match locs with
   | (loc.ns l) := do
      l.mmap' (λ l, match l with
      | some h :=  apply_fun_name q h lem
      | none := skip
      end)
   | wildcard := do ctx ← local_context,
                    ctx.mmap' (λ h, apply_fun_name q h.local_pp_name lem)
   end
end tactic.interactive

add_tactic_doc
{ name       := "apply_fun",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_fun],
  tags       := ["context management"] }

open function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : injective $ g ∘ f) :
  injective f :=
begin
  intros x x' h,
  apply_fun g at h,
  exact H h
end


import Smt

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


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

Lemmas about traversing collections.

Inspired by:

    The Essence of the Iterator Pattern
    Jeremy Gibbons and Bruno César dos Santos Oliveira
    In Journal of Functional Programming. Vol. 19. No. 3&4. Pages 377−402. 2009.
    http://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf
-/

import tactic.cache
import category.traversable.basic

universe variables u

open is_lawful_traversable
open function (hiding comp)
open functor

attribute [functor_norm] is_lawful_traversable.naturality
attribute [simp] is_lawful_traversable.id_traverse

namespace traversable

variable {t : Type u → Type u}
variables [traversable t] [is_lawful_traversable t]
variables F G : Type u → Type u

variables [applicative F] [is_lawful_applicative F]
variables [applicative G] [is_lawful_applicative G]
variables {α β γ : Type u}
variables g : α → F β
variables h : β → G γ
variables f : β → γ

def pure_transformation : applicative_transformation id F :=
{ app := @pure F _,
  preserves_pure' := λ α x, rfl,
  preserves_seq' := λ α β f x, by simp; refl }

@[simp] theorem pure_transformation_apply {α} (x : id α) :
  (pure_transformation F) x = pure x := rfl

variables {F G} (x : t β)

lemma map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
funext $ λ y, (traverse_eq_map_id f y).symm

theorem map_traverse (x : t α) :
  map f <$> traverse g x = traverse (map f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ f,
  refine (comp_traverse (id.mk ∘ f) g x).symm.trans _,
  congr, apply comp.applicative_comp_id
end

theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
  traverse f (g <$> x) = traverse (f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ g,
  refine (comp_traverse f (id.mk ∘ g) x).symm.trans _,
  congr, apply comp.applicative_id_comp
end

lemma pure_traverse (x : t α) :
  traverse pure x = (pure x : F (t α)) :=
by have : traverse pure x = pure (traverse id.mk x) :=
     (naturality (pure_transformation F) id.mk x).symm;
   rwa id_traverse at this

lemma id_sequence (x : t α) :
  sequence (id.mk <$> x) = id.mk x :=
by simp [sequence, traverse_map, id_traverse]; refl

lemma comp_sequence (x : t (F (G α))) :
  sequence (comp.mk <$> x) = comp.mk (sequence <$> sequence x) :=
by simp [sequence, traverse_map]; rw ← comp_traverse; simp [map_id]

lemma naturality' (η : applicative_transformation F G) (x : t (F α)) :
  η (sequence x) = sequence (@η _ <$> x) :=
by simp [sequence, naturality, traverse_map]

@[functor_norm]
lemma traverse_id :
  traverse id.mk = (id.mk : t α → id (t α)) :=
by ext; simp [id_traverse]; refl

@[functor_norm]
lemma traverse_comp (g : α → F β) (h : β → G γ) :
  traverse (comp.mk ∘ map h ∘ g) =
  (comp.mk ∘ map (traverse h) ∘ traverse g : t α → comp F G (t γ)) :=
by ext; simp [comp_traverse]

lemma traverse_eq_map_id' (f : β → γ) :
  traverse (id.mk ∘ f) =
  id.mk ∘ (map f : t β → t γ) :=
by ext;rw traverse_eq_map_id

-- @[functor_norm]
lemma traverse_map' (g : α → β) (h : β → G γ) :
  traverse (h ∘ g) =
  (traverse h ∘ map g : t α → G (t γ)) :=
by ext; simp [traverse_map]

lemma map_traverse' (g : α → G β) (h : β → γ) :
  traverse (map h ∘ g) =
  (map (map h) ∘ traverse g : t α → G (t γ)) :=
by ext; simp [map_traverse]

lemma naturality_pf (η : applicative_transformation F G) (f : α → F β) :
  traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
by ext; simp [naturality]

end traversable