import .homotopy_classes

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open homotopy_theory.cylinder

section C
parameters {C : Type u} [category.{v} C]
  [has_initial_object.{v} C] [has_coproducts.{v} C] [I_category.{v} C]

parameters {a b : C} {j : a ⟶ b} (hj : is_cof j)

section
/-

Suppose f₀ : b → x is a map and G is a homotopy from u = f₀ ∘ j to
some other map u' : a → x. Using the homotopy extension property of j,
we obtain a homotopy f₀ ≃ f₁ extending G to a map f₁ with f₁ ∘ j = u'.
We show below that this construction is well-defined up to homotopy
rel j and defines a bijection between homotopy classes rel j of maps
extending u and homotopy classes rel j of maps extending u'.

This correspondence is not constructive in either direction since we
need to use the HEP, which is a mere existence statement. Therefore we
describe it as a relation and show that a homotopy class on either
side is related to a unique homotopy class on the other side.

We call this the "drag" relation induced by G, and imagine dragging
the restriction of f₀ to a along the homotopy G, with the rest of f₀
following along. A familiar example is the isomorphism πₙ(X, x) ≃
πₙ(X, y) induced by a path γ : x ↝ y in X.

-/

parameters {x : C}
include hj

section dir
-- Abstract over the direction of "dragging": f₀ to f₁ or f₁ to f₀.
parameters (u : endpoint → (a ⟶ x))
parameters (ε : endpoint) (G : homotopy_dir ε (u ε) (u ε.v))
include G

def drag_rel_dir : maps_extending hj (u ε) → maps_extending hj (u ε.v) → Prop :=
λ fε fεv, ∃ H : homotopy_dir ε fε.val fεv.val, H.H ∘ I &> j = G.H

lemma total (fε : maps_extending hj (u ε)) : ∃ fεv, drag_rel_dir fε fεv :=
let ⟨E, h₁, h₂⟩ := I_category.hep_cof j hj ε x fε.val G.H $
  by rw [fε.property, G.Hiε] in
⟨⟨E ∘ i ε.v @> b, by rw [i_nat_assoc, ←G.Hiεv, h₂]⟩,
 ⟨homotopy_dir.mk ε E h₁ rfl, by clear _let_match; cases ε; exact h₂⟩⟩

end dir

parameters {u u' : a ⟶ x}
parameters (G : homotopy u u')
include G

def drag_rel : maps_extending hj u → maps_extending hj u' → Prop :=
λ f₀ f₁, ∃ H : homotopy f₀.val f₁.val, H.H ∘ I &> j = G.H

local notation f₀ ` ~G `:50 f₁:50 := drag_rel f₀ f₁
local notation `[` b `,` x `]^` u:60 := homotopy_classes_extending_rel j hj u

-- The relation ~G does not descend to the quotient: given a homotopy
-- f₀ ≃ f₀' rel u and a homotopy f₀ ≃ f₁ extending G, we may not be
-- able to find a homotopy f₀' ≃ f₁ extending G. Rather, two homotopy
-- classes are related when they have representatives which are
-- related by ~G.
def drag_rel_homotopy : [b, x]^u → [b, x]^u' → Prop :=
λ g₀ g₁, ∃ f₀ f₁, ⟦f₀⟧ = g₀ ∧ ⟦f₁⟧ = g₁ ∧ f₀ ~G f₁

private def uu' : endpoint → (a ⟶ x) := λ ε, endpoint.cases_on ε u u'

lemma drag_rel_homotopy_total₀ (g₀) : ∃ g₁, drag_rel_homotopy g₀ g₁ :=
quotient.induction_on g₀ $ assume f₀,
  let ⟨f₁, h⟩ := total uu' 0 G f₀ in ⟨⟦f₁⟧, ⟨f₀, f₁, rfl, rfl, h⟩⟩

lemma drag_rel_homotopy_total₁ (g₁) : ∃ g₀, drag_rel_homotopy g₀ g₁ :=
quotient.induction_on g₁ $ assume f₁,
  let ⟨f₀, h⟩ := total uu' 1 G f₁ in ⟨⟦f₀⟧, ⟨f₀, f₁, rfl, rfl, h⟩⟩

lemma drag_rel_homotopy_unique₀ {g₀ g₁ g₁'} :
  drag_rel_homotopy g₀ g₁ → drag_rel_homotopy g₀ g₁' → g₁ = g₁' :=
assume ⟨f₀, f₁, hf₀, hf₁, ⟨H, h⟩⟩ ⟨f₀', f₁', hf₀', hf₁', ⟨H', h'⟩⟩,
  have f₀.val ≃ f₀'.val rel j, from quotient.exact (hf₀.trans hf₀'.symm),
  let ⟨H₀, h₀⟩ := this in
  hf₁.symm.trans $
    (quotient.sound (equiv_private.f₁_f₂ j hj h₀ 0 h h') : ⟦f₁⟧ = ⟦f₁'⟧).trans hf₁'

lemma drag_rel_homotopy_unique₁ {g₀ g₀' g₁} :
  drag_rel_homotopy g₀ g₁ → drag_rel_homotopy g₀' g₁ → g₀ = g₀' :=
assume ⟨f₀, f₁, hf₀, hf₁, ⟨H, h⟩⟩ ⟨f₀', f₁', hf₀', hf₁', ⟨H', h'⟩⟩,
  have f₁.val ≃ f₁'.val rel j, from quotient.exact (hf₁.trans hf₁'.symm),
  let ⟨H₁, h₁⟩ := this in
  hf₀.symm.trans $
    (quotient.sound (equiv_private.f₁_f₂ j hj h₁ 1 h h') : ⟦f₀⟧ = ⟦f₀'⟧).trans hf₀'

parameters {hj u u'}

-- TODO: General theory of bijective relations
-- FIXME: collision between homotopy ≃ and equiv ≃
noncomputable def drag_equiv : equiv ([b, x]^u) ([b, x]^u') :=
{ to_fun := λ g₀, classical.some (drag_rel_homotopy_total₀ g₀),
  inv_fun := λ g₁, classical.some (drag_rel_homotopy_total₁ g₁),
  left_inv := assume g₀,
    let g₁ := classical.some (drag_rel_homotopy_total₀ g₀),
        g₀' := classical.some (drag_rel_homotopy_total₁ g₁) in
    show g₀' = g₀, from
    have e' : drag_rel_homotopy g₀' g₁, from classical.some_spec (drag_rel_homotopy_total₁ g₁),
    have e : drag_rel_homotopy g₀ g₁, from classical.some_spec (drag_rel_homotopy_total₀ g₀),
    drag_rel_homotopy_unique₁ e' e,
  right_inv := assume g₁,
    let g₀ := classical.some (drag_rel_homotopy_total₁ g₁),
        g₁' := classical.some (drag_rel_homotopy_total₀ g₀) in
    show g₁' = g₁, from
    have e' : drag_rel_homotopy g₀ g₁', from classical.some_spec (drag_rel_homotopy_total₀ g₀),
    have e : drag_rel_homotopy g₀ g₁, from classical.some_spec (drag_rel_homotopy_total₁ g₁),
    drag_rel_homotopy_unique₀ e' e }

lemma drag_equiv_apply {g₀ g₁} : drag_equiv g₀ = g₁ ↔ drag_rel_homotopy g₀ g₁ :=
iff.intro
  (assume h, by rw ←h; exact classical.some_spec (drag_rel_homotopy_total₀ _ _ _))
  (assume h,
    have h' : drag_rel_homotopy g₀ (drag_equiv g₀) :=
      classical.some_spec (drag_rel_homotopy_total₀ _),
    drag_rel_homotopy_unique₀ h' h)

end

parameters {hj}

lemma drag_rel_homotopy_induced {x y : C} {u u' : a ⟶ x} (G : homotopy u u') (g : x ⟶ y)
  (g₀ : homotopy_classes_extending_rel j hj u) (g₁ : homotopy_classes_extending_rel j hj u') :
  drag_rel_homotopy G g₀ g₁ →
  drag_rel_homotopy (G.congr_left g) (hcer_induced g g₀) (hcer_induced g g₁) :=
assume ⟨f₀, f₁, hf₀, hf₁, H, hH⟩,
⟨⟨g ∘ f₀.val, by rw [←assoc, f₀.property]⟩,
 ⟨g ∘ f₁.val, by rw [←assoc, f₁.property]⟩,
 by rw ←hf₀; refl, by rw ←hf₁; refl,
 H.congr_left g,
 by unfold homotopy.congr_left; rw [←assoc, hH]⟩

lemma drag_equiv_induced {x y : C} {u u' : a ⟶ x} (G : homotopy u u') (g : x ⟶ y)
  (g₀ : homotopy_classes_extending_rel j hj u) :
  hcer_induced g (drag_equiv G g₀) = drag_equiv (G.congr_left g) (hcer_induced g g₀) :=
begin
  symmetry,
  rw drag_equiv_apply,
  apply drag_rel_homotopy_induced,
  rw ←drag_equiv_apply
end

-- Now we can state and prove the fact that homotopic maps g ≃ g'
-- induce the same map on homotopy classes extending u, up to the drag
-- identification.

variables {x y : C} {u : a ⟶ x} {g g' : x ⟶ y} (h : homotopy g g')
lemma hcer_induced_homotopic (f : homotopy_classes_extending_rel j hj u) :
  drag_equiv (h.congr_right u) (hcer_induced g f) = hcer_induced g' f :=
quotient.induction_on f $ λ f, begin
  dsimp [hcer_induced],
  rw drag_equiv_apply,
  existsi [_, _],
  split, exact rfl,
  split, exact rfl,
  existsi h.congr_right f.val,
  dsimp only [homotopy.congr_right],
  rw [←assoc, ←I.map_comp, f.property]
end

end C

end homotopy_theory.cofibrations


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.rat.default
import Mathlib.data.semiquot
import Mathlib.PostPort

universes l u_1

namespace Mathlib

/-!
# Implementation of floating-point numbers (experimental).
-/

def int.shift2 (a : ℕ) (b : ℕ) : ℤ → ℕ × ℕ := sorry

namespace fp

structure rmode where
  NE ::

class float_cfg where
  prec : ℕ
  emax : ℕ
  prec_pos : 0 < prec
  prec_max : prec ≤ emax

def prec [C : float_cfg] : ℕ := float_cfg.prec

def emax [C : float_cfg] : ℕ := float_cfg.emax

def emin [C : float_cfg] : ℤ := 1 - ↑float_cfg.emax

def valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) :=
  emin ≤ e + ↑prec - 1 ∧ e + ↑prec - 1 ≤ ↑emax ∧ e = max (e + ↑(nat.size m) - ↑prec) emin

protected instance dec_valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) :
    Decidable (valid_finite e m) :=
  eq.mpr sorry and.decidable

inductive float [C : float_cfg] where
| inf : Bool → float
| nan : float
| finite : Bool → (e : ℤ) → (m : ℕ) → valid_finite e m → float

def float.is_finite [C : float_cfg] : float → Bool := sorry

def to_rat [C : float_cfg] (f : float) : ↥(float.is_finite f) → ℚ := sorry

theorem float.zero.valid [C : float_cfg] : valid_finite emin 0 := sorry

def float.zero [C : float_cfg] (s : Bool) : float := float.finite s emin 0 sorry

protected instance float.inhabited [C : float_cfg] : Inhabited float := { default := float.zero tt }

protected def float.sign' [C : float_cfg] : float → semiquot Bool := sorry

protected def float.sign [C : float_cfg] : float → Bool := sorry

protected def float.is_zero [C : float_cfg] : float → Bool := sorry

protected def float.neg [C : float_cfg] : float → float := sorry

def div_nat_lt_two_pow [C : float_cfg] (n : ℕ) (d : ℕ) : ℤ → Bool := sorry

-- TODO(Mario): Prove these and drop 'meta'

namespace float

protected instance has_neg [C : float_cfg] : Neg float := { neg := float.neg }

end Mathlib


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Floris van Doorn
-/
import category_theory.limits.shapes.products
import category_theory.discrete_category

universes v u

noncomputable theory

open category_theory
open category_theory.functor
open opposite

namespace category_theory.limits

variables {C : Type u} [category.{v} C]
variables {J : Type v} [small_category J]
variable (F : J ⥤ Cᵒᵖ)

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a colimit, we can construct a limit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_limit_of_has_colimit_left_op [has_colimit F.left_op] : has_limit F :=
has_limit.mk
{ cone := cone_of_cocone_left_op (colimit.cocone F.left_op),
  is_limit :=
  { lift := λ s, (colimit.desc F.left_op (cocone_left_op_of_cone s)).op,
    fac' := λ s j,
    begin
      rw [cone_of_cocone_left_op_π_app, colimit.cocone_ι, ←op_comp,
          colimit.ι_desc, cocone_left_op_of_cone_ι_app, quiver.hom.op_unop],
      refl, end,
    uniq' := λ s m w,
    begin
      -- It's a pity we can't do this automatically.
      -- Usually something like this would work by limit.hom_ext,
      -- but the opposites get in the way of this firing.
      have u := (colimit.is_colimit F.left_op).uniq (cocone_left_op_of_cone s) (m.unop),
      convert congr_arg (λ f : _ ⟶ _, f.op) (u _), clear u,
      intro j,
      rw [cocone_left_op_of_cone_ι_app, colimit.cocone_ι],
      convert congr_arg (λ f : _ ⟶ _, f.unop) (w (unop j)), clear w,
      rw [cone_of_cocone_left_op_π_app, colimit.cocone_ι, quiver.hom.unop_op],
      refl,
    end } }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_limits_of_shape_op_of_has_colimits_of_shape [has_colimits_of_shape Jᵒᵖ C] :
  has_limits_of_shape J Cᵒᵖ :=
{ has_limit := λ F, has_limit_of_has_colimit_left_op F }

local attribute [instance] has_limits_of_shape_op_of_has_colimits_of_shape

/--
If `C` has colimits, we can construct limits for `Cᵒᵖ`.
-/
lemma has_limits_op_of_has_colimits [has_colimits C] : has_limits Cᵒᵖ := {}

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a limit, we can construct a colimit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_colimit_of_has_limit_left_op [has_limit F.left_op] : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cone_left_op (limit.cone F.left_op),
  is_colimit :=
  { desc := λ s, (limit.lift F.left_op (cone_left_op_of_cocone s)).op,
    fac' := λ s j,
    begin
      rw [cocone_of_cone_left_op_ι_app, limit.cone_π, ←op_comp,
          limit.lift_π, cone_left_op_of_cocone_π_app, quiver.hom.op_unop],
      refl, end,
    uniq' := λ s m w,
    begin
      have u := (limit.is_limit F.left_op).uniq (cone_left_op_of_cocone s) (m.unop),
      convert congr_arg (λ f : _ ⟶ _, f.op) (u _), clear u,
      intro j,
      rw [cone_left_op_of_cocone_π_app, limit.cone_π],
      convert congr_arg (λ f : _ ⟶ _, f.unop) (w (unop j)), clear w,
      rw [cocone_of_cone_left_op_ι_app, limit.cone_π, quiver.hom.unop_op],
      refl,
    end } }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_colimits_of_shape_op_of_has_limits_of_shape [has_limits_of_shape Jᵒᵖ C] :
  has_colimits_of_shape J Cᵒᵖ :=
{ has_colimit := λ F, has_colimit_of_has_limit_left_op F }

local attribute [instance] has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has limits, we can construct colimits for `Cᵒᵖ`.
-/
lemma has_colimits_op_of_has_limits [has_limits C] : has_colimits Cᵒᵖ := {}

variables (X : Type v)
/--
If `C` has products indexed by `X`, then `Cᵒᵖ` has coproducts indexed by `X`.
-/
lemma has_coproducts_opposite [has_products_of_shape X C] :
  has_coproducts_of_shape X Cᵒᵖ :=
begin
  haveI : has_limits_of_shape (discrete X)ᵒᵖ C :=
    has_limits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

/--
If `C` has coproducts indexed by `X`, then `Cᵒᵖ` has products indexed by `X`.
-/
lemma has_products_opposite [has_coproducts_of_shape X C] :
  has_products_of_shape X Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape (discrete X)ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

end category_theory.limits


import data.nat.basic tactic data.nat.parity
open nat expr tactic

universes u v

lemma let_congr {α : Type u} {β : Type v} (assignment₁ assignment₂ : α) (body : β)
  (h : assignment₁ = assignment₂) : let a := assignment₁ in body = let a := assignment₂ in body :=
h ▸ rfl

meta def reduce : expr → tactic (expr × expr)
| (elet n t v b) :=
  do (v', p) ← reduce v,
  T ← infer_type (elet n t v b),
  let eq' := `(@eq.{1} (%%T) (%%(elet n t (var 0) b)) (%%(elet n t v b))),
  --eq' ← tactic.mk_mapp `eq [T, elet n t v b, elet n t (var 0) b],
  let motive : expr := lam `x default t eq',
  let
  p' ← tactic.mk_mapp `eq.rec [t, v, motive, p, v'],
  return (elet n t v' b, p')
| `((1 : ℕ) + (1 : ℕ)) := return (`(2 : ℕ), `(eq.refl (2 : ℕ)))
| e := do eq' ← tactic.mk_app `eq.refl [e], return (e, eq')

set_option trace.app_builder true
#eval reduce `(let n := 1 + 1 in n)

meta def blah : tactic unit :=
do (e₁, e₂) ← reduce `(let n := 1 + 1 in n), tactic.exact e₂

example : let n := 1 + 1 in n = let n := 2 in n := by blah

#eval


import .core

namespace tts ------------------------------------------------------------------
namespace sch ------------------------------------------------------------------
variables {V : Type} [_root_.decidable_eq V] -- Type of variable names
variables {vs : list V} -- List of variable names
variables {nd : vs.nodup} -- No duplicate variables names
variables {x x₁ x₂ : tagged V} -- Variables
variables {xs : list (tagged V)} -- List of variable names
variables {t tx t₁ t₂ : typ V} -- Types
variables {ts txs : list (typ V)} -- Lists of types
variables {s : sch V} -- Type schemes

open list

/-- Substitute a free variable for a type in a scheme -/
def subst (x : tagged V) (t : typ V) (s : sch V) : sch V :=
⟨s.vars, typ.subst x t s.type, s.vars_nodup⟩

@[simp] theorem subst_mk : subst x tx (mk vs t nd) = mk vs (typ.subst x tx t) nd :=
rfl

/-- Substitute a list of free variables for a list of types in a scheme -/
def subst_list (xs : list (tagged V)) (ts : list (typ V)) (s : sch V) : sch V :=
⟨s.vars, typ.subst_list xs ts s.type, s.vars_nodup⟩

@[simp] theorem subst_list_mk :
  subst_list xs txs (mk vs t nd) = mk vs (typ.subst_list xs txs t) nd :=
rfl

-- Substitution with a fresh name is the identity
@[simp] theorem subst_fresh (h : x ∉ fv s) : subst x t s = s :=
eq_of_veq rfl $ typ.subst_fresh h

-- Fold typ.subst into sch.subst
theorem subst_fold : mk vs (typ.subst x t₂ t₁) nd = subst x t₂ (mk vs t₁ nd) :=
rfl

-- Substitution distributes over open
theorem subst_open_typs (l : typ.lc t) :
  typ.subst x t (open_typs ts s) = open_typs (map (typ.subst x t) ts) (subst x t s) :=
by cases s; simp [typ.subst_open_typs l]

-- Substitution distributes over open_vars
theorem subst_open_vars (h : x ∉ xs) (l : typ.lc t) :
  open_vars xs (subst x t s) = typ.subst x t (open_vars xs s) :=
by cases s; simp [typ.subst_open_vars h l]

@[simp] theorem subst_arity : (subst x t s).arity = s.arity :=
by unfold subst arity

@[simp] theorem subst_type : (subst x t s).type = typ.subst x t s.type :=
by unfold subst

-- A scheme substituted with a type is well-formed if the scheme is well-formed
-- and the type is locally-closed.
theorem subst_well_formed (lt : typ.lc t) (ls : lc s) : lc (subst x t s) :=
begin
  cases ls with L ls,
  existsi insert x L,
  intros xs d ln_eq F,
  simp [not_or_distrib] at F,
  have h₁ : x ∉ xs := λ h, absurd (eq.refl x) (F h).1,
  have h₂ : ∀ x ∈ xs, x ∉ L := λ _ h, (F h).2,
  simp [typ.subst_open_vars h₁ lt, typ.subst_lc lt (ls d ln_eq h₂)],
end

-- Opening up a scheme `s` with `ts` is the same as opening up `s` with fresh
-- names `xs` and then substituting `xs` for `ts`.
theorem subst_list_intro
  (d : xs.nodup)
  (ln_eq : xs.length = ts.length)
  (F : ∀ x ∈ xs, x ∉ fv s ∪ typ.fv_list ts)
  (l : ∀ t ∈ ts, typ.lc t) :
  open_typs ts s = typ.subst_list xs ts (open_vars xs s) :=
by rw [open_typs, open_vars, typ.subst_list_intro d ln_eq F l]

end /- namespace -/ sch --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


import data.finsupp

universes u v
variable (α : Type u)
variable [ring α]
variable [decidable_eq α]

@[simp] lemma ite.map (P : Prop) [decidable P] {β γ : Type*} (a b : β) (f : β → γ) :
  f (ite P a b) = ite P (f a) (f b) :=
begin
  split_ifs; refl
end

@[simp] lemma ite.mul_right (P : Prop) [decidable P] (a b c : α) :
  (ite P a b) * c = ite P (a * c) (b * c) := ite.map P a b (λ x, x * c)

-- theorem ite_single {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] (f : α → β) :

def finsupp_of_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [decidable_eq β] [add_comm_monoid β] (f : α → β) : finsupp α β :=
begin
  by_cases h₁ : f a₀ ≠ 0,
  { constructor,
    show α → β,
    from (λ a, ite (a₀ = a) (f a) 0),
    show finset α,
    from finset.singleton a₀,
    intros,
    simp,
    split_ifs,
    rw ←h,
    simp[h₁],
    simp[h],
    from λ h₂, h (eq.symm h₂),
  },
  exact 0
end

-- finsupp of double ite
def finsupp_of_double_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) : finsupp α β :=
begin
  constructor,
  show α → β,
  from (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)),
  show finset α,
  from finset.singleton a₀ ∪ finset.singleton a₁,
  intros,
  simp,
  split_ifs,
  rw ←h,
  simp[h₁],
  rw ←h_1,
  simp[h₂],
  simp,
  intros h_n,
  cases h_n,
  from h (eq.symm h_n),
  from h_1 (eq.symm h_n),
end

@[simp] lemma finsupp_of_double_ite_eq_double_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) : (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (finsupp_of_double_ite a₀ a₁ f g h₁ h₂).to_fun :=
begin
  funext,
  by_cases h₁ : (a₀ = a),
  simp[h₁],
  unfold finsupp_of_double_ite,
  simp,
  unfold finsupp_of_double_ite,
end

@[simp] lemma coe_to_fun_to_fun {α : Type*} {β : Type*} [add_comm_monoid β] {fs : finsupp α β} : ⇑(fs) = fs.to_fun := rfl

lemma temp {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) (h_neq : a₀ ≠ a₁) (a : α) (h_p : a = a₀) : (a ∈ ((finsupp.single a₀ (f a₀)).support).val ∧
      ¬(finsupp.single a₀ (f a₀)).to_fun a + (finsupp.single a₁ (g a₁)).to_fun a = 0 ∨
    a ∈ ((finsupp.single a₁ (g a₁)).support).val ∧
      ¬(finsupp.single a₀ (f a₀)).to_fun a + (finsupp.single a₁ (g a₁)).to_fun a = 0) :=
begin
  simp[h_p],
  constructor,
  constructor,

  simp[finsupp.single, h₁],

  intros h_q,
  --(by simp[finsupp.single,h₂, h_neq])
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a₀ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a₀) (by simp[finsupp.single,h₂, h_neq]),
  -- rw ←h_p at H₁,
  simp[H₁] at h_q,

  have H₂ : (finsupp.single a₀ (f a₀)).to_fun a₀ ≠ 0,
  from iff.elim_left (@finsupp.mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a₀) (by simp[finsupp.single, h₁]),
  from H₂ h_q,
end

@[simp] lemma finsupp_of_double_ite_zip_singles {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h₁ : f a₀ ≠ 0) (h₂ : g a₁ ≠ 0) (h_neq : a₀ ≠ a₁) : (finsupp_of_double_ite a₀ a₁ f g h₁ h₂) = (finsupp.single a₀ (f a₀)) + (finsupp.single a₁ (g a₁)) :=
begin

  -- congr,
  unfold finsupp_of_double_ite,
  -- unfold finsupp.zip_with,
  congr,
  show (λ a, _) = (λ a, _),
  funext,
  by_cases h_t : (a₀ = a);
  simp[h_t],
  rw ←h_t,
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a₀ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a₀) (by
  simp[finsupp.single,h₂, h_neq]),
  rw H₁,
  simp,
  simp[finsupp.single],
  simp,

  by_cases h_t₀ : (a₁ = a),
  simp[h_t₀],
  rw ←h_t₀,
  have H₁ : (finsupp.single a₀ (f a₀)).to_fun a₁ = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a₁) (by simp[finsupp.single,h₁, λ x, h_neq (eq.symm x)]),
  rw H₁,
  simp,
  simp[finsupp.single],
  simp,

  simp[h_t₀],
  have H₁ : (finsupp.single a₁ (g a₁)).to_fun a = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₁ (g a₁)) a) (by simp[finsupp.single, h₂, (λ x, h_t₀ (eq.symm x))]),
  have H₂ : (finsupp.single a₀ (f a₀)).to_fun a = 0,
  from iff.elim_left (@finsupp.not_mem_support_iff α β _ (finsupp.single a₀ (f a₀)) a) (by simp[finsupp.single, h₁, (λ x, h_t (eq.symm x))]),
  rw H₁,
  rw H₂,
  simp,

  -- simp[finset.singleton],
  ext,
  constructor,
  intros h_p,
  simp at h_p,
  cases h_p with h_p h_p,
{
  simp,
  apply temp; assumption,
},
{simp,
apply or.swap,
rw add_comm,
apply temp,
assumption,
assumption,
from λ x, h_neq (eq.symm x),
assumption,
},

intros h_p,
simp at h_p,
cases h_p with h_p h_p,
have H₁, from and.elim_left h_p,

simp,
constructor,
-- by_contra,
-- have H₄ :
have H₃ : ((finsupp.single a₀ (f a₀)).support) = finset.singleton a₀,
simp[finsupp.single, h₁],
rw H₃ at H₁,
-- ext,
simp[finsupp.single, finsupp.support, finset.val] at H₁,
-- constructor,
from H₁,

simp,
apply or.swap,
constructor,
have H₃ : ((finsupp.single a₁ (g a₁)).support) = finset.singleton a₁,
simp[finsupp.single, h₂],
-- simp[H₃] at h_p,
rw H₃ at h_p,
simp[finsupp.single, finsupp.support, finset.val] at h_p,
from and.elim_left h_p,
end

@[simp] lemma finsupp_of_ite_single {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f : α → β) : (finsupp_of_ite a₀ f) = finsupp.single a₀ (f a₀) :=
begin
  simp[finsupp.single],
  simp[finsupp_of_ite],
  simp[finset.singleton],
  by_cases h₁ : f a₀ ≠ 0,
  { simp[h₁],
    funext,
    -- congr,
    by_cases h₂ : (a₀ = a);
    simp[h₂], },
  simp at h₁,
  simp [h₁],
  refl,
end

@[simp] lemma finsupp_of_ite_eq_ite {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [decidable_eq β] [add_comm_monoid β] (f : α → β) : (λ a, ite (a₀ = a) (f a) 0) = (finsupp_of_ite a₀ f).to_fun :=
begin
  funext,
  by_cases h₂ : (a₀ = a),
  simp[h₂],
  dsimp [finsupp.single],
  simp,
  unfold finsupp_of_ite,
  simp,
  simp[h₂],
  by_cases h₁ : f a₀ ≠ 0,
  simp[h₁],
  simp[h₂],
  simp[h₁],
  refl,
end

section
open finset
-- open finsupp
lemma finsupp_sum_support_subset {α : Type*} [fintype α] [decidable_eq α] {β : Type*} [add_comm_monoid β] (fs : finsupp α β) : Π (S : finset α), fs.support ⊆ S → S.sum (fs.to_fun) = fs.sum (λ x y, y) := begin
  intros S hS,
  by_cases hT : (S ⊆ fs.support),
  congr,
  apply finset.subset.antisymm; assumption,
  unfold finsupp.sum,
  simp,
  -- have h₇ : ⇑fs = (fs).to_fun,
  -- refl,
  have h₄, from eq.symm (@finset.sum_sdiff α β fs.support S fs.to_fun _ _ hS),
  apply eq.trans,
  from h₄,
  have h₅ : sum (S \ fs.support) (fs.to_fun) = 0,
  apply @finset.sum_eq_zero α β _ _ fs.to_fun (S \ fs.support),
  intros x,
  have h₆, from iff.elim_left ((@finsupp.not_mem_support_iff α β _ fs) x),
  -- simp at h₆,
  intros h₈,
  apply h₆,
  intros h₉,
  simp at h₈,
  simp at h₉,
  apply h₈.elim_right,
  from h₉,
  -- rw h₇,
  rw h₅,
  simp,
end
end

lemma finset.sum_ite_zero {α : Type*} [fintype α] [decidable_eq α] (a₀ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f : α → β):
  finset.sum finset.univ (λ a, ite (a₀ = a) (f a) 0) = f a₀ := begin

    -- TODO update: cases have been moved earlier.
    -- Outline of proof:  ⊢ finset.sum finset.univ (λ (a : α), ite (a₀ = a) (f a) 0) = f a₀
    /-
        Two cases, h : (f a₀ = 0):

        Case 1: If (f a₀ = 0) :
          The goal is:
          ⊢ finset.sum finset.univ (λ (a : α), ite (a₀ = a) (f a) 0) = 0
          We may show that (λ (a : α), ite (a₀ = a) (f a) 0) = (λ (a : α), 0) by cases.
          ⊢ finset.sum finset.univ (λ (a : α), 0) = 0
          which is resolved by the fact that summation over constant zero is zero.

        Case 2: If (f a₀ ≠ 0) :
          Then (λ (a : α), ite (a₀ = a) (f a) 0) is a finitely-supported (single) function : α →₀ β
          We then have
          ⊢ finset.sum finset.univ ((finsupp.single a₀ (f a₀)).to_fun) = f a₀
          Then summing over the entire finset with a single-supported function is the same
          as summing the result of the function mapped over the support of that function, so
          ⊢ finsupp.sum (finsupp.single a₀ (f a₀)) (λ (x : α) (y : β), y) = f a₀
          Then we may apply the fact that summing over a (single) supported function just picks the value at the point of interest, so
          ⊢ (λ (x : α) (y : β), y) a₀ (f a₀) = f a₀
          which is resolved by refl
    -/

    -- by_cases h : (f a₀ ≠ 0),
    -- Case 1: --------------------------------
    rw finsupp_of_ite_eq_ite,
    rw finsupp_of_ite_single,
    apply eq.trans (@finsupp_sum_support_subset α _ _ β _ (finsupp.single a₀ (f a₀)) finset.univ (by apply finset.subset_univ)),
    -- from H₃,
    -- show f a₀ ≠ 0, by assumption,

    apply eq.trans (@finsupp.sum_single_index α β β _ _ _ _ a₀ (f a₀) (λ x y, y) (by refl)),
    -- from @finsupp.sum_single_index α β β _ _ _ _ a₀ (f a₀) (λ x y, y) (by refl),
    simp,

    -- Case 2: --------------------------------
    -- simp at h,
    -- simp[h],
    -- have H₅ : (λ (a : α), ite (a₀ = a) (f a) 0) = (λ (a : α), 0),
    -- funext,
    -- by_cases h₁ : (a₀ = a); simp[h₁],
    -- subst h₁, assumption,
    -- rw H₅,
    -- from @finset.sum_const_zero α β finset.univ _,
  end

-- set_option pp.proofs true

-- lemma finset.sum_ite : finset.sum X (λ a, ite (a₀ = a) (f a) (g a)) = ite (a₀ ∈ X) (f a₀) 0 + finset.sum (sorry) g

lemma finset.sum_ite_zero₂ {α : Type*} [fintype α] [decidable_eq α] (a₀ a₁ : α) {β : Type*} [add_comm_monoid β] [decidable_eq β] (f g : α → β) (h_ne : a₀ ≠ a₁):
  finset.sum finset.univ (λ a, ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = f a₀ + g a₁ := begin
  by_cases h₁ : (g a₁ = 0),
    -- Case 1:
    have H₁ : (λ (a : α), ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (λ (a : α), ite (a₀ = a) (f a) 0),
    funext,
    by_cases h_t : (a₀ = a); simp[h_t],
    by_cases h_t₀ : (a₁ = a), {subst h_t₀, simp[h_t, h₁]}, simp[h_t₀],
    rw H₁,
    rw finset.sum_ite_zero,
    simp[h₁],

    -- Case 2:
    by_cases h₂ : (f a₀ = 0),
    have H₁ : (λ (a : α), ite (a₀ = a) (f a) (ite (a₁ = a) (g a) 0)) = (λ (a : α), ite (a₁ = a) (g a) 0),
    funext,
    by_cases h_t : (a₀ = a); simp[h_t],
    by_cases h_t₀ : (a₁ = a),
    subst h_t₀,
    exfalso, from h_ne h_t,
    simp[h_t₀],
    subst h_t,
    from h₂,
    rw H₁,
    -- rw h₂,
    rw finset.sum_ite_zero,
    simp[h₂],

    -- Case 3:
    rw finsupp_of_double_ite_eq_double_ite,
    rw finsupp_of_double_ite_zip_singles,
    repeat{show _ ≠ _, by assumption},

    apply eq.trans (@finsupp_sum_support_subset α _ _ β _ (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)) finset.univ (by apply finset.subset_univ)),

    unfold finsupp.sum,

    have H₄ : disjoint ((finsupp.single a₀ (f a₀)).support) ((finsupp.single a₁ (g a₁)).support),
    dsimp[finsupp.single],
    -- simp[finsupp.single],

    -- simp[finsupp.single],
    simp[h₁, h₂],
    from λ x, h_ne (eq.symm x),

    have H₂, from @finsupp.support_add_eq α β _ _ _ (finsupp.single a₀ (f a₀)) (finsupp.single a₁ (g a₁)) H₄,

    have H₃ : finset.sum ((finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).support)
      (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) = finset.sum (((finsupp.single a₀ (f a₀)).support) ∪ ((finsupp.single a₁ (g a₁)).support))
      (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a),
    simp,
    congr,
    from H₂,
    simp,
    rw H₃,
    clear H₃ H₂,
    have H₅, from @finset.sum_union α β (finsupp.single a₀ (f a₀)).support (finsupp.single a₁ (g a₁)).support (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) _ _ ((iff.elim_left finset.disjoint_iff_inter_eq_empty)  H₄),
    apply eq.trans,
    from H₅,
    clear H₅,

    -- have H₁ : finset.sum ((finsupp.single a₀ (f a₀)).support)
    --     (λ (a : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun a) = f a₀,

    have H₄, from @finsupp.add_apply α β _ _ _ (finsupp.single a₀ (f a₀)) (finsupp.single a₁ (g a₁)),
    rw ←coe_to_fun_to_fun,
    have H₅ :
      (λ (x : α), (finsupp.single a₀ (f a₀) + finsupp.single a₁ (g a₁)).to_fun x) =
      (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x),
    funext,
    have H₄_temp, from @H₄ x,
    simp at H₄_temp,
    from H₄_temp,
    simp,
    rw H₅,
    clear H₄,

    have H₁ : finset.sum ((finsupp.single a₀ (f a₀)).support)
        (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x) = f a₀,
    -- simp,

    dsimp[finsupp.single],
    simp[h₁, h₂, λ x, h_ne (eq.symm x)],
    simp[H₁],

    clear H₁,
    have H₁ : finset.sum ((finsupp.single a₁ (g a₁)).support)
        (λ (x : α), (finsupp.single a₀ (f a₀)).to_fun x + (finsupp.single a₁ (g a₁)).to_fun x) = g a₁,
    dsimp[finsupp.single],
    simp[h₁, h₂, h_ne],

    simp[H₁],
end


import order.filter.basic

lemma filter.eventually_eq.eventually_eq_ite {X Y : Type*} {l : filter X} {f g : X → Y}
  {P : X → Prop} [decidable_pred P] (h : f =ᶠ[l] g) :
(λ x, if P x then f x else g x) =ᶠ[l] f :=
begin
  apply h.mono (λ x hx, _),
  dsimp only,
  split_ifs ; tauto
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro, Reid Barton, Andrew Yang
-/
import category_theory.limits.kan_extension
import topology.category.Top.opens
import category_theory.adjunction.opposites

/-!
# Presheaves on a topological space

We define `presheaf C X` simply as `(opens X)ᵒᵖ ⥤ C`,
and inherit the category structure with natural transformations as morphisms.

We define
* `pushforward_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C`
with notation `f _* ℱ`
and for `ℱ : X.presheaf C` provide the natural isomorphisms
* `pushforward.id : (𝟙 X) _* ℱ ≅ ℱ`
* `pushforward.comp : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ)`
along with their `@[simp]` lemmas.

We also define the functors `pushforward` and `pullback` between the categories
`X.presheaf C` and `Y.presheaf C`, and provide their adjunction at
`pushforward_pullback_adjunction`.
-/

universes w v u

open category_theory
open topological_space
open opposite

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

namespace Top

/-- The category of `C`-valued presheaves on a (bundled) topological space `X`. -/
@[derive category, nolint has_nonempty_instance]
def presheaf (X : Top.{w}) : Type (max u v w) := (opens X)ᵒᵖ ⥤ C

variables {C}

namespace presheaf

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

/-- Tag lemmas to use in `Top.presheaf.restrict_tac`.  -/
@[user_attribute]
meta def restrict_attr : user_attribute (tactic unit → tactic unit) unit :=
{ name      := `sheaf_restrict,
  descr     := "tag lemmas to use in `Top.presheaf.restrict_tac`",
  cache_cfg :=
  { mk_cache := λ ns, pure $ λ t, do
    { ctx <- tactic.local_context,
      ctx.any_of (tactic.focus1 ∘ (tactic.apply' >=> (λ _, tactic.done)) >=> (λ _, t)) <|>
      ns.any_of (tactic.focus1 ∘ (tactic.resolve_name >=> tactic.to_expr >=> tactic.apply' >=>
        (λ _, tactic.done)) >=> (λ _, t)) },
    dependencies := [] } }

/-- A tactic to discharge goals of type `U ≤ V` for `Top.presheaf.restrict_open` -/
meta def restrict_tac : Π (n : ℕ), tactic unit
| 0 := tactic.fail "`restrict_tac` failed"
| (n + 1) := monad.join (restrict_attr.get_cache <*> pure tactic.done) <|>
    `[apply' le_trans, mjoin (restrict_attr.get_cache <*> pure (restrict_tac n))]

/-- A tactic to discharge goals of type `U ≤ V` for `Top.presheaf.restrict_open`.
Defaults to three iterations. -/
meta def restrict_tac' := restrict_tac 3

attribute [sheaf_restrict] bot_le le_top le_refl inf_le_left inf_le_right le_sup_left le_sup_right

example {X : Top} {v w x y z : opens X} (h₀ : v ≤ x) (h₁ : x ≤ z ⊓ w) (h₂ : x ≤ y ⊓ z) :
  v ≤ y := by restrict_tac'

/-- The restriction of a section along an inclusion of open sets.
For `x : F.obj (op V)`, we provide the notation `x |_ₕ i` (`h` stands for `hom`) for `i : U ⟶ V`,
and the notation `x |_ₗ U ⟪i⟫` (`l` stands for `le`) for `i : U ≤ V`.
-/
def restrict {X : Top} {C : Type*} [category C] [concrete_category C]
  {F : X.presheaf C} {V : opens X} (x : F.obj (op V)) {U : opens X} (h : U ⟶ V) : F.obj (op U) :=
F.map h.op x

localized "infixl ` |_ₕ `: 80 := Top.presheaf.restrict" in algebraic_geometry

localized "notation x ` |_ₗ `: 80 U ` ⟪` e `⟫ ` :=
@Top.presheaf.restrict _ _ _ _ _ _ x U (@hom_of_le (opens _) _ U _ e)" in algebraic_geometry

/-- The restriction of a section along an inclusion of open sets.
For `x : F.obj (op V)`, we provide the notation `x |_ U`, where the proof `U ≤ V` is inferred by
the tactic `Top.presheaf.restrict_tac'` -/
abbreviation restrict_open {X : Top} {C : Type*} [category C] [concrete_category C]
  {F : X.presheaf C} {V : opens X} (x : F.obj (op V)) (U : opens X)
  (e : U ≤ V . Top.presheaf.restrict_tac') : F.obj (op U) :=
x |_ₗ U ⟪e⟫

localized "infixl ` |_ `: 80 := Top.presheaf.restrict_open" in algebraic_geometry

@[simp]
lemma restrict_restrict {X : Top} {C : Type*} [category C] [concrete_category C]
  {F : X.presheaf C} {U V W : opens X} (e₁ : U ≤ V) (e₂ : V ≤ W) (x : F.obj (op W)) :
    x |_ V |_ U = x |_ U :=
by { delta restrict_open restrict, rw [← comp_apply, ← functor.map_comp], refl }

@[simp]
lemma map_restrict {X : Top} {C : Type*} [category C] [concrete_category C]
  {F G : X.presheaf C} (e : F ⟶ G) {U V : opens X} (h : U ≤ V) (x : F.obj (op V)) :
    e.app _ (x |_ U) = (e.app _ x) |_ U :=
by { delta restrict_open restrict, rw [← comp_apply, nat_trans.naturality, comp_apply] }

/-- Pushforward a presheaf on `X` along a continuous map `f : X ⟶ Y`, obtaining a presheaf
on `Y`. -/
def pushforward_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C :=
(opens.map f).op ⋙ ℱ

infix ` _* `: 80 := pushforward_obj

@[simp] lemma pushforward_obj_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) (U : (opens Y)ᵒᵖ) :
  (f _* ℱ).obj U = ℱ.obj ((opens.map f).op.obj U) := rfl

@[simp] lemma pushforward_obj_map {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C)
  {U V : (opens Y)ᵒᵖ} (i : U ⟶ V) :
  (f _* ℱ).map i = ℱ.map ((opens.map f).op.map i) := rfl

/--
An equality of continuous maps induces a natural isomorphism between the pushforwards of a presheaf
along those maps.
-/
def pushforward_eq {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) :
  f _* ℱ ≅ g _* ℱ :=
iso_whisker_right (nat_iso.op (opens.map_iso f g h).symm) ℱ

lemma pushforward_eq' {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) :
  f _* ℱ = g _* ℱ :=
by rw h

@[simp] lemma pushforward_eq_hom_app
  {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) (U) :
  (pushforward_eq h ℱ).hom.app U =
    ℱ.map (begin dsimp [functor.op], apply quiver.hom.op, apply eq_to_hom, rw h, end) :=
by simp [pushforward_eq]

lemma pushforward_eq'_hom_app
  {X Y : Top.{w}} {f g : X ⟶ Y} (h : f = g) (ℱ : X.presheaf C) (U) :
  nat_trans.app (eq_to_hom (pushforward_eq' h ℱ)) U = ℱ.map (eq_to_hom (by rw h)) :=
by simpa [eq_to_hom_map]

@[simp]
lemma pushforward_eq_rfl {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) (U) :
  (pushforward_eq (rfl : f = f) ℱ).hom.app (op U) = 𝟙 _ :=
begin
  dsimp [pushforward_eq],
  simp,
end

lemma pushforward_eq_eq {X Y : Top.{w}} {f g : X ⟶ Y} (h₁ h₂ : f = g) (ℱ : X.presheaf C) :
  ℱ.pushforward_eq h₁ = ℱ.pushforward_eq h₂ :=
rfl

namespace pushforward
variables {X : Top.{w}} (ℱ : X.presheaf C)

/-- The natural isomorphism between the pushforward of a presheaf along the identity continuous map
and the original presheaf. -/
def id : (𝟙 X) _* ℱ ≅ ℱ :=
(iso_whisker_right (nat_iso.op (opens.map_id X).symm) ℱ) ≪≫ functor.left_unitor _

lemma id_eq : (𝟙 X) _* ℱ = ℱ :=
by { unfold pushforward_obj, rw opens.map_id_eq, erw functor.id_comp }

@[simp] lemma id_hom_app' (U) (p) :
  (id ℱ).hom.app (op ⟨U, p⟩) = ℱ.map (𝟙 (op ⟨U, p⟩)) :=
by { dsimp [id], simp, }

local attribute [tidy] tactic.op_induction'

@[simp, priority 990] lemma id_hom_app (U) :
  (id ℱ).hom.app U = ℱ.map (eq_to_hom (opens.op_map_id_obj U)) :=
begin
  -- was `tidy`
  induction U using opposite.rec,
  cases U,
  rw [id_hom_app'],
  congr
end

@[simp] lemma id_inv_app' (U) (p) : (id ℱ).inv.app (op ⟨U, p⟩) = ℱ.map (𝟙 (op ⟨U, p⟩)) :=
by { dsimp [id], simp, }

/-- The natural isomorphism between
the pushforward of a presheaf along the composition of two continuous maps and
the corresponding pushforward of a pushforward. -/
def comp {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ) :=
iso_whisker_right (nat_iso.op (opens.map_comp f g).symm) ℱ

@[simp] lemma comp_hom_app {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (comp ℱ f g).hom.app U = 𝟙 _ :=
by { dsimp [comp], tidy, }

@[simp] lemma comp_inv_app {Y Z : Top.{w}} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (comp ℱ f g).inv.app U = 𝟙 _ :=
by { dsimp [comp], tidy, }

end pushforward

/--
A morphism of presheaves gives rise to a morphisms of the pushforwards of those presheaves.
-/
@[simps]
def pushforward_map {X Y : Top.{w}} (f : X ⟶ Y) {ℱ 𝒢 : X.presheaf C} (α : ℱ ⟶ 𝒢) :
  f _* ℱ ⟶ f _* 𝒢 :=
{ app := λ U, α.app _,
  naturality' := λ U V i, by { erw α.naturality, refl, } }

open category_theory.limits
section pullback
variable [has_colimits C]
noncomputable theory

/--
Pullback a presheaf on `Y` along a continuous map `f : X ⟶ Y`, obtaining a presheaf on `X`.

This is defined in terms of left Kan extensions, which is just a fancy way of saying
"take the colimits over the open sets whose preimage contains U".
-/
@[simps]
def pullback_obj {X Y : Top.{v}} (f : X ⟶ Y) (ℱ : Y.presheaf C) : X.presheaf C :=
(Lan (opens.map f).op).obj ℱ

/-- Pulling back along continuous maps is functorial. -/
def pullback_map {X Y : Top.{v}} (f : X ⟶ Y) {ℱ 𝒢 : Y.presheaf C} (α : ℱ ⟶ 𝒢) :
  pullback_obj f ℱ ⟶ pullback_obj f 𝒢 :=
(Lan (opens.map f).op).map α

/-- If `f '' U` is open, then `f⁻¹ℱ U ≅ ℱ (f '' U)`.  -/
@[simps]
def pullback_obj_obj_of_image_open {X Y : Top.{v}} (f : X ⟶ Y) (ℱ : Y.presheaf C) (U : opens X)
  (H : is_open (f '' U)) : (pullback_obj f ℱ).obj (op U) ≅ ℱ.obj (op ⟨_, H⟩) :=
begin
  let x : costructured_arrow (opens.map f).op (op U) := begin
    refine @costructured_arrow.mk _ _ _ _ _ (op (opens.mk (f '' U) H)) _ _,
    exact ((@hom_of_le _ _ _ ((opens.map f).obj ⟨_, H⟩) (set.image_preimage.le_u_l _)).op),
  end,
  have hx : is_terminal x :=
  { lift := λ s,
    begin
      fapply costructured_arrow.hom_mk,
      change op (unop _) ⟶ op (⟨_, H⟩ : opens _),
      refine (hom_of_le _).op,
      exact (set.image_subset f s.X.hom.unop.le).trans (set.image_preimage.l_u_le ↑(unop s.X.left)),
      simp
    end },
  exact is_colimit.cocone_point_unique_up_to_iso
    (colimit.is_colimit _)
    (colimit_of_diagram_terminal hx _),
end

namespace pullback
variables {X Y : Top.{v}} (ℱ : Y.presheaf C)

/-- The pullback along the identity is isomorphic to the original presheaf. -/
def id : pullback_obj (𝟙 _) ℱ ≅ ℱ :=
nat_iso.of_components
  (λ U, pullback_obj_obj_of_image_open (𝟙 _) ℱ (unop U) (by simpa using U.unop.2) ≪≫
    ℱ.map_iso (eq_to_iso (by simp)))
  (λ U V i,
  begin
      ext, simp,
      erw colimit.pre_desc_assoc,
      erw colimit.ι_desc_assoc,
      erw colimit.ι_desc_assoc,
      dsimp, simp only [←ℱ.map_comp], congr
  end)

lemma id_inv_app (U : opens Y) :
  (id ℱ).inv.app (op U) = colimit.ι (Lan.diagram (opens.map (𝟙 Y)).op ℱ (op U))
    (@costructured_arrow.mk _ _ _ _ _ (op U) _ (eq_to_hom (by simp))) :=
begin
  rw [← category.id_comp ((id ℱ).inv.app (op U)), ← nat_iso.app_inv, iso.comp_inv_eq],
  dsimp [id],
  rw colimit.ι_desc_assoc,
  dsimp,
  rw [← ℱ.map_comp, ← ℱ.map_id], refl,
end

end pullback
end pullback
variable (C)

/--
The pushforward functor.
-/
def pushforward {X Y : Top.{w}} (f : X ⟶ Y) : X.presheaf C ⥤ Y.presheaf C :=
{ obj := pushforward_obj f,
  map := @pushforward_map _ _ X Y f }

@[simp]
lemma pushforward_map_app' {X Y : Top.{w}} (f : X ⟶ Y)
  {ℱ 𝒢 : X.presheaf C} (α : ℱ ⟶ 𝒢) {U : (opens Y)ᵒᵖ} :
  ((pushforward C f).map α).app U = α.app (op $ (opens.map f).obj U.unop) := rfl

lemma id_pushforward {X : Top.{w}} : pushforward C (𝟙 X) = 𝟭 (X.presheaf C) :=
begin
  apply category_theory.functor.ext,
  { intros,
    ext U,
    have h := f.congr, erw h (opens.op_map_id_obj U),
    simpa [eq_to_hom_map], },
  { intros, apply pushforward.id_eq },
end

section iso

/-- A homeomorphism of spaces gives an equivalence of categories of presheaves. -/
@[simps] def presheaf_equiv_of_iso {X Y : Top} (H : X ≅ Y) :
  X.presheaf C ≌ Y.presheaf C :=
equivalence.congr_left (opens.map_map_iso H).symm.op

variable {C}

/--
If `H : X ≅ Y` is a homeomorphism,
then given an `H _* ℱ ⟶ 𝒢`, we may obtain an `ℱ ⟶ H ⁻¹ _* 𝒢`.
-/
def to_pushforward_of_iso {X Y : Top} (H : X ≅ Y) {ℱ : X.presheaf C} {𝒢 : Y.presheaf C}
  (α : H.hom _* ℱ ⟶ 𝒢) : ℱ ⟶ H.inv _* 𝒢 :=
(presheaf_equiv_of_iso _ H).to_adjunction.hom_equiv ℱ 𝒢 α

@[simp]
lemma to_pushforward_of_iso_app {X Y : Top} (H₁ : X ≅ Y) {ℱ : X.presheaf C} {𝒢 : Y.presheaf C}
  (H₂ : H₁.hom _* ℱ ⟶ 𝒢) (U : (opens X)ᵒᵖ) :
(to_pushforward_of_iso H₁ H₂).app U =
  ℱ.map (eq_to_hom (by simp [opens.map, set.preimage_preimage])) ≫
  H₂.app (op ((opens.map H₁.inv).obj (unop U))) :=
begin
  delta to_pushforward_of_iso,
  simp only [equiv.to_fun_as_coe, nat_trans.comp_app, equivalence.equivalence_mk'_unit,
    eq_to_hom_map, eq_to_hom_op, eq_to_hom_trans, presheaf_equiv_of_iso_unit_iso_hom_app_app,
    equivalence.to_adjunction, equivalence.equivalence_mk'_counit,
    presheaf_equiv_of_iso_inverse_map_app, adjunction.mk_of_unit_counit_hom_equiv_apply],
  congr,
end

/--
If `H : X ≅ Y` is a homeomorphism,
then given an `H _* ℱ ⟶ 𝒢`, we may obtain an `ℱ ⟶ H ⁻¹ _* 𝒢`.
-/
def pushforward_to_of_iso {X Y : Top} (H₁ : X ≅ Y) {ℱ : Y.presheaf C} {𝒢 : X.presheaf C}
  (H₂ : ℱ ⟶ H₁.hom _* 𝒢) : H₁.inv _* ℱ ⟶ 𝒢 :=
((presheaf_equiv_of_iso _ H₁.symm).to_adjunction.hom_equiv ℱ 𝒢).symm H₂

@[simp]
lemma pushforward_to_of_iso_app {X Y : Top} (H₁ : X ≅ Y) {ℱ : Y.presheaf C} {𝒢 : X.presheaf C}
  (H₂ : ℱ ⟶ H₁.hom _* 𝒢) (U : (opens X)ᵒᵖ) :
(pushforward_to_of_iso H₁ H₂).app U =
  H₂.app (op ((opens.map H₁.inv).obj (unop U))) ≫
  𝒢.map (eq_to_hom (by simp [opens.map, set.preimage_preimage])) :=
by simpa [pushforward_to_of_iso, equivalence.to_adjunction]

end iso

variables (C) [has_colimits C]

/-- Pullback a presheaf on `Y` along a continuous map `f : X ⟶ Y`, obtaining a presheaf
on `X`. -/
@[simps map_app]
def pullback {X Y : Top.{v}} (f : X ⟶ Y) : Y.presheaf C ⥤ X.presheaf C := Lan (opens.map f).op

@[simp] lemma pullback_obj_eq_pullback_obj {C} [category C] [has_colimits C] {X Y : Top.{w}}
  (f : X ⟶ Y) (ℱ : Y.presheaf C) : (pullback C f).obj ℱ = pullback_obj f ℱ := rfl

/-- The pullback and pushforward along a continuous map are adjoint to each other. -/
@[simps unit_app_app counit_app_app]
def pushforward_pullback_adjunction {X Y : Top.{v}} (f : X ⟶ Y) :
  pullback C f ⊣ pushforward C f := Lan.adjunction _ _

/-- Pulling back along a homeomorphism is the same as pushing forward along its inverse. -/
def pullback_hom_iso_pushforward_inv {X Y : Top.{v}} (H : X ≅ Y) :
  pullback C H.hom ≅ pushforward C H.inv :=
adjunction.left_adjoint_uniq
  (pushforward_pullback_adjunction C H.hom)
  (presheaf_equiv_of_iso C H.symm).to_adjunction

/-- Pulling back along the inverse of a homeomorphism is the same as pushing forward along it. -/
def pullback_inv_iso_pushforward_hom {X Y : Top.{v}} (H : X ≅ Y) :
  pullback C H.inv ≅ pushforward C H.hom :=
adjunction.left_adjoint_uniq
  (pushforward_pullback_adjunction C H.inv)
  (presheaf_equiv_of_iso C H).to_adjunction

end presheaf
end Top


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

! This file was ported from Lean 3 source module category_theory.monoidal.Mon_
! leanprover-community/mathlib commit a836c6dba9bd1ee2a0cdc9af0006a596f243031c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.Braided
import Mathbin.CategoryTheory.Monoidal.Discrete
import Mathbin.CategoryTheory.Monoidal.CoherenceLemmas
import Mathbin.CategoryTheory.Limits.Shapes.Terminal
import Mathbin.Algebra.PunitInstances

/-!
# The category of monoids in a monoidal category.

We define monoids in a monoidal category `C` and show that the category of monoids is equivalent to
the category of lax monoidal functors from the unit monoidal category to `C`.  We also show that if
`C` is braided, then the category of monoids is naturally monoidal.

-/

universe v₁ v₂ u₁ u₂ u

open CategoryTheory

open CategoryTheory.MonoidalCategory

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

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ where
  pt : C
  one : 𝟙_ C ⟶ X
  mul : X ⊗ X ⟶ X
  one_mul' : (one ⊗ 𝟙 X) ≫ mul = (λ_ X).Hom := by obviously
  mul_one' : (𝟙 X ⊗ one) ≫ mul = (ρ_ X).Hom := by obviously
  -- Obviously there is some flexibility stating this axiom.
  -- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,
  -- and chooses to place the associator on the right-hand side.
  -- The heuristic is that unitors and associators "don't have much weight".
  mul_assoc' : (mul ⊗ 𝟙 X) ≫ mul = (α_ X X X).Hom ≫ (𝟙 X ⊗ mul) ≫ mul := by obviously
#align Mon_ Mon_

restate_axiom Mon_.one_mul'

restate_axiom Mon_.mul_one'

restate_axiom Mon_.mul_assoc'

attribute [reassoc.1] Mon_.one_mul Mon_.mul_one

-- We prove a more general `@[simp]` lemma below.
attribute [simp, reassoc.1] Mon_.mul_assoc

namespace Mon_

/-- The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simps]
def trivial : Mon_ C where
  pt := 𝟙_ C
  one := 𝟙 _
  mul := (λ_ _).Hom
  mul_assoc' := by coherence
  mul_one' := by coherence
#align Mon_.trivial Mon_.trivial

instance : Inhabited (Mon_ C) :=
  ⟨trivial C⟩

variable {C} {M : Mon_ C}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem one_mul_hom {Z : C} (f : Z ⟶ M.pt) : (M.one ⊗ f) ≫ M.mul = (λ_ Z).Hom ≫ f := by
  rw [← id_tensor_comp_tensor_id, category.assoc, M.one_mul, left_unitor_naturality]
#align Mon_.one_mul_hom Mon_.one_mul_hom

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem mul_one_hom {Z : C} (f : Z ⟶ M.pt) : (f ⊗ M.one) ≫ M.mul = (ρ_ Z).Hom ≫ f := by
  rw [← tensor_id_comp_id_tensor, category.assoc, M.mul_one, right_unitor_naturality]
#align Mon_.mul_one_hom Mon_.mul_one_hom

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem assoc_flip :
    (𝟙 M.pt ⊗ M.mul) ≫ M.mul = (α_ M.pt M.pt M.pt).inv ≫ (M.mul ⊗ 𝟙 M.pt) ≫ M.mul := by simp
#align Mon_.assoc_flip Mon_.assoc_flip

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A morphism of monoid objects. -/
@[ext]
structure Hom (M N : Mon_ C) where
  Hom : M.pt ⟶ N.pt
  one_hom' : M.one ≫ hom = N.one := by obviously
  mul_hom' : M.mul ≫ hom = (hom ⊗ hom) ≫ N.mul := by obviously
#align Mon_.hom Mon_.Hom

restate_axiom hom.one_hom'

restate_axiom hom.mul_hom'

attribute [simp, reassoc.1] hom.one_hom hom.mul_hom

/-- The identity morphism on a monoid object. -/
@[simps]
def id (M : Mon_ C) : Hom M M where Hom := 𝟙 M.pt
#align Mon_.id Mon_.id

instance homInhabited (M : Mon_ C) : Inhabited (Hom M M) :=
  ⟨id M⟩
#align Mon_.hom_inhabited Mon_.homInhabited

/-- Composition of morphisms of monoid objects. -/
@[simps]
def comp {M N O : Mon_ C} (f : Hom M N) (g : Hom N O) : Hom M O where Hom := f.Hom ≫ g.Hom
#align Mon_.comp Mon_.comp

instance : Category (Mon_ C) where
  Hom M N := Hom M N
  id := id
  comp M N O f g := comp f g

@[simp]
theorem id_hom' (M : Mon_ C) : (𝟙 M : Hom M M).Hom = 𝟙 M.pt :=
  rfl
#align Mon_.id_hom' Mon_.id_hom'

@[simp]
theorem comp_hom' {M N K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) :
    (f ≫ g : Hom M K).Hom = f.Hom ≫ g.Hom :=
  rfl
#align Mon_.comp_hom' Mon_.comp_hom'

section

variable (C)

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simps]
def forget : Mon_ C ⥤ C where
  obj A := A.pt
  map A B f := f.Hom
#align Mon_.forget Mon_.forget

end

instance forget_faithful : Faithful (@forget C _ _) where
#align Mon_.forget_faithful Mon_.forget_faithful

instance {A B : Mon_ C} (f : A ⟶ B) [e : IsIso ((forget C).map f)] : IsIso f.Hom :=
  e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
instance : ReflectsIsomorphisms (forget C)
    where reflects X Y f e :=
    ⟨⟨{   Hom := inv f.hom
          mul_hom' := by
            simp only [is_iso.comp_inv_eq, hom.mul_hom, category.assoc, ← tensor_comp_assoc,
              is_iso.inv_hom_id, tensor_id, category.id_comp] },
        by tidy⟩⟩

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Construct an isomorphism of monoids by giving an isomorphism between the underlying objects
and checking compatibility with unit and multiplication only in the forward direction.
-/
def isoOfIso {M N : Mon_ C} (f : M.pt ≅ N.pt) (one_f : M.one ≫ f.Hom = N.one)
    (mul_f : M.mul ≫ f.Hom = (f.Hom ⊗ f.Hom) ≫ N.mul) : M ≅ N
    where
  Hom :=
    { Hom := f.Hom
      one_hom' := one_f
      mul_hom' := mul_f }
  inv :=
    { Hom := f.inv
      one_hom' := by
        rw [← one_f]
        simp
      mul_hom' := by
        rw [← cancel_mono f.hom]
        slice_rhs 2 3 => rw [mul_f]
        simp }
#align Mon_.iso_of_iso Mon_.isoOfIso

instance uniqueHomFromTrivial (A : Mon_ C) : Unique (trivial C ⟶ A)
    where
  default :=
    { Hom := A.one
      one_hom' := by
        dsimp
        simp
      mul_hom' := by
        dsimp
        simp [A.one_mul, unitors_equal] }
  uniq f := by
    ext; simp
    rw [← category.id_comp f.hom]
    erw [f.one_hom]
#align Mon_.unique_hom_from_trivial Mon_.uniqueHomFromTrivial

open CategoryTheory.Limits

instance : HasInitial (Mon_ C) :=
  hasInitial_of_unique (trivial C)

end Mon_

namespace CategoryTheory.LaxMonoidalFunctor

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

-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)
/-- A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
@[simps]
def mapMon (F : LaxMonoidalFunctor C D) : Mon_ C ⥤ Mon_ D
    where
  obj A :=
    { pt := F.obj A.pt
      one := F.ε ≫ F.map A.one
      mul := F.μ _ _ ≫ F.map A.mul
      one_mul' := by
        conv_lhs => rw [comp_tensor_id, ← F.to_functor.map_id]
        slice_lhs 2 3 => rw [F.μ_natural]
        slice_lhs 3 4 => rw [← F.to_functor.map_comp, A.one_mul]
        rw [F.to_functor.map_id]
        rw [F.left_unitality]
      mul_one' := by
        conv_lhs => rw [id_tensor_comp, ← F.to_functor.map_id]
        slice_lhs 2 3 => rw [F.μ_natural]
        slice_lhs 3 4 => rw [← F.to_functor.map_comp, A.mul_one]
        rw [F.to_functor.map_id]
        rw [F.right_unitality]
      mul_assoc' := by
        conv_lhs => rw [comp_tensor_id, ← F.to_functor.map_id]
        slice_lhs 2 3 => rw [F.μ_natural]
        slice_lhs 3 4 => rw [← F.to_functor.map_comp, A.mul_assoc]
        conv_lhs => rw [F.to_functor.map_id]
        conv_lhs => rw [F.to_functor.map_comp, F.to_functor.map_comp]
        conv_rhs => rw [id_tensor_comp, ← F.to_functor.map_id]
        slice_rhs 3 4 => rw [F.μ_natural]
        conv_rhs => rw [F.to_functor.map_id]
        slice_rhs 1 3 => rw [← F.associativity]
        simp only [category.assoc] }
  map A B f :=
    { Hom := F.map f.Hom
      one_hom' := by
        dsimp
        rw [category.assoc, ← F.to_functor.map_comp, f.one_hom]
      mul_hom' := by
        dsimp
        rw [category.assoc, F.μ_natural_assoc, ← F.to_functor.map_comp, ← F.to_functor.map_comp,
          f.mul_hom] }
  map_id' A := by
    ext
    simp
  map_comp' A B C f g := by
    ext
    simp
#align category_theory.lax_monoidal_functor.map_Mon CategoryTheory.LaxMonoidalFunctor.mapMon

variable (C D)

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def mapMonFunctor : LaxMonoidalFunctor C D ⥤ Mon_ C ⥤ Mon_ D
    where
  obj := mapMon
  map F G α := { app := fun A => { Hom := α.app A.pt } }
#align category_theory.lax_monoidal_functor.map_Mon_functor CategoryTheory.LaxMonoidalFunctor.mapMonFunctor

end CategoryTheory.LaxMonoidalFunctor

namespace Mon_

open CategoryTheory.LaxMonoidalFunctor

namespace EquivLaxMonoidalFunctorPunit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def laxMonoidalToMon : LaxMonoidalFunctor (Discrete PUnit.{u + 1}) C ⥤ Mon_ C
    where
  obj F := (F.mapMon : Mon_ _ ⥤ Mon_ C).obj (trivial (Discrete PUnit))
  map F G α := ((mapMonFunctor (Discrete PUnit) C).map α).app _
#align Mon_.equiv_lax_monoidal_functor_punit.lax_monoidal_to_Mon Mon_.EquivLaxMonoidalFunctorPunit.laxMonoidalToMon

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def monToLaxMonoidal : Mon_ C ⥤ LaxMonoidalFunctor (Discrete PUnit.{u + 1}) C
    where
  obj A :=
    { obj := fun _ => A.pt
      map := fun _ _ _ => 𝟙 _
      ε := A.one
      μ := fun _ _ => A.mul
      map_id' := fun _ => rfl
      map_comp' := fun _ _ _ _ _ => (Category.id_comp (𝟙 A.pt)).symm }
  map A B f :=
    { app := fun _ => f.Hom
      naturality' := fun _ _ _ => by
        dsimp
        rw [category.id_comp, category.comp_id]
      unit' := f.OneHom
      tensor' := fun _ _ => f.MulHom }
#align Mon_.equiv_lax_monoidal_functor_punit.Mon_to_lax_monoidal Mon_.EquivLaxMonoidalFunctorPunit.monToLaxMonoidal

attribute [local tidy] tactic.discrete_cases

attribute [local simp] eq_to_iso_map

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def unitIso :
    𝟭 (LaxMonoidalFunctor (Discrete PUnit.{u + 1}) C) ≅ laxMonoidalToMon C ⋙ monToLaxMonoidal C :=
  NatIso.ofComponents
    (fun F =>
      MonoidalNatIso.ofComponents (fun _ => F.toFunctor.mapIso (eqToIso (by ext))) (by tidy)
        (by tidy) (by tidy))
    (by tidy)
#align Mon_.equiv_lax_monoidal_functor_punit.unit_iso Mon_.EquivLaxMonoidalFunctorPunit.unitIso

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def counitIso : monToLaxMonoidal C ⋙ laxMonoidalToMon C ≅ 𝟭 (Mon_ C) :=
  NatIso.ofComponents
    (fun F =>
      { Hom := { Hom := 𝟙 _ }
        inv := { Hom := 𝟙 _ } })
    (by tidy)
#align Mon_.equiv_lax_monoidal_functor_punit.counit_iso Mon_.EquivLaxMonoidalFunctorPunit.counitIso

end EquivLaxMonoidalFunctorPunit

open EquivLaxMonoidalFunctorPunit

attribute [local simp] eq_to_iso_map

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
@[simps]
def equivLaxMonoidalFunctorPunit : LaxMonoidalFunctor (Discrete PUnit.{u + 1}) C ≌ Mon_ C
    where
  Functor := laxMonoidalToMon C
  inverse := monToLaxMonoidal C
  unitIso := unitIso C
  counitIso := counitIso C
#align Mon_.equiv_lax_monoidal_functor_punit Mon_.equivLaxMonoidalFunctorPunit

end Mon_

namespace Mon_

/-!
In this section, we prove that the category of monoids in a braided monoidal category is monoidal.

Given two monoids `M` and `N` in a braided monoidal category `C`, the multiplication on the tensor
product `M.X ⊗ N.X` is defined in the obvious way: it is the tensor product of the multiplications
on `M` and `N`, except that the tensor factors in the source come in the wrong order, which we fix
by pre-composing with a permutation isomorphism constructed from the braiding.

A more conceptual way of understanding this definition is the following: The braiding on `C` gives
rise to a monoidal structure on the tensor product functor from `C × C` to `C`.  A pair of monoids
in `C` gives rise to a monoid in `C × C`, which the tensor product functor by being monoidal takes
to a monoid in `C`.  The permutation isomorphism appearing in the definition of the multiplication
on the tensor product of two monoids is an instance of a more general family of isomorphisms which
together form a strength that equips the tensor product functor with a monoidal structure, and the
monoid axioms for the tensor product follow from the monoid axioms for the tensor factors plus the
properties of the strength (i.e., monoidal functor axioms).  The strength `tensor_μ` of the tensor
product functor has been defined in `category_theory.monoidal.braided`.  Its properties, stated as
independent lemmas in that module, are used extensively in the proofs below.  Notice that we could
have followed the above plan not only conceptually but also as a possible implementation and could
have constructed the tensor product of monoids via `map_Mon`, but we chose to give a more explicit
definition directly in terms of `tensor_μ`.

To complete the definition of the monoidal category structure on the category of monoids, we need
to provide definitions of associator and unitors.  The obvious candidates are the associator and
unitors from `C`, but we need to prove that they are monoid morphisms, i.e., compatible with unit
and multiplication.  These properties translate to the monoidality of the associator and unitors
(with respect to the monoidal structures on the functors they relate), which have also been proved
in `category_theory.monoidal.braided`.

-/

variable {C}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- The proofs that associators and unitors preserve monoid units don't require braiding.
theorem one_associator {M N P : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ P.one)) ≫ (α_ M.pt N.pt P.pt).Hom =
      (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ (λ_ (𝟙_ C)).inv ≫ (N.one ⊗ P.one)) :=
  by
  simp
  slice_lhs 1 3 => rw [← category.id_comp P.one, tensor_comp]
  slice_lhs 2 3 => rw [associator_naturality]
  slice_rhs 1 2 => rw [← category.id_comp M.one, tensor_comp]
  slice_lhs 1 2 => rw [← left_unitor_tensor_inv]
  rw [← cancel_epi (λ_ (𝟙_ C)).inv]
  slice_lhs 1 2 => rw [left_unitor_inv_naturality]
  simp only [category.assoc]
#align Mon_.one_associator Mon_.one_associator

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem one_leftUnitor {M : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ⊗ M.one)) ≫ (λ_ M.pt).Hom = M.one :=
  by
  slice_lhs 2 3 => rw [left_unitor_naturality]
  simp
#align Mon_.one_left_unitor Mon_.one_leftUnitor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem one_rightUnitor {M : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ 𝟙 (𝟙_ C))) ≫ (ρ_ M.pt).Hom = M.one :=
  by
  slice_lhs 2 3 => rw [right_unitor_naturality, ← unitors_equal]
  simp
#align Mon_.one_right_unitor Mon_.one_rightUnitor

variable [BraidedCategory C]

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Mon_tensor_one_mul (M N : Mon_ C) :
    ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ 𝟙 (M.pt ⊗ N.pt)) ≫
        tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) =
      (λ_ (M.pt ⊗ N.pt)).Hom :=
  by
  rw [← category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp]
  slice_lhs 2 3 => rw [← tensor_id, tensor_μ_natural]
  slice_lhs 3 4 => rw [← tensor_comp, one_mul M, one_mul N]
  symm
  exact tensor_left_unitality C M.X N.X
#align Mon_.Mon_tensor_one_mul Mon_.Mon_tensor_one_mul

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Mon_tensor_mul_one (M N : Mon_ C) :
    (𝟙 (M.pt ⊗ N.pt) ⊗ (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one)) ≫
        tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) =
      (ρ_ (M.pt ⊗ N.pt)).Hom :=
  by
  rw [← category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp]
  slice_lhs 2 3 => rw [← tensor_id, tensor_μ_natural]
  slice_lhs 3 4 => rw [← tensor_comp, mul_one M, mul_one N]
  symm
  exact tensor_right_unitality C M.X N.X
#align Mon_.Mon_tensor_mul_one Mon_.Mon_tensor_mul_one

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem Mon_tensor_mul_assoc (M N : Mon_ C) :
    (tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) ⊗ 𝟙 (M.pt ⊗ N.pt)) ≫
        tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) =
      (α_ (M.pt ⊗ N.pt) (M.pt ⊗ N.pt) (M.pt ⊗ N.pt)).Hom ≫
        (𝟙 (M.pt ⊗ N.pt) ⊗ tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul)) ≫
          tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) :=
  by
  rw [← category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp]
  slice_lhs 2 3 => rw [← tensor_id, tensor_μ_natural]
  slice_lhs 3 4 => rw [← tensor_comp, mul_assoc M, mul_assoc N, tensor_comp, tensor_comp]
  slice_lhs 1 3 => rw [tensor_associativity]
  slice_lhs 3 4 => rw [← tensor_μ_natural]
  slice_lhs 2 3 => rw [← tensor_comp, tensor_id]
  simp only [category.assoc]
#align Mon_.Mon_tensor_mul_assoc Mon_.Mon_tensor_mul_assoc

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem mul_associator {M N P : Mon_ C} :
    (tensorμ C (M.pt ⊗ N.pt, P.pt) (M.pt ⊗ N.pt, P.pt) ≫
          (tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul) ⊗ P.mul)) ≫
        (α_ M.pt N.pt P.pt).Hom =
      ((α_ M.pt N.pt P.pt).Hom ⊗ (α_ M.pt N.pt P.pt).Hom) ≫
        tensorμ C (M.pt, N.pt ⊗ P.pt) (M.pt, N.pt ⊗ P.pt) ≫
          (M.mul ⊗ tensorμ C (N.pt, P.pt) (N.pt, P.pt) ≫ (N.mul ⊗ P.mul)) :=
  by
  simp
  slice_lhs 2 3 => rw [← category.id_comp P.mul, tensor_comp]
  slice_lhs 3 4 => rw [associator_naturality]
  slice_rhs 3 4 => rw [← category.id_comp M.mul, tensor_comp]
  slice_lhs 1 3 => rw [associator_monoidal]
  simp only [category.assoc]
#align Mon_.mul_associator Mon_.mul_associator

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem mul_leftUnitor {M : Mon_ C} :
    (tensorμ C (𝟙_ C, M.pt) (𝟙_ C, M.pt) ≫ ((λ_ (𝟙_ C)).Hom ⊗ M.mul)) ≫ (λ_ M.pt).Hom =
      ((λ_ M.pt).Hom ⊗ (λ_ M.pt).Hom) ≫ M.mul :=
  by
  rw [← category.comp_id (λ_ (𝟙_ C)).Hom, ← category.id_comp M.mul, tensor_comp]
  slice_lhs 3 4 => rw [left_unitor_naturality]
  slice_lhs 1 3 => rw [← left_unitor_monoidal]
  simp only [category.assoc, category.id_comp]
#align Mon_.mul_left_unitor Mon_.mul_leftUnitor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem mul_rightUnitor {M : Mon_ C} :
    (tensorμ C (M.pt, 𝟙_ C) (M.pt, 𝟙_ C) ≫ (M.mul ⊗ (λ_ (𝟙_ C)).Hom)) ≫ (ρ_ M.pt).Hom =
      ((ρ_ M.pt).Hom ⊗ (ρ_ M.pt).Hom) ≫ M.mul :=
  by
  rw [← category.id_comp M.mul, ← category.comp_id (λ_ (𝟙_ C)).Hom, tensor_comp]
  slice_lhs 3 4 => rw [right_unitor_naturality]
  slice_lhs 1 3 => rw [← right_unitor_monoidal]
  simp only [category.assoc, category.id_comp]
#align Mon_.mul_right_unitor Mon_.mul_rightUnitor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance monMonoidal : MonoidalCategory (Mon_ C)
    where
  tensorObj M N :=
    { pt := M.pt ⊗ N.pt
      one := (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one)
      mul := tensorμ C (M.pt, N.pt) (M.pt, N.pt) ≫ (M.mul ⊗ N.mul)
      one_mul' := Mon_tensor_one_mul M N
      mul_one' := Mon_tensor_mul_one M N
      mul_assoc' := Mon_tensor_mul_assoc M N }
  tensorHom M N P Q f g :=
    { Hom := f.Hom ⊗ g.Hom
      one_hom' := by
        dsimp
        slice_lhs 2 3 => rw [← tensor_comp, hom.one_hom f, hom.one_hom g]
      mul_hom' := by
        dsimp
        slice_rhs 1 2 => rw [tensor_μ_natural]
        slice_lhs 2 3 => rw [← tensor_comp, hom.mul_hom f, hom.mul_hom g, tensor_comp]
        simp only [category.assoc] }
  tensor_id' := by
    intros
    ext
    apply tensor_id
  tensor_comp' := by
    intros
    ext
    apply tensor_comp
  tensorUnit := trivial C
  associator M N P := isoOfIso (α_ M.pt N.pt P.pt) one_associator mul_associator
  associator_naturality' := by
    intros
    ext
    dsimp
    apply associator_naturality
  leftUnitor M := isoOfIso (λ_ M.pt) one_leftUnitor mul_leftUnitor
  leftUnitor_naturality' := by
    intros
    ext
    dsimp
    apply left_unitor_naturality
  rightUnitor M := isoOfIso (ρ_ M.pt) one_rightUnitor mul_rightUnitor
  rightUnitor_naturality' := by
    intros
    ext
    dsimp
    apply right_unitor_naturality
  pentagon' := by
    intros
    ext
    dsimp
    apply pentagon
  triangle' := by
    intros
    ext
    dsimp
    apply triangle
#align Mon_.Mon_monoidal Mon_.monMonoidal

end Mon_

/-!
Projects:
* Check that `Mon_ Mon ≌ CommMon`, via the Eckmann-Hilton argument.
  (You'll have to hook up the cartesian monoidal structure on `Mon` first, available in #3463)
* Check that `Mon_ Top ≌ [bundled topological monoids]`.
* Check that `Mon_ AddCommGroup ≌ Ring`.
  (We've already got `Mon_ (Module R) ≌ Algebra R`, in `category_theory.monoidal.internal.Module`.)
* Can you transport this monoidal structure to `Ring` or `Algebra R`?
  How does it compare to the "native" one?
* Show that when `C` is braided, the forgetful functor `Mon_ C ⥤ C` is monoidal.
* Show that when `F` is a lax braided functor `C ⥤ D`, the functor `map_Mon F : Mon_ C ⥤ Mon_ D`
  is lax monoidal.
-/


import tactic.lint

def f : ℕ → ℕ := default
def c : ℕ := default
def d : ℕ := default

@[simp] lemma c_eq_d : c = d := rfl

-- The following lemma never applies when using simp, because c is first rewritten to d
@[simp] lemma f_c : f c = 0 := rfl

example : f c = 0 :=
begin
  simp,
  guard_target f d = 0, -- does not apply f_c
  refl
end

open tactic
run_cmd do
decl ← get_decl ``f_c,
res ← linter.simp_nf.test decl,
-- linter complains
guard $ res.is_some

-- also works with `coe_to_fun`

structure morphism :=
(f : ℕ → ℕ)

instance : has_coe_to_fun morphism (λ _, ℕ → ℕ):=
⟨morphism.f⟩

def h : morphism := ⟨default⟩

-- Also never applies
@[simp] lemma h_c : h c = 0 := rfl

example : h c = 0 :=
begin
  simp,
  guard_target h d = 0, -- does not apply h_c
  refl
end

open tactic
run_cmd do
decl ← get_decl ``h_c,
res ← linter.simp_nf.test decl,
-- linter complains
guard $ res.is_some


import Runtime.Network.Graph.Basic

namespace Network.Graph

inductive Path (graph : Graph) : Class graph → Type _
  | nil : Path graph _
  | cons {start : Class graph} (child : Class.Child start) : Path graph child.class → Path graph start
  deriving DecidableEq

namespace Path

def isNil : Path graph start → Bool
  | nil => true
  | cons .. => false

theorem isNil_of_nil : (nil : Path graph start).isNil := rfl

@[simp]
theorem isNil_def {path : Path graph start} : path.isNil ↔ path = nil := by
  cases path <;> simp [isNil]

def isCons : Path graph start → Bool
  | nil => false
  | cons .. => true

theorem isCons_of_cons : (Path.cons child subpath).isCons := rfl

theorem isCons_of_eq_cons {path : Path graph start} : (path = cons child subpath) → path.isCons :=
  (by rw [·, isCons_of_cons])

theorem isCons_def {path : Path graph start} : path.isCons ↔ (∃ child subpath, path = cons child subpath) := by
  cases path <;> simp [isCons]
  exists ‹_›, ‹_›
  simp

theorem isCons_iff_not_isNil {path : Path graph start} : path.isCons ↔ ¬path.isNil := by
  cases path <;> simp [isCons, isNil]

theorem isNil_iff_not_isCons {path : Path graph start} : path.isNil ↔ ¬path.isCons := by
  cases path <;> simp [isCons, isNil]

def «class» : (Path graph start) → Class graph
  | nil            => start
  | cons _ subpath => subpath.class

@[simp]
theorem nil_class : (nil : Path graph start).class = start := rfl

@[simp]
theorem cons_class : (Path.cons child subpath).class = subpath.class := rfl

@[simp]
theorem eq_class_iff_cons_eq_class : (path₁.class = path₂.class) ↔ (Path.cons child₁ path₁).class = (Path.cons child₂ path₂).class := ⟨id, id⟩

end Path
end Network.Graph


import Std.Classes.Order

/-
We want to represent some nested function calls for a very restricted language, for example:
  and(lt(3, 5), contains("abcd", "bc"))
We represent the description (including AST) of the expr, or as we call it the Descriptor here:
-/

inductive Desc where
  | intro
    (name : String)
    (hash : UInt64)
    (params : List Desc)
    (reader: Bool)
  : Desc
  deriving Repr

/-
The `hash` field is important, because it is used to efficiently compare functions calls, so that we can reorder and simplify.  For example:
  * and(lt(3, 5), contains("abcd", "bc")) => and(contains("abcd", "bc"), lt(3, 5))
  * and(lt(3, 5), lt(3, 5)) => lt(3, 5)
  * or(and(lt(3, 5), contains("abcd", "bc")), and(contains("abcd", "bc"), lt(3, 5))) => and(contains("abcd", "bc"), lt(3, 5))
-/

/- The reader field tells us whether the function has any variables or can be evaluated at compile time. -/

def get_reader (desc: Desc): Bool :=
  match desc with
  | ⟨ _, _, _, reader⟩ => reader

def get_hash (desc: Desc): UInt64 :=
  match desc with
  | ⟨ _, hash, _, _ ⟩ => hash

def hash_list (innit: UInt64) (list: List UInt64): UInt64 :=
  List.foldl (fun acc h => 31 * acc + h) innit list

def hash_string (s: String): UInt64 :=
  hash_list 0 (List.map (Nat.toUInt64 ∘ Char.toNat) (String.toList s))

def hash_with_name (name: String) (params: List Desc): UInt64 :=
  hash_list (31 * 17 + hash_string name) (List.map get_hash params)

#eval hash_string "abcdefghjasdfasdf"

def introDesc (name: String) (params: List Desc): Desc :=
  Desc.intro
    name
    (hash_with_name name params)
    params
    (List.any params get_reader)

#eval introDesc "a" List.nil

def introReaderDesc (name: String) (params: List Desc): Desc :=
  ⟨
    name,
    hash_with_name name params,
    params,
    true
  ⟩

def cmp (x y: Desc): Ordering :=
  match x with
  | ⟨xname, xhash, xparams, _⟩ =>
    match y with
    | ⟨yname, yhash, yparams, _⟩ =>
      let chash := compare xhash yhash
      if chash != Ordering.eq
      then chash
      else
        let cname := compare xname yname
        if cname != Ordering.eq
        then cname
        else cmps xparams yparams
where cmps (xs ys : List Desc) : Ordering :=
  match xs, ys with
  | x::xs, y::ys =>
    let r := cmp x y
    if r != Ordering.eq
    then r
    else cmps xs ys
  | _, _ => Ordering.eq

instance : Hashable Desc where
  hash x := get_hash x

instance : Ord Desc where
  compare x y := cmp x y

theorem cmp_symm : ∀ (x y : Desc),
  Ordering.swap (cmp x y) = cmp y x := by
  -- TODO
  sorry

instance : Std.OrientedCmp cmp where
  symm x y := cmp_symm x y


import ReactorModel.Objects.Reactor.Theorems.Indexable
import ReactorModel.Objects.Reactor.Wellformed

namespace ReactorType

open Indexable
variable [Indexable α] [Indexable β] {rtr rtr₁ : α}

namespace Dependency

theorem nested (h : nest rtr₁ i = some rtr₂) (d : i₁ <[rtr₂] i₂) : i₁ <[rtr₁] i₂ := by
  induction d with
  | prio h₁          => exact prio (obj?_nested' h h₁).choose_spec ‹_› ‹_› ‹_› ‹_›
  | mutNorm h₁       => exact mutNorm (obj?_nested' h h₁).choose_spec ‹_› ‹_› ‹_› ‹_›
  | depOverlap h₁ h₂ => exact depOverlap (obj?_nested h h₁) (obj?_nested h h₂) ‹_› ‹_› ‹_›
  | mutNest h₁       => exact mutNest (obj?_nested' h h₁).choose_spec ‹_› ‹_› ‹_› ‹_›
  | trans _ _ d₁ d₂  => exact trans d₁ d₂

theorem Acyclic.nested (a : Acyclic rtr₁) (h : nest rtr₁ i = some rtr₂) : Acyclic rtr₂ :=
  fun i d => absurd (d.nested h) (a i)

end Dependency

namespace Wellformed

set_option hygiene false in
scoped macro "wf_nested_proof " name:ident : term => `(
  @fun
  | (_ : ID) => ($name ‹_› $ obj?_nested h ·)
  | ⊤        => ($name ‹_› <| obj?_nested_root h · |>.choose_spec)
)

theorem nested (wf : Wellformed rtr₁) (h : nest rtr₁ i = some rtr₂) : Wellformed rtr₂ where
  overlap_prio  := wf_nested_proof overlap_prio
  hazards_prio  := wf_nested_proof hazards_prio
  mutation_prio := wf_nested_proof mutation_prio
  valid_deps    := wf_nested_proof valid_deps
  acyclic_deps  := wf.acyclic_deps.nested h
  unique_inputs h₁ h₂ _ h₄ :=
    wf.unique_inputs (obj?_nested h h₁) (obj?_nested h h₂) ‹_› (obj?_mem_nested h h₄)

end Wellformed
end ReactorType


/-
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 for_mathlib.algebraic_topology.homotopical_algebra.cofibrant_object
import for_mathlib.category_theory.localization.predicate
import for_mathlib.algebraic_topology.homotopical_algebra.ks_brown_lemma
import for_mathlib.category_theory.functor_misc

noncomputable theory

open algebraic_topology category_theory category_theory.limits category_theory.category

namespace category_theory.functor

lemma map_eq_iff_of_nat_iso {C D : Type*} [category C] [category D]
  {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) {X Y : C} (f₁ f₂ : X ⟶ Y) :
  F₁.map f₁ = F₁.map f₂ ↔ F₂.map f₁ = F₂.map f₂ :=
begin
  revert F₁ F₂ e,
  suffices : ∀ {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) (h : F₁.map f₁ = F₁.map f₂),
    F₂.map f₁ = F₂.map f₂,
  { exact λ F₁ F₂ e, ⟨this e, this e.symm⟩, },
  intros F₁ F₂ e h,
  rw [← cancel_epi (e.hom.app X), ← e.hom.naturality f₁, ← e.hom.naturality f₂, h],
end

@[simp]
lemma map_eq_iff {C D : Type*} [category C] [category D]
  (F : C ⥤ D) [faithful F] {X Y : C} (f₁ f₂ : X ⟶ Y) :
  F.map f₁ = F.map f₂ ↔ f₁ = f₂ :=
begin
  split,
  { apply F.map_injective, },
  { intro h,
    rw h, }
end

lemma function_surjective_map_iff_of_iso {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (e : F ≅ G) (X Y : C) :
  function.surjective (@map _ _ _ _ F X Y) ↔ function.surjective (@map _ _ _ _ G X Y) :=
begin
  revert X Y e F G,
  suffices : ∀ {F G : C ⥤ D} (e : F ≅ G) (X Y : C) (hF : function.surjective F.map),
    function.surjective G.map,
  { exact λ F G e X Y, ⟨this e X Y, this e.symm X Y⟩, },
  intros F G e X Y hF g,
  rcases hF (e.hom.app X ≫ g ≫ e.inv.app Y) with ⟨φ, hφ⟩,
  refine ⟨φ, _⟩,
  simp only [← cancel_epi (e.hom.app X), ← e.hom.naturality φ, hφ,
    category.assoc, iso.inv_hom_id_app, comp_id],
end

end category_theory.functor

namespace category_theory.quotient

def lift.is_lift' {C D : Type*} [category C] [category D]
  (r : hom_rel C) (F : C ⥤ D)   (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂) :
  (functor r) ⋙ lift r F H = F :=
category_theory.functor.ext (λ X, rfl) (by tidy)

end category_theory.quotient

namespace algebraic_topology

namespace model_category

variables (C : Type*) [category C] [model_category C]

@[nolint has_nonempty_instance]
structure bifibrant_object :=
(obj : C)
[cof : is_cofibrant obj]
[fib : is_fibrant obj]

namespace bifibrant_object

instance (X : bifibrant_object C) : is_cofibrant X.obj := X.cof
instance (X : bifibrant_object C) : is_fibrant X.obj := X.fib

instance : category (bifibrant_object C) :=
induced_category.category (λ X, cofibrant_object.mk X.obj)

@[simps]
def forget_fib : bifibrant_object C ⥤ cofibrant_object C := induced_functor _

@[simps]
def forget : bifibrant_object C ⥤ C := forget_fib C ⋙ cofibrant_object.forget C

instance is_cofibrant_forget_obj (X : bifibrant_object C) :
  is_cofibrant ((forget C).obj X) := X.cof
instance is_fibrant_forget_obj (X : bifibrant_object C) :
  is_fibrant ((forget C).obj X) := X.fib

variable {C}

@[simp]
def weq : morphism_property (bifibrant_object C) :=
λ X Y f, model_category.weq ((bifibrant_object.forget C).map f)

def right_homotopy : hom_rel (bifibrant_object C) :=
λ A X f₁ f₂, cofibrant_object.right_homotopy f₁ f₂

lemma right_homotopy.is_equiv (A X : bifibrant_object C) :
  is_equiv (A ⟶ X) (λ f₁ f₂, right_homotopy f₁ f₂) :=
{ refl := λ f, cofibrant_object.right_homotopy.mk (path_object.some X.1)
      (right_homotopy.refl _ f),
  symm := λ f₁ f₂ H, H.symm,
  trans := λ f₁ f₂ f₃ H₁₂ H₂₃, begin
    let Cyl := cylinder.some A.obj,
    let H₁₂' := H₁₂.some_spec.some.to_left_homotopy Cyl,
    let H₂₃' := H₂₃.some_spec.some.to_left_homotopy Cyl,
    let H₁₃' := H₁₂'.trans H₂₃',
    let H₁₃ := H₁₃'.to_right_homotopy (path_object.some X.obj),
    exact cofibrant_object.right_homotopy.mk (path_object.some X.obj) H₁₃,
  end}

instance : congruence (bifibrant_object.right_homotopy : hom_rel (bifibrant_object C)) :=
{ is_equiv := right_homotopy.is_equiv,
  comp_left := λ A B X f g₁ g₂ H, H.comp_left f,
  comp_right := λ A X Y f₁ f₂ g H, H.comp_right g, }

variable (C)

def homotopy_category := quotient (right_homotopy : hom_rel (bifibrant_object C))

instance : category (homotopy_category C) := quotient.category _

variable {C}

namespace homotopy_category

@[derive full]
def Q : bifibrant_object C ⥤ homotopy_category C := quotient.functor _

@[simp]
lemma Q_map {X Y : bifibrant_object C} (f : X ⟶ Y) :
  homotopy_category.Q.map f = (quotient.functor _).map f := rfl

lemma Q_map_eq_iff' {X Y : bifibrant_object C}
  (P : path_object Y.obj) (f₁ f₂ : X ⟶ Y) :
  (homotopy_category.Q.map f₁ = homotopy_category.Q.map f₂) ↔
    nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  split,
  { intro h,
    simp only [homotopy_category.Q_map, quotient.functor_map_eq_iff] at h,
    exact nonempty.intro (h.some_spec.some.change_path_object P), },
  { intro h,
    apply category_theory.quotient.sound,
    exact cofibrant_object.right_homotopy.mk P h.some, },
end

lemma Q_map_eq_iff {X Y : bifibrant_object C}
  (Cyl : cylinder X.obj) (f₁ f₂ : X ⟶ Y) :
  (homotopy_category.Q.map f₁ = homotopy_category.Q.map f₂) ↔
    nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  rw homotopy_category.Q_map_eq_iff' (path_object.some Y.obj),
  split,
  { exact λ h, nonempty.intro (h.some.to_left_homotopy _), },
  { exact λ h, nonempty.intro (h.some.to_right_homotopy _), },
end

@[simps]
def forget_fib : homotopy_category C ⥤ cofibrant_object.homotopy_category C :=
category_theory.quotient.lift _
  (bifibrant_object.forget_fib C ⋙ cofibrant_object.homotopy_category.Q)
  (λ X Y f₁ f₂ H, begin
    dsimp only [functor.comp_map],
    haveI : is_fibrant ((forget_fib C).obj Y).obj := by { dsimp, apply_instance, },
    rw cofibrant_object.homotopy_category.Q_map_eq_iff' H.some,
    exact nonempty.intro H.some_spec.some,
  end)

def lift {D : Type*} [category D] (F : bifibrant_object C ⥤ D) (hF : weq.is_inverted_by F) :
  bifibrant_object.homotopy_category C ⥤ D :=
category_theory.quotient.lift _ F (λ X Y f₁ f₂ h, begin
  rcases h with ⟨P, h'⟩,
  let Cyl := cylinder.some X.obj,
  let H := h'.some.to_left_homotopy Cyl,
  let I := bifibrant_object.mk (Cyl.I),
  let s : I ⟶ X := Cyl.σ,
  let η : I ⟶ Y := H.h,
  let d₀ : X ⟶ I := Cyl.d₀,
  let d₁ : X ⟶ I := Cyl.d₁,
  have eq₁ : f₁ = d₀ ≫ η := H.h₀.symm,
  have eq₂ : f₂ = d₁ ≫ η := H.h₁.symm,
  simp only [eq₁, eq₂, F.map_comp],
  congr' 1,
  haveI : is_iso (F.map s) := hF s (by { dsimp [s], exact weak_eq.property, }),
  simp only [← cancel_mono (F.map s), ← F.map_comp],
  congr' 1,
  exact Cyl.σd₀.trans Cyl.σd₁.symm,
end)

lemma fac {D : Type*} [category D] (F : bifibrant_object C ⥤ D) (hF : weq.is_inverted_by F) :
  Q ⋙ lift F hF = F :=
by apply category_theory.quotient.lift.is_lift'

lemma uniq {D : Type*} [category D] (G₁ G₂ : bifibrant_object.homotopy_category C ⥤ D)
  (h₁₂ : Q ⋙ G₁ = Q ⋙ G₂) : G₁ = G₂ :=
begin
  refine category_theory.functor.ext _ _,
  { rintro ⟨X⟩,
    convert functor.congr_obj h₁₂ X, },
  { rintros ⟨X⟩ ⟨Y⟩ f,
    rw ← Q.image_preimage f,
    convert category_theory.functor.congr_map_conjugate h₁₂ (Q.preimage f), },
end

lemma Q_inverts_triv_cof {X Y : bifibrant_object C} (f : X ⟶ Y)
  [cofibration ((forget C).map f)] [weak_eq ((forget C).map f)] :
  is_iso (Q.map f) :=
begin
  have sq : comm_sq (𝟙 X.obj) ((forget C).map f) (terminal.from _) (terminal.from _) := by tidy,
  let r : Y.obj ⟶ X.obj := sq.lift,
  refine is_iso.mk ⟨Q.map r, ⟨congr_arg (λ f, Q.map f) sq.fac_left, _⟩⟩,
  rw [← Q.map_comp, ← Q.map_id Y],
  let P := path_object.some Y.obj,
  symmetry,
  rw Q_map_eq_iff' P,
  let H := right_homotopy.of_hom ((forget C).map f ≫ P.σ),
  have eq : (forget C).map f ≫ P.σ ≫ P.d₁ =
    (forget C).map f ≫ (sq.lift) ≫ (forget C).map f,
  { erw [P.d₁σ, sq.fac_left_assoc, comp_id, id_comp], },
  erw [assoc, P.d₀σ, assoc, eq] at H,
  exact nonempty.intro (right_homotopy.extension ((forget C).map f) H),
end

lemma Q_inverts_weq : weq.is_inverted_by (Q : bifibrant_object C ⥤ _) := λ X Y f hf,
begin
  let Z := bifibrant_object.mk (brown_factorisation.cofibrant.obj ((forget C).map f)),
  let i : X ⟶ Z := brown_factorisation.cofibrant.i ((forget C).map f),
  let p : Z ⟶ Y := brown_factorisation.cofibrant.p ((forget C).map f),
  let s : Y ⟶ Z := brown_factorisation.cofibrant.s ((forget C).map f),
  have fac₁ : i ≫ p = f := brown_factorisation.cofibrant.fac₁ ((forget C).map f),
  have fac₂ : s ≫ p = 𝟙 Y := brown_factorisation.cofibrant.fac₂ ((forget C).map f),
  haveI : weak_eq ((forget C).map f) := ⟨hf⟩,
  haveI : cofibration ((forget C).map i) := brown_factorisation.cofibrant.cof_i _,
  haveI : weak_eq ((forget C).map i) := brown_factorisation.cofibrant.weak_eq_i _,
  haveI : cofibration ((forget C).map s) := brown_factorisation.cofibrant.cof_s _,
  haveI : weak_eq ((forget C).map s) := brown_factorisation.cofibrant.weak_eq_s _,
  haveI := Q_inverts_triv_cof i,
  haveI := Q_inverts_triv_cof s,
  haveI : is_iso (Q.map s ≫ Q.map p) := by { rw [← Q.map_comp, fac₂], apply_instance, },
  haveI : is_iso (Q.map p) := is_iso.of_is_iso_comp_left (Q.map s) (Q.map p),
  rw [← fac₁, Q.map_comp],
  apply_instance,
end

variable (C)

def strict_universal_property_fixed_target (D : Type*) [category D] :
  localization.strict_universal_property_fixed_target (Q : bifibrant_object C ⥤ _) weq D :=
{ inverts := Q_inverts_weq,
  lift := lift,
  fac := fac,
  uniq := uniq, }

instance Q_is_localization : (Q : bifibrant_object C ⥤ _).is_localization weq :=
functor.is_localization.mk' _ _ (strict_universal_property_fixed_target C _)
  (strict_universal_property_fixed_target C _)

end homotopy_category

end bifibrant_object

section

variables {C} {D : Type*} [category D] (Lbif : bifibrant_object C ⥤ D)
  [Lbif.is_localization bifibrant_object.weq]

instance : full Lbif :=
full.of_iso (localization.comp_uniq_equivalence_functor_iso bifibrant_object.weq bifibrant_object.homotopy_category.Q Lbif)

lemma Lbif_map_eq_iff_Q_map_eq {X Y : bifibrant_object C} (f₁ f₂ : X ⟶ Y) :
  Lbif.map f₁ = Lbif.map f₂ ↔
  bifibrant_object.homotopy_category.Q.map f₁ = bifibrant_object.homotopy_category.Q.map f₂ :=
begin
  rw ← category_theory.functor.map_eq_iff_of_nat_iso
    (localization.comp_uniq_equivalence_functor_iso bifibrant_object.weq
      bifibrant_object.homotopy_category.Q Lbif),
  dsimp only [functor.comp_map],
  simp only [category_theory.functor.map_eq_iff],
end

lemma Lbif_map_eq_iff {X Y : bifibrant_object C} (Cyl : cylinder X.obj) (f₁ f₂ : X ⟶ Y) :
  Lbif.map f₁ = Lbif.map f₂ ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
by rw [← bifibrant_object.homotopy_category.Q_map_eq_iff, Lbif_map_eq_iff_Q_map_eq]

lemma Lbif_map_eq_iff' {X Y : bifibrant_object C} (P : path_object Y.obj) (f₁ f₂ : X ⟶ Y) :
  Lbif.map f₁ = Lbif.map f₂ ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
by rw [← bifibrant_object.homotopy_category.Q_map_eq_iff', Lbif_map_eq_iff_Q_map_eq]

lemma is_iso_Lbif_map' {X Y : bifibrant_object C} (f : X ⟶ Y) (hf : bifibrant_object.weq f):
  is_iso (Lbif.map f) := localization.inverts Lbif bifibrant_object.weq f hf

lemma is_iso_Lbif_map {X Y : bifibrant_object C} (f : X ⟶ Y) [hf : weak_eq ((bifibrant_object.forget C).map f)] :
  is_iso (Lbif.map f) := is_iso_Lbif_map' Lbif f hf.property

end

end model_category

end algebraic_topology


import .types

-- Required for us to emit more compact `conv` invocations
import tactic.converter.interactive

open interactive interactive.types expr tactic

variables {α β γ δ : Type}

namespace tactic.rewrite_search

private meta def hand : sided_pair string := ⟨"lhs", "rhs"⟩

meta def nth_rule (rs : list (expr × bool)) (i : ℕ) : expr × bool := (rs.nth i).iget

meta def pp_rule (r : expr × bool) : tactic string :=
  do pp ← pp r.1, return $ (if r.2 then "←" else "") ++ (to_string pp)

meta def how.to_rewrite (rs : list (expr × bool)) : how → option (expr × bool)
| (how.rewrite index _ _) := nth_rule rs index
| _ := none

meta def explain_using_location (rs : list (expr × bool)) (s : side) : how → tactic (option string)
| (how.rewrite index location _) := do
  rule ← pp_rule $ nth_rule rs index,
  return $ some ("nth_rewrite_" ++ hand.get s ++ " " ++ to_string location ++ " " ++ rule)
| _ := return none

meta def using_location.explain_rewrites (rs : list (expr × bool)) (s : side) (steps : list how) : tactic string := do
  rules ← steps.mmap $ λ h : how, option.to_list <$> explain_using_location rs s h,
  return $ string.intercalate ",\n" rules.join

namespace using_conv

inductive app_addr
| node (children : sided_pair (option app_addr)) : app_addr
| rw : list ℕ → app_addr

open app_addr

meta def app_addr.to_string : app_addr → string
| (node c) := "(node " ++ ((c.to_list.filter_map id).map app_addr.to_string).to_string ++ ")"
| (rw rws) := "(rw " ++ rws.to_string ++ ")"

inductive splice_result
-- There was more of the addr to be added left, but we hit a rw
| obstructed
-- The added addr was already fully contained, and did not terminate at an existing rw
| contained
-- The added addr terminated at an existing rw or we could create a new one for it
| new (addr : app_addr)

open splice_result

def splice_result.pack (s : side) : splice_result → sided_pair (option app_addr) → splice_result
| (new addr) c := new $ app_addr.node $ c.set s (some addr)
| sr _ := sr

-- TODO? prove well founded
private meta def splice_in_aux (new_rws : list ℕ) : option app_addr → list side → splice_result
| (some $ node _) [] := contained
| (some $ node c) (s :: rest) := (splice_in_aux (c.get s) rest).pack s c
| (some $ rw _) (_ :: _) := obstructed
| (some $ rw rws) [] := new $ rw (rws ++ new_rws)
| none [] := new $ rw new_rws
| none l := splice_in_aux (some $ node ⟨none, none⟩) l

private meta def to_congr_form : list side → tactic (list side)
| [] := return []
| (side.L :: (side.R :: rest)) := do
  r ← to_congr_form rest,
  return (side.L :: r)
| (side.R :: rest) := do
  r ← to_congr_form rest,
  return (side.R :: r)
| [side.L] := fail "app list ends in side.L!"
| (side.L :: (side.L :: _)) := fail "app list has repeated side.L!"

meta def splice_in (a : option app_addr) (rws : list ℕ) (s : list side) : tactic splice_result :=
  splice_in_aux rws a <$> to_congr_form s

meta def build_rw_tactic (rs : list (expr × bool)) (hs : list ℕ) : tactic string := do
  rws ← (hs.map $ nth_rule rs).mmap pp_rule,
  return $ "erw [" ++ (string.intercalate ", " rws) ++ "]"

meta def explain_tree_aux (rs : list (expr × bool)) : app_addr → tactic (option (list string))
| (app_addr.rw rws) := (λ a, some [a]) <$> build_rw_tactic rs rws
| (app_addr.node ⟨func, arg⟩) := do
  sf ← match func with | none := pure none | some func := explain_tree_aux func end,
  sa ← match arg  with | none := pure none | some arg  := explain_tree_aux arg  end,
  return $ match (sf, sa) with
  | (none, none) := none
  | (some sf, none) := ["congr"].append sf
  | (none, some sa) := ["congr", "skip"].append sa
  | (some sf, some sa) := (["congr"].append sf).append (["skip"].append sf)
  end

-- TODO break the tree into pieces when the gaps are too big
meta def explain_tree (rs : list (expr × bool)) (tree : app_addr) : tactic (list string) :=
  list.join <$> option.to_list <$> explain_tree_aux rs tree

meta def compile_rewrites_aux (rs : list (expr × bool)) (s : side) : option app_addr → list how → tactic (list string)
| none [] := return []
| (some tree) [] := do
  tacs ← explain_tree rs tree,
  return $ if tacs.length = 0 then []
  else ["conv_" ++ hand.get s ++ " { " ++ string.intercalate ", " tacs ++ " }"]
| tree (h :: rest) := do
-- TODO handle other how.* values here, e.g. how.simp
-- At the moment we just silently drop these.
  (new_tree, rest_if_fail) ← match h with
  | how.rewrite index loc (some addr) := do
    new_tree ← splice_in tree [index] addr,
    return (some new_tree, list.cons h rest)
  | _ := do
    return (none, rest)
  end,

  match new_tree with
  | some (new new_tree) := compile_rewrites_aux new_tree rest
  | _ := do
    line ← compile_rewrites_aux tree [],
    lines ← compile_rewrites_aux none rest_if_fail,
    return $ line ++ lines
  end

meta def compile_rewrites (rs : list (expr × bool)) (s : side) : list how → tactic (list string) :=
  compile_rewrites_aux rs s none

meta def explain_rewrites (rs : list (expr × bool)) (s : side) (hows : list how) : tactic string :=
  string.intercalate ",\n" <$> compile_rewrites rs s hows

end using_conv

meta def explain_rewrites_concisely (steps : list (expr × bool)) (needs_refl : bool) : tactic string := do
  rules ← string.intercalate ", " <$> steps.mmap pp_rule,
  return $ "erw [" ++ rules ++ "]" ++ (if needs_refl then ", refl" else "")

-- fails if we can't just use rewrite
-- otherwise, returns 'tt' if we need a `refl` at the end
meta def check_if_simple_rewrite_succeeds (rewrites : list (expr × bool)) (goal : expr) : tactic bool :=
lock_tactic_state $ do
  m ← mk_meta_var goal,
  set_goals [m],
  rewrites.mmap' $ λ q, rewrite_target q.1 {symm := q.2, md := semireducible},
  (reflexivity reducible >> return ff) <|> (reflexivity >> return tt)

meta def proof_unit.rewrites (u : proof_unit) (rs : list (expr × bool)) : list (expr × bool) :=
  u.steps.filter_map $ how.to_rewrite rs

-- TODO rewrite this to use conv!
meta def proof_unit.explain (u : proof_unit) (rs : list (expr × bool)) (explain_using_conv : bool) : tactic string := do
  -- TODO We could try to merge adjacent proof units or something more complicated.

  -- FIXME using explain_rewrites_concisely:
  -- Currently we only try to explain away the whole proof, falling back on
  -- failure. Moreover, "single proof unit" is unfortunately broken, because
  -- `erw` inspects the goal when it performs its actions. As an example of a
  -- failing case, observe (or check) that given an axiom `foo` saying [1] = [2]`
  -- then `check_if_simple_rewrite_succeeds` will approve using `erw [foo]` to
  -- discharge the goal `[[1], [1]] = [[1], [2]]`, even though once part of the
  -- explaination of a bigger proof with multiple units `erw` will turn
  -- `[[1], [1]]` into `[[2], [2]]`, not what we want.

  -- One possible solution is to prepend `transitivity xxx` in front of such
  -- left-proof_units (currently we only do this for right-proof_units), but
  -- this seems to tend to be more clumsy that a one-line `congr` which would
  -- normally replace it.

  -- This is a bit of a shame, though, since it works quite well in many siutations.
  -- Perhaps we should run though given this optimisation, try to see if the
  -- resulting whole proof works, emit if it succeeds and if it fails go-again
  -- without the optimisations? This actually wouldn't be too hard to implement.

  -- (do
  --   goal ← infer_type u.proof,
  --   let rewrites := u.rewrites cfg,
  --   needs_refl ← check_if_simple_rewrite_succeeds rewrites goal,
  --   explain_rewrites_concisely rewrites needs_refl
  -- ) <|>

  if explain_using_conv then
    using_conv.explain_rewrites rs u.side u.steps
  else
    using_location.explain_rewrites rs u.side u.steps

meta def explain_proof_full (rs : list (expr × bool)) (explain_using_conv : bool) : list proof_unit → tactic string
| [] := return ""
| (u :: rest) := do
  -- This is an optimisation: don't use transitivity for the last unit, since
  -- it neccesarily must be redundant.
  head ← if rest.length = 0 ∨ u.side = side.L then pure [] else (do
    n ← infer_type u.proof >>= rw_equation.rhs >>= pp,
    pure $ ["transitivity " ++ to_string n]
  ),

  unit_expl ← u.explain rs explain_using_conv,
  rest_expl ← explain_proof_full rest,
  let expls := (head ++ [unit_expl, rest_expl]).filter $ λ t, ¬(t.length = 0),
  return $ string.intercalate ",\n" expls

meta def explain_proof_concisely (rs : list (expr × bool)) (proof : expr) (l : list proof_unit) : tactic string := do
  let rws : list (expr × bool) := list.join $ l.map (λ u, do
    (r, s) ← u.rewrites rs,
    return (r, if u.side = side.L then s else ¬s)
  ),
  goal ← infer_type proof,
  needs_refl ← check_if_simple_rewrite_succeeds rws goal,
  explain_rewrites_concisely rws needs_refl

meta def explain_search_result (cfg : config) (rs : list (expr × bool)) (proof : expr) (units : list proof_unit) : tactic string := do
  if cfg.trace then do
    pp ← pp proof,
    trace format!"rewrite_search found proof:\n{pp}"
  else skip,

  explanation ← explain_proof_concisely rs proof units <|> explain_proof_full rs cfg.explain_using_conv units,
  if cfg.explain then trace $ "/- `rewrite_search` says -/\n" ++ explanation
  else skip,
  return explanation

end tactic.rewrite_search