import tag009H -- to get definition of stalk, which is the only filtered colimit I care about right now
import tag009P -- presheaf of (commutative) rings on basis
universe u
--#print presheaf_on_basis_stalk
--#print presheaf_on_basis_stalk.aux
namespace presheaf_of_rings_on_basis_stalk

variables {X : Type u} [topological_space X] {B : set (set X)}
{HB : topological_space.is_topological_basis B}
-- goal : comm_ring (presheaf_on_basis_stalk (FPRB.to_presheaf_of_types_on_basis) x)

def stalk (FPRB : presheaf_of_rings_on_basis HB)
(x : X)
(Hstandard : ∀ {{U V : set X}}, U ∈ B → V ∈ B → U ∩ V ∈ B)
(Hall : set.univ ∈ B)
:= presheaf_on_basis_stalk (FPRB.to_presheaf_of_types_on_basis) x

def stalk.aux (FPRB : presheaf_of_rings_on_basis HB)
(x : X)
(Hstandard : ∀ {{U V : set X}}, U ∈ B → V ∈ B → U ∩ V ∈ B)
(Hall : set.univ ∈ B)
:= presheaf_on_basis_stalk.aux (FPRB.to_presheaf_of_types_on_basis) x

-- need this instance because a stalk.aux of a presheaf of types is a setoid
-- but I have a presheaf of rings
-- I guess I could have had presheaf of rings coe to presheaf of types?
variables (FPRB : presheaf_of_rings_on_basis HB) (x : X)
(Hstandard : ∀ {{U V : set X}}, U ∈ B → V ∈ B → U ∩ V ∈ B)
(Hall : set.univ ∈ B)
include FPRB x Hstandard Hall

instance stalk_is_setoid
 : setoid (stalk.aux FPRB x Hstandard Hall) := presheaf_on_basis_stalk.setoid FPRB.to_presheaf_of_types_on_basis x

private def add_aux : stalk.aux FPRB x Hstandard Hall → stalk.aux FPRB x Hstandard Hall → stalk FPRB x Hstandard Hall :=
λ s t,⟦⟨s.U ∩ t.U,Hstandard s.BU t.BU,⟨s.Hx,t.Hx⟩,
        FPRB.res s.BU _   (set.inter_subset_left _ _) s.s +
        FPRB.res t.BU _   (set.inter_subset_right _ _) t.s
      ⟩⟧

instance ring_stalk_has_add : has_add (stalk FPRB x Hstandard Hall) :=
⟨quotient.lift₂ (add_aux FPRB x Hstandard Hall) (λ a₁ a₂ b₁ b₂ H1 H2,
  let U1 := classical.some H1 in
  let U2 := classical.some H2 in
  quotient.sound ⟨U1 ∩ U2,begin
    have H1' := classical.some_spec H1,
    cases H1' with Hx1 H1',
    cases H1' with BU1 H1',
    cases H1' with HUa₁ H1',
    cases H1' with HUb₁ H1',
    have H2' := classical.some_spec H2,
    cases H2' with Hx2 H2',
    cases H2' with BU2 H2',
    cases H2' with HUa₂ H2',
    cases H2' with HUb₂ H2',
    existsi (⟨Hx1,Hx2⟩ : x ∈ U1 ∩ U2),
    existsi Hstandard BU1 BU2,
    existsi set.inter_subset_inter HUa₁ HUa₂,
    existsi set.inter_subset_inter HUb₁ HUb₂,
    rw (FPRB.res_is_ring_morphism _ _ _).map_add,
    rw (FPRB.res_is_ring_morphism _ _ _).map_add,
    show (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (a₁.s) +
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (a₂.s) =
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (b₁.s) +
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (b₂.s),
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    suffices : (FPRB.res BU1 (Hstandard BU1 BU2) (set.inter_subset_left _ _) ∘ FPRB.res a₁.BU BU1 HUa₁) (a₁.s) +
      (FPRB.res BU2 (Hstandard BU1 BU2) (set.inter_subset_right _ _) ∘ FPRB.res a₂.BU BU2 HUa₂) (a₂.s) =
      (FPRB.res BU1 (Hstandard BU1 BU2) (set.inter_subset_left _ _) ∘ FPRB.res b₁.BU BU1 HUb₁) (b₁.s) +
      (FPRB.res BU2 (Hstandard BU1 BU2) (set.inter_subset_right _ _) ∘ FPRB.res b₂.BU BU2 HUb₂) (b₂.s),
    rwa [←FPRB.Hcomp,←FPRB.Hcomp,←FPRB.Hcomp,←FPRB.Hcomp] at this,
    simp [H1',H2']
  end⟩)⟩

  --#check is_ring_hom

private def neg_aux : stalk.aux FPRB x Hstandard Hall → stalk FPRB x Hstandard Hall :=
λ s,⟦⟨s.U,s.BU,s.Hx,-s.s⟩⟧

instance : has_neg (stalk FPRB x Hstandard Hall) :=
⟨quotient.lift (neg_aux FPRB x Hstandard Hall) $ begin
  intros a b H,
  apply quotient.sound,
  cases H with U H,
  existsi U,
  cases H with Hx H,
  existsi Hx,
  cases H with BW H,
  existsi BW,
  cases H with HWU H,
  existsi HWU,
  cases H with HWV H,
  existsi HWV,
  show FPRB.res _ _ _ (-a.s) = FPRB.res _ _ _ (-b.s),
  have Ha : FPRB.res _ BW HWU (-a.s) = -(FPRB.res _ BW HWU a.s),
    rw @is_ring_hom.map_neg _ _ _ _ _ (FPRB.res_is_ring_morphism _ _ _),
  rw [Ha,H],
  rw @is_ring_hom.map_neg _ _ _ _ _ (FPRB.res_is_ring_morphism _ _ _),
end⟩

--#check @is_ring_hom.map_neg

private def mul_aux : stalk.aux FPRB x Hstandard Hall → stalk.aux FPRB x Hstandard Hall → stalk FPRB x Hstandard Hall:=
λ s t,⟦⟨s.U ∩ t.U,Hstandard s.BU t.BU,⟨s.Hx,t.Hx⟩,
        FPRB.res s.BU _   (set.inter_subset_left _ _) s.s *
        FPRB.res t.BU _   (set.inter_subset_right _ _) t.s
      ⟩⟧

instance ring_stalk_has_mul : has_mul (stalk FPRB x Hstandard Hall) :=
⟨quotient.lift₂ (mul_aux FPRB x Hstandard Hall) (λ a₁ a₂ b₁ b₂ H1 H2,
  let U1 := classical.some H1 in
  let U2 := classical.some H2 in
  quotient.sound ⟨U1 ∩ U2,begin
    have H1' := classical.some_spec H1,
    cases H1' with Hx1 H1',
    cases H1' with BU1 H1',
    cases H1' with HUa₁ H1',
    cases H1' with HUb₁ H1',
    have H2' := classical.some_spec H2,
    cases H2' with Hx2 H2',
    cases H2' with BU2 H2',
    cases H2' with HUa₂ H2',
    cases H2' with HUb₂ H2',
    existsi (⟨Hx1,Hx2⟩ : x ∈ U1 ∩ U2),
    existsi Hstandard BU1 BU2,
    existsi set.inter_subset_inter HUa₁ HUa₂,
    existsi set.inter_subset_inter HUb₁ HUb₂,
    rw (FPRB.res_is_ring_morphism _ _ _).map_mul,
    rw (FPRB.res_is_ring_morphism _ _ _).map_mul,
    show (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (a₁.s) *
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (a₂.s) =
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (b₁.s) *
         (FPRB.res _ _ _ ∘ FPRB.res _ _ _) (b₂.s),
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    rw ←FPRB.Hcomp,
    suffices : (FPRB.res BU1 (Hstandard BU1 BU2) (set.inter_subset_left _ _) ∘ FPRB.res a₁.BU BU1 HUa₁) (a₁.s) *
      (FPRB.res BU2 (Hstandard BU1 BU2) (set.inter_subset_right _ _) ∘ FPRB.res a₂.BU BU2 HUa₂) (a₂.s) =
      (FPRB.res BU1 (Hstandard BU1 BU2) (set.inter_subset_left _ _) ∘ FPRB.res b₁.BU BU1 HUb₁) (b₁.s) *
      (FPRB.res BU2 (Hstandard BU1 BU2) (set.inter_subset_right _ _) ∘ FPRB.res b₂.BU BU2 HUb₂) (b₂.s),
    rwa [←FPRB.Hcomp,←FPRB.Hcomp,←FPRB.Hcomp,←FPRB.Hcomp] at this,
    simp [H1',H2']
  end⟩)⟩

/-
lemma x_in_basis_elt : ∃ U ∈ B, x ∈ U :=
begin
have H1 := HB.2.1.symm,
have H2 : x ∈ @set.univ X := trivial,
rw H1 at H2,
cases H2 with U HU,
existsi U,
existsi HU.fst,
exact HU.snd
end
-/

private def zero : stalk FPRB x Hstandard Hall :=
⟦⟨set.univ,Hall,trivial,0⟩⟧

instance ring_stalk_has_zero : has_zero (stalk FPRB x Hstandard Hall) := ⟨zero FPRB x Hstandard Hall⟩

private def one : stalk FPRB x Hstandard Hall :=
⟦⟨set.univ,Hall,trivial,1⟩⟧

instance ring_stalk_has_one : has_one (stalk FPRB x Hstandard Hall) := ⟨one FPRB x Hstandard Hall⟩

/-
lemma r_of_eq : ∀ a b : (stalk.aux FPRB x Hstandard Hall), a = b → a ≈ b := begin
intros a b Hab,
rw Hab,
end
-/

/-
lemma eq_eta : ∀ sU tU sBU tBU sHx tHx ss ts,ss = ts →
  (⟨sU,sBU,sHx,ss⟩ : (stalk.aux FPRB x Hstandard)) = ⟨tU,tBU,tHx,ts⟩ :=
  begin
sorry
  end
-/

instance stalks_of_presheaf_of_rings_on_basis_are_rings
-- {X : Type u} [topological_space X] {B : set (set X)}
--{HB : topological_space.is_topological_basis B} (FPRB : presheaf_of_rings_on_basis HB) (x : X) :
: comm_ring (stalk FPRB x Hstandard Hall) := begin
  refine {
    add := has_add.add,
    add_assoc := _,
    zero := (zero FPRB x Hstandard Hall),
    zero_add := _,
    add_zero := _,
    neg := has_neg.neg,
    add_left_neg := _,
    add_comm := _,
    mul := has_mul.mul,
    mul_assoc := _,
    mul_one := _,
    one := (one FPRB x Hstandard Hall),
    one_mul := _,
    left_distrib := _,
    right_distrib := _,
    mul_comm := _,
  },
  show ∀ (a b c : stalk FPRB x Hstandard Hall), a + b + c = a + (b + c),
  { intros a1 b1 c1,
    refine quotient.induction_on₃ a1 b1 c1 _,
    intros,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    cases c with Uc BUc Hxc sc,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub ∩ Uc), -- brainwave
    existsi (⟨⟨Hxa,Hxb⟩,Hxc⟩ : x ∈ Ua ∩ Ub ∩ Uc),
    existsi (Hstandard (Hstandard BUa BUb) BUc),
    existsi (set.subset.refl (Ua ∩ Ub ∩ Uc)),
    existsi ((set.inter_assoc Ua Ub Uc ▸ set.subset.refl _) : Ua ∩ Ub ∩ Uc ⊆ Ua ∩ (Ub ∩ Uc)),
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←(presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw add_assoc,
  --    simp [add_assoc,add_comm],rw add_comm, -- also works!
  },
  show ∀ (a : stalk FPRB x Hstandard Hall), 0 + a = a,
  { intro a1,
    refine quotient.induction_on a1 _,
    intro a,
    cases a with Ua BUa Hxa sa,
    refine quotient.sound _,
    dsimp,
    existsi (set.univ ∩ Ua),
    existsi ( ⟨trivial,Hxa⟩ : x ∈ set.univ ∩ Ua),
    existsi (Hstandard Hall BUa : set.univ ∩ Ua ∈ B),
    existsi (_ : set.univ ∩ Ua ⊆ set.univ ∩ Ua),tactic.swap,rw set.inter_comm,
    existsi _,tactic.swap, rw set.univ_inter Ua,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw is_ring_hom.map_zero (FPRB.res _ _ _);try {apply_instance},
    -- (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_zero,
    rw zero_add,
  },
  show ∀ (a : stalk FPRB x Hstandard Hall), a + 0 = a,
  { intro a1,
    refine quotient.induction_on a1 _,
    intro a,
    cases a with Ua BUa Hxa sa,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ set.univ),
    existsi ( ⟨Hxa,trivial⟩ : x ∈ Ua ∩ set.univ),
    existsi (Hstandard BUa Hall : Ua ∩ set.univ ∈ B),
    existsi (_ : Ua ∩ set.univ ⊆ Ua ∩ set.univ),tactic.swap,rw set.inter_comm,
    existsi _,tactic.swap, rw set.inter_univ Ua,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw is_ring_hom.map_zero (FPRB.res _ _ _);try {apply_instance},
    -- (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_zero,
    rw add_zero
  },
  show ∀ (a : stalk FPRB x Hstandard Hall), -a + a = 0,
  { intro a1,
    refine quotient.induction_on a1 _,
    intro a,
    cases a with Ua BUa Hxa sa,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ua),
    existsi _,tactic.swap, exact ⟨Hxa,Hxa⟩,
    existsi _,tactic.swap, exact Hstandard BUa BUa,
    existsi _,tactic.swap, exact set.subset.refl _,
    existsi _,tactic.swap, exact set.subset.trans (set.inter_subset_left _ _) (set.subset_univ _),
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw is_ring_hom.map_neg (FPRB.res _ _ _);try {apply_instance},
    rw add_left_neg,
    rw is_ring_hom.map_zero (FPRB.res _ _ _);try {apply_instance}
  },
  show ∀ (a b : stalk FPRB x Hstandard Hall), a + b = b + a,
  { intros a1 b1,
    refine quotient.induction_on₂ a1 b1 _,
    intros a b,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub), -- brainwave
    existsi (⟨Hxa,Hxb⟩ : x ∈ Ua ∩ Ub),
    existsi (Hstandard BUa BUb),
    existsi (set.subset.refl (Ua ∩ Ub)),
    existsi ((set.inter_comm Ua Ub ▸ set.subset.refl _) : Ua ∩ Ub ⊆ Ub ∩ Ua),
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw add_comm
  },
  show ∀ (a b c : stalk FPRB x Hstandard Hall), a * b * c = a * (b * c),
  { intros a1 b1 c1,
    refine quotient.induction_on₃ a1 b1 c1 _,
    intros,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    cases c with Uc BUc Hxc sc,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub ∩ Uc),
    existsi (⟨⟨Hxa,Hxb⟩,Hxc⟩ : x ∈ Ua ∩ Ub ∩ Uc),
    existsi (Hstandard (Hstandard BUa BUb) BUc),
    existsi (set.subset.refl (Ua ∩ Ub ∩ Uc)),
    existsi ((set.inter_assoc Ua Ub Uc ▸ set.subset.refl _) : Ua ∩ Ub ∩ Uc ⊆ Ua ∩ (Ub ∩ Uc)),
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw mul_assoc
  },
  show ∀ (a : stalk FPRB x Hstandard Hall), _ * a = a, -- 1
  { intro a1,
    refine quotient.induction_on a1 _,
    intro a,
    cases a with Ua BUa Hxa sa,
    refine quotient.sound _,
    dsimp,
    existsi (set.univ ∩ Ua),
    existsi ( ⟨trivial,Hxa⟩ : x ∈ set.univ ∩ Ua),
    existsi (Hstandard Hall BUa : set.univ ∩ Ua ∈ B),
    existsi (_ : set.univ ∩ Ua ⊆ set.univ ∩ Ua),tactic.swap,rw set.inter_comm,
    existsi _,tactic.swap, rw set.univ_inter Ua,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw is_ring_hom.map_one (FPRB.res _ _ _);try {apply_instance},
    rw one_mul,
  },
  show ∀ (a : stalk FPRB x Hstandard Hall), a * 1 = a,
  { intro a1,
    refine quotient.induction_on a1 _,
    intro a,
    cases a with Ua BUa Hxa sa,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ set.univ),
    existsi ( ⟨Hxa,trivial⟩ : x ∈ Ua ∩ set.univ),
    existsi (Hstandard BUa Hall : Ua ∩ set.univ ∈ B),
    existsi (_ : Ua ∩ set.univ ⊆ Ua ∩ set.univ),tactic.swap,rw set.inter_comm,
    existsi _,tactic.swap, rw set.inter_univ Ua,
    rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul,
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw ←presheaf_of_types_on_basis.Hcomp',
    rw is_ring_hom.map_one (FPRB.res _ _ _);try {apply_instance},
    -- (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_zero,
    rw mul_one
  },
  show ∀ (a b c : stalk FPRB x Hstandard Hall), a * (b + c) = a * b + a * c,
  { intros a1 b1 c1,
    refine quotient.induction_on₃ a1 b1 c1 _,
    intros,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    cases c with Uc BUc Hxc sc,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub ∩ Uc), -- brainwave
    existsi (⟨⟨Hxa,Hxb⟩,Hxc⟩ : x ∈ Ua ∩ Ub ∩ Uc),
    existsi (Hstandard (Hstandard BUa BUb) BUc),
    existsi ((set.inter_assoc Ua Ub Uc ▸ set.subset.refl _) : Ua ∩ Ub ∩ Uc ⊆ Ua ∩ (Ub ∩ Uc)),
    existsi _,tactic.swap, show (Ua ∩ Ub ∩ Uc ⊆ Ua ∩ Ub ∩ (Ua ∩ Uc)),
      intros y Hy,cases Hy with Hab Hc, cases Hab with Ha Hb,
      exact ⟨⟨Ha,Hb⟩,⟨Ha,Hc⟩⟩,
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add},
    repeat {rw ←presheaf_of_types_on_basis.Hcomp'},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add},
    repeat {rw ←presheaf_of_types_on_basis.Hcomp'},
    rw mul_add,
  },
  show ∀ (a b c : stalk FPRB x Hstandard Hall), (a + b) * c = a * c + b * c,
  { intros a1 b1 c1,
    refine quotient.induction_on₃ a1 b1 c1 _,
    intros,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    cases c with Uc BUc Hxc sc,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub ∩ Uc), -- brainwave
    existsi (⟨⟨Hxa,Hxb⟩,Hxc⟩ : x ∈ Ua ∩ Ub ∩ Uc),
    existsi (Hstandard (Hstandard BUa BUb) BUc),
    existsi (set.subset.refl _),
    existsi _,tactic.swap, show (Ua ∩ Ub ∩ Uc ⊆ Ua ∩ Uc ∩ (Ub ∩ Uc)),
      intros y Hy,cases Hy with Hab Hc, cases Hab with Ha Hb,
      exact ⟨⟨Ha,Hc⟩,⟨Hb,Hc⟩⟩,
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add},
    repeat {rw ←presheaf_of_types_on_basis.Hcomp'},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul},
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_add},
    repeat {rw ←presheaf_of_types_on_basis.Hcomp'},
    rw add_mul,
  },
  -- last one!
  show ∀ (a b : stalk FPRB x Hstandard Hall), a * b = b * a,
  { intros a1 b1,
    refine quotient.induction_on₂ a1 b1 _,
    intros,
    cases a with Ua BUa Hxa sa,
    cases b with Ub BUb Hxb sb,
    refine quotient.sound _,
    dsimp,
    existsi (Ua ∩ Ub),
    existsi (⟨Hxa,Hxb⟩ : x ∈ Ua ∩ Ub),
    existsi (Hstandard BUa BUb),
    existsi (set.subset.refl _),
    existsi _,tactic.swap, rw set.inter_comm,
    repeat {rw (presheaf_of_rings_on_basis.res_is_ring_morphism FPRB _ _ _).map_mul},
    repeat {rw ←presheaf_of_types_on_basis.Hcomp'},
    rw mul_comm,
  },
end
end presheaf_of_rings_on_basis_stalk


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Util.ForEachExpr
import Lean.Meta.ForEachExpr
import Lean.Meta.RecursorInfo
import Lean.Meta.Match.Match
import Lean.Meta.Transform
import Lean.Meta.IndPredBelow
import Lean.Elab.PreDefinition.Basic
namespace Lean.Elab
namespace Structural
open Meta

private def getFixedPrefix (declName : Name) (xs : Array Expr) (value : Expr) : MetaM Nat := do
  let numFixedRef ← IO.mkRef xs.size
  forEachExpr' value fun e => do
    if e.isAppOf declName then
      let args := e.getAppArgs
      numFixedRef.modify fun numFixed => if args.size < numFixed then args.size else numFixed
      for arg in args, x in xs do
        /- We should not use structural equality here. For example, given the definition
           ```
           def V.map {α β} f x x_1 :=
             @V.map.match_1.{1} α (fun x x_2 => V β x) x x_1
               (fun x x_2 => @V.mk₁ β x (f Bool.true x_2))
               (fun e => @V.mk₂ β (V.map (fun b => α b) (fun b => β b) f Bool.false e))
           ```
           The first three arguments at `V.map (fun b => α b) (fun b => β b) f Bool.false e` are "fixed"
           modulo definitional equality.

           We disable to proof irrelevance to be able to use structural recursion on inductive predicates.
           For example, consider the example
           ```
          inductive PList (α : Type) : Prop
          | nil
          | cons : α → PList α → PList α

          infixr:67 " ::: " => PList.cons

          set_option trace.Elab.definition.structural true in
          def pmap {α β} (f : α → β) : PList α → PList β
          | PList.nil => PList.nil
          | a:::as => f a ::: pmap f as
          ```
          The "Fixed" prefix would be 4 since all elements of type `PList α` are definitionally equal.
        -/
        if !(← withoutProofIrrelevance <| withReducible <| isDefEq arg x) then
          -- We continue searching if e's arguments are not a prefix of `xs`
          return true
      return false
    else
      return true
  numFixedRef.get

structure RecArgInfo where
  /- `fixedParams ++ ys` are the arguments of the function we are trying to justify termination using structural recursion. -/
  fixedParams : Array Expr
  ys          : Array Expr  -- recursion arguments
  pos         : Nat         -- position in `ys` of the argument we are recursing on
  indicesPos  : Array Nat   -- position in `ys` of the inductive datatype indices we are recursing on
  indName     : Name        -- inductive datatype name of the argument we are recursing on
  indLevels   : List Level  -- inductice datatype universe levels of the argument we are recursing on
  indParams   : Array Expr  -- inductive datatype parameters of the argument we are recursing on
  indIndices  : Array Expr  -- inductive datatype indices of the argument we are recursing on, it is equal to `indicesPos.map fun i => ys.get! i`
  reflexive   : Bool        -- true if we are recursing over a reflexive inductive datatype
  indPred     : Bool        -- true if the type is an inductive predicate

private def getIndexMinPos (xs : Array Expr) (indices : Array Expr) : Nat := do
  let mut minPos := xs.size
  for index in indices do
    match xs.indexOf? index with
    | some pos => if pos.val < minPos then minPos := pos.val
    | _        => pure ()
  return minPos

-- Indices can only depend on other indices
private def hasBadIndexDep? (ys : Array Expr) (indices : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for index in indices do
    let indexType ← inferType index
    for y in ys do
      if !indices.contains y && (← dependsOn indexType y.fvarId!) then
        return some (index, y)
  return none

-- Inductive datatype parameters cannot depend on ys
private def hasBadParamDep? (ys : Array Expr) (indParams : Array Expr) : MetaM (Option (Expr × Expr)) := do
  for p in indParams do
    let pType ← inferType p
    for y in ys do
      if ← dependsOn pType y.fvarId! then
        return some (p, y)
  return none

private def throwStructuralFailed {α} : MetaM α :=
  throwError "structural recursion cannot be used"

structure State where
  /- When compiling structural recursion we use the `brecOn` recursor automatically built by
     the `inductive` command. For an inductive datatype `C`, it has the form
     `C.brecOn As motive is c F`
     where `As` are the inductive datatype parameters, `is` are the inductive datatype indices,
     `c : C As is`, and `F : (js) → (d : C As js) → C.below d → motive d`
     The `C.below d` is used to eliminate recursive applications. We refine its type when we process
     a nested dependent pattern matcher using `MatcherApp.addArg`. See `replaceRecApps` for additional details.
     We store the names of the matcher where we used `MatcherApp.addArg` at `matcherBelowDep`.
     We use this information to generate the auxiliary `_sunfold` definition needed by the smart unfolding
     technique used at WHNF. -/
  matcherBelowDep : NameSet := {}
  /- As part of the inductive predicates case, we keep adding more and more discriminants from the
     local context and build up a bigger matcher application until we reach a fixed point.
     As a side-effect, this creates matchers. Here we capture all these side-effects, because
     the construction rolls back any changes done to the environment and the side-effects
     need to be replayed. -/
  addMatchers : Array $ MetaM Unit := #[]

abbrev M := StateRefT State MetaM

instance {α} : Inhabited (M α) where
  default := throwError "failed"

private def run {α} (x : M α) (s : State := {}) : MetaM (α × State) :=
  StateRefT'.run x s

private def orelse' {α} (x y : M α) : M α := do
  let saveState ← get
  orelseMergeErrors x (do set saveState; y)

private partial def findRecArg {α} (numFixed : Nat) (xs : Array Expr) (k : RecArgInfo → M α) : M α :=
  let rec loop (i : Nat) : M α := do
    if h : i < xs.size then
      let x := xs.get ⟨i, h⟩
      let localDecl ← getFVarLocalDecl x
      if localDecl.isLet then
        throwStructuralFailed
      else
        let xType ← whnfD localDecl.type
        matchConstInduct xType.getAppFn (fun _ => loop (i+1)) fun indInfo us => do
        if !(← hasConst (mkBRecOnName indInfo.name)) then
          loop (i+1)
        else if indInfo.isReflexive && !(← hasConst (mkBInductionOnName indInfo.name)) then
          loop (i+1)
        else
          let indArgs    := xType.getAppArgs
          let indParams  := indArgs.extract 0 indInfo.numParams
          let indIndices := indArgs.extract indInfo.numParams indArgs.size
          if !indIndices.all Expr.isFVar then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not variables{indentExpr xType}")
              (loop (i+1))
          else if !indIndices.allDiff then
            orelse'
              (throwError "argument #{i+1} was not used because its type is an inductive family and indices are not pairwise distinct{indentExpr xType}")
              (loop (i+1))
          else
            let indexMinPos := getIndexMinPos xs indIndices
            let numFixed    := if indexMinPos < numFixed then indexMinPos else numFixed
            let fixedParams := xs.extract 0 numFixed
            let ys          := xs.extract numFixed xs.size
            match (← hasBadIndexDep? ys indIndices) with
            | some (index, y) =>
              orelse'
                (throwError "argument #{i+1} was not used because its type is an inductive family{indentExpr xType}\nand index{indentExpr index}\ndepends on the non index{indentExpr y}")
                (loop (i+1))
            | none =>
              match (← hasBadParamDep? ys indParams) with
              | some (indParam, y) =>
                orelse'
                  (throwError "argument #{i+1} was not used because its type is an inductive datatype{indentExpr xType}\nand parameter{indentExpr indParam}\ndepends on{indentExpr y}")
                  (loop (i+1))
              | none =>
                let indicesPos := indIndices.map fun index => match ys.indexOf? index with | some i => i.val | none => unreachable!
                orelse'
                  (mapError
                    (k { fixedParams := fixedParams
                         ys          := ys
                         pos         := i - fixedParams.size
                         indicesPos  := indicesPos
                         indName     := indInfo.name
                         indLevels   := us
                         indParams   := indParams
                         indIndices  := indIndices
                         reflexive := indInfo.isReflexive
                         indPred := ←isInductivePredicate indInfo.name })
                    (fun msg => m!"argument #{i+1} was not used for structural recursion{indentD msg}"))
                  (loop (i+1))
    else
      throwStructuralFailed
  loop numFixed

private def containsRecFn (recFnName : Name) (e : Expr) : Bool :=
  (e.find? fun e => e.isConstOf recFnName).isSome

private def ensureNoRecFn (recFnName : Name) (e : Expr) : MetaM Expr := do
  if containsRecFn recFnName e then
    Meta.forEachExpr e fun e => do
      if e.isAppOf recFnName then
        throwError "unexpected occurrence of recursive application{indentExpr e}"
    pure e
  else
    pure e

private def throwToBelowFailed {α} : MetaM α :=
  throwError "toBelow failed"

/- See toBelow -/
private partial def toBelowAux (C : Expr) : Expr → Expr → Expr → MetaM Expr
  | belowDict, arg, F => do
    let belowDict ← whnf belowDict
    trace[Elab.definition.structural] "belowDict: {belowDict}, arg: {arg}"
    match belowDict with
    | Expr.app (Expr.app (Expr.const `PProd _ _) d1 _) d2 _ =>
      (do toBelowAux C d1 arg (← mkAppM `PProd.fst #[F]))
      <|>
      (do toBelowAux C d2 arg (← mkAppM `PProd.snd #[F]))
    | Expr.app (Expr.app (Expr.const `And _ _) d1 _) d2 _ =>
      (do toBelowAux C d1 arg (← mkAppM `And.left #[F]))
      <|>
      (do toBelowAux C d2 arg (← mkAppM `And.right #[F]))
    | _ => forallTelescopeReducing belowDict fun xs belowDict => do
      let argArgs := arg.getAppArgs
      unless argArgs.size >= xs.size do throwToBelowFailed
      let n := argArgs.size
      let argTailArgs := argArgs.extract (n - xs.size) n
      let belowDict := belowDict.replaceFVars xs argTailArgs
      match belowDict with
      | Expr.app belowDictFun belowDictArg _ =>
        unless belowDictFun.getAppFn == C do throwToBelowFailed
        unless ← isDefEq belowDictArg arg do throwToBelowFailed
        pure (mkAppN F argTailArgs)
      | _ => throwToBelowFailed

/- See toBelow -/
private def withBelowDict {α} (below : Expr) (numIndParams : Nat) (k : Expr → Expr → MetaM α) : MetaM α := do
  let belowType ← inferType below
  trace[Elab.definition.structural] "belowType: {belowType}"
  belowType.withApp fun f args => do
    let motivePos := numIndParams + 1
    unless motivePos < args.size do throwError "unexpected 'below' type{indentExpr belowType}"
    let pre := mkAppN f (args.extract 0 numIndParams)
    let preType ← inferType pre
    forallBoundedTelescope preType (some 1) fun x _ => do
      let motiveType ← inferType x[0]
      let C ← mkFreshUserName `C
      withLocalDeclD C motiveType fun C =>
        let belowDict := mkApp pre C
        let belowDict := mkAppN belowDict (args.extract (numIndParams + 1) args.size)
        k C belowDict

/-
  `below` is a free variable with type of the form `I.below indParams motive indices major`,
  where `I` is the name of an inductive datatype.

  For example, when trying to show that the following function terminates using structural recursion
  ```lean
  def addAdjacent : List Nat → List Nat
  | []       => []
  | [a]      => [a]
  | a::b::as => (a+b) :: addAdjacent as
  ```
  when we are visiting `addAdjacent as` at `replaceRecApps`, `below` has type
  `@List.below Nat (fun (x : List Nat) => List Nat) (a::b::as)`
  The motive `fun (x : List Nat) => List Nat` depends on the actual function we are trying to compute.
  So, we first replace it with a fresh variable `C` at `withBelowDict`.
  Recall that `brecOn` implements course-of-values recursion, and `below` can be viewed as a dictionary
  of the "previous values".
  We search this dictionary using the auxiliary function `toBelowAux`.
  The dictionary is built using the `PProd` (`And` for inductive predicates).
  We keep searching it until we find `C recArg`, where `C` is the auxiliary fresh variable created at `withBelowDict`.  -/
private partial def toBelow (below : Expr) (numIndParams : Nat) (recArg : Expr) : MetaM Expr := do
  withBelowDict below numIndParams fun C belowDict =>
    toBelowAux C belowDict recArg below

/--
  Return true iff `e` contains an application `recFnName .. t ..` where the term `t` is
  the argument we are trying to recurse on, and it contains loose bound variables.

  We use this test to decide whether we should process a matcher-application as a regular
  applicaton or not. That is, whether we should push the `below` argument should be affected by the matcher or not.
  If `e` does not contain an application of the form `recFnName .. t ..`, then we know
  the recursion doesn't depend on any pattern variable in this matcher.
-/
private def recArgHasLooseBVarsAt (recFnName : Name) (recArgInfo : RecArgInfo) (e : Expr) : Bool :=
  let recArgPos := recArgInfo.fixedParams.size + recArgInfo.pos
  let app?   := e.find? fun e =>
     e.isAppOf recFnName && e.getAppNumArgs > recArgPos && (e.getArg! recArgPos).hasLooseBVars
  app?.isSome

private partial def replaceRecApps (recFnName : Name) (recArgInfo : RecArgInfo) (below : Expr) (e : Expr) : M Expr :=
  let rec loop (below : Expr) (e : Expr) : M Expr := do
    match e with
    | Expr.lam n d b c =>
      withLocalDecl n c.binderInfo (← loop below d) fun x => do
        mkLambdaFVars #[x] (← loop below (b.instantiate1 x))
    | Expr.forallE n d b c =>
      withLocalDecl n c.binderInfo (← loop below d) fun x => do
        mkForallFVars #[x] (← loop below (b.instantiate1 x))
    | Expr.letE n type val body _ =>
      withLetDecl n (← loop below type) (← loop below val) fun x => do
        mkLetFVars #[x] (← loop below (body.instantiate1 x))
    | Expr.mdata d e _   => return mkMData d (← loop below e)
    | Expr.proj n i e _  => return mkProj n i (← loop below e)
    | Expr.app _ _ _ =>
      let processApp (e : Expr) : M Expr :=
        e.withApp fun f args => do
          if f.isConstOf recFnName then
            let numFixed  := recArgInfo.fixedParams.size
            let recArgPos := recArgInfo.fixedParams.size + recArgInfo.pos
            if recArgPos >= args.size then
              throwError "insufficient number of parameters at recursive application {indentExpr e}"
            let recArg := args[recArgPos]
            -- For reflexive type, we may have nested recursive applications in recArg
            let recArg ← loop below recArg
            let f ← try toBelow below recArgInfo.indParams.size recArg catch  _ => throwError "failed to eliminate recursive application{indentExpr e}"
            -- Recall that the fixed parameters are not in the scope of the `brecOn`. So, we skip them.
            let argsNonFixed := args.extract numFixed args.size
            -- The function `f` does not explicitly take `recArg` and its indices as arguments. So, we skip them too.
            let mut fArgs := #[]
            for i in [:argsNonFixed.size] do
              if recArgInfo.pos != i && !recArgInfo.indicesPos.contains i then
                let arg := argsNonFixed[i]
                let arg ← replaceRecApps recFnName recArgInfo below arg
                fArgs := fArgs.push arg
            return mkAppN f fArgs
          else
            return mkAppN (← loop below f) (← args.mapM (loop below))
      let matcherApp? ← matchMatcherApp? e
      match matcherApp? with
      | some matcherApp =>
        if !recArgHasLooseBVarsAt recFnName recArgInfo e then
          processApp e
        else
          /- Here is an example we currently not handle
             ```
             def g (xs : List Nat) : Nat :=
             match xs with
             | [] => 0
             | y::ys =>
               match ys with
               | []       => 1
               | _::_::zs => g zs + 1
               | zs       => g ys + 2
             ```
             We are matching on `ys`, but still using `ys` in the third alternative.
             If we push the `below` argument over the dependent match it will be able to eliminate recursive call using `zs`.
             To make it work, users have to write the third alternative as `| zs => g zs + 2`
             If this is too annoying in practice, we may replace `ys` with the matching term, but
             this may generate weird error messages, when it doesn't work. -/
          trace[Elab.definition.structural] "below before matcherApp.addArg: {below} : {← inferType below}"
          let matcherApp ← mapError (matcherApp.addArg below) (fun msg => "failed to add `below` argument to 'matcher' application" ++ indentD msg)
          modify fun s => { s with matcherBelowDep := s.matcherBelowDep.insert matcherApp.matcherName }
          let altsNew ← (Array.zip matcherApp.alts matcherApp.altNumParams).mapM fun (alt, numParams) =>
            lambdaTelescope alt fun xs altBody => do
              trace[Elab.definition.structural] "altNumParams: {numParams}, xs: {xs}"
              unless xs.size >= numParams do
                throwError "unexpected matcher application alternative{indentExpr alt}\nat application{indentExpr e}"
              let belowForAlt := xs[numParams - 1]
              mkLambdaFVars xs (← loop belowForAlt altBody)
          pure { matcherApp with alts := altsNew }.toExpr
      | none => processApp e
    | e => ensureNoRecFn recFnName e
  loop below e

private partial def replaceIndPredRecApps (recFnName : Name) (recArgInfo : RecArgInfo) (motive : Expr) (e : Expr) : M Expr := do
  let maxDepth := IndPredBelow.maxBackwardChainingDepth.get $ ←getOptions
  let rec loop (e : Expr) : M Expr := do
    match e with
    | Expr.lam n d b c =>
      withLocalDecl n c.binderInfo (← loop d) fun x => do
        mkLambdaFVars #[x] (← loop (b.instantiate1 x))
    | Expr.forallE n d b c =>
      withLocalDecl n c.binderInfo (← loop d) fun x => do
        mkForallFVars #[x] (← loop (b.instantiate1 x))
    | Expr.letE n type val body _ =>
      withLetDecl n (← loop type) (← loop val) fun x => do
        mkLetFVars #[x] (← loop (body.instantiate1 x))
    | Expr.mdata d e _   => return mkMData d (← loop e)
    | Expr.proj n i e _  => return mkProj n i (← loop e)
    | Expr.app _ _ _ =>
      let processApp (e : Expr) : M Expr := do
        e.withApp fun f args => do
          if f.isConstOf recFnName then
            let ty ← inferType e
            let main ← mkFreshExprSyntheticOpaqueMVar ty
            if ←IndPredBelow.backwardsChaining main.mvarId! maxDepth then
              main
            else
              throwError "could not solve using backwards chaining {MessageData.ofGoal main.mvarId!}"
          else
            return mkAppN (← loop f) (← args.mapM loop)
      match (←matchMatcherApp? e) with
      | some matcherApp =>
        if !recArgHasLooseBVarsAt recFnName recArgInfo e then
          processApp e
        else
          trace[Elab.definition.structural] "matcherApp before adding below transformation:\n{matcherApp.toExpr}"
          let rec addBelow (matcherApp : MatcherApp) : M Expr := do
            if let some (t, idx) ← IndPredBelow.findBelowIdx matcherApp.discrs motive then
              let (newApp, addMatcher) ← IndPredBelow.mkBelowMatcher matcherApp motive t idx
              modify fun s => { s with addMatchers := s.addMatchers.push addMatcher }
              let some newApp ← matchMatcherApp? newApp | throwError "not a matcherApp: {newApp}"
              addBelow newApp
            else matcherApp.toExpr

          let newApp ← addBelow matcherApp
          if newApp == matcherApp.toExpr then
            throwError "could not add below discriminant"
          else
            trace[Elab.definition.structural] "modified matcher:\n{newApp}"
            processApp newApp
      | none => processApp e
    | e => ensureNoRecFn recFnName e
  loop e

private def mkBRecOn (recFnName : Name) (recArgInfo : RecArgInfo) (value : Expr) : M Expr := do
  let type  := (← inferType value).headBeta
  let major := recArgInfo.ys[recArgInfo.pos]
  let otherArgs := recArgInfo.ys.filter fun y => y != major && !recArgInfo.indIndices.contains y
  trace[Elab.definition.structural] "fixedParams: {recArgInfo.fixedParams}, otherArgs: {otherArgs}"
  let motive ← mkForallFVars otherArgs type
  let mut brecOnUniv ← getLevel motive
  trace[Elab.definition.structural] "brecOn univ: {brecOnUniv}"
  let useBInductionOn := recArgInfo.reflexive && brecOnUniv == levelZero
  if recArgInfo.reflexive && brecOnUniv != levelZero then
    brecOnUniv ← decLevel brecOnUniv
  let motive ← mkLambdaFVars (recArgInfo.indIndices.push major) motive
  trace[Elab.definition.structural] "brecOn motive: {motive}"
  let brecOn :=
    if useBInductionOn then
      Lean.mkConst (mkBInductionOnName recArgInfo.indName) recArgInfo.indLevels
    else
      Lean.mkConst (mkBRecOnName recArgInfo.indName) (brecOnUniv :: recArgInfo.indLevels)
  let brecOn := mkAppN brecOn recArgInfo.indParams
  let brecOn := mkApp brecOn motive
  let brecOn := mkAppN brecOn recArgInfo.indIndices
  let brecOn := mkApp brecOn major
  check brecOn
  let brecOnType ← inferType brecOn
  trace[Elab.definition.structural] "brecOn     {brecOn}"
  trace[Elab.definition.structural] "brecOnType {brecOnType}"
  forallBoundedTelescope brecOnType (some 1) fun F _ => do
    let F := F[0]
    let FType ← inferType F
    trace[Elab.definition.structural] "FType: {FType}"
    let FType ← instantiateForall FType recArgInfo.indIndices
    let FType ← instantiateForall FType #[major]
    forallBoundedTelescope FType (some 1) fun below _ => do
      let below := below[0]
      let valueNew     ← replaceRecApps recFnName recArgInfo below value
      let Farg         ← mkLambdaFVars (recArgInfo.indIndices ++ #[major, below] ++ otherArgs) valueNew
      let brecOn       := mkApp brecOn Farg
      pure $ mkAppN brecOn otherArgs

private def mkIndPredBRecOn (recFnName : Name) (recArgInfo : RecArgInfo) (value : Expr) : M Expr := do
  let type  := (← inferType value).headBeta
  let major := recArgInfo.ys[recArgInfo.pos]
  let otherArgs := recArgInfo.ys.filter fun y => y != major && !recArgInfo.indIndices.contains y
  trace[Elab.definition.structural] "fixedParams: {recArgInfo.fixedParams}, otherArgs: {otherArgs}"
  let motive ← mkForallFVars otherArgs type
  let motive ← mkLambdaFVars (recArgInfo.indIndices.push major) motive
  trace[Elab.definition.structural] "brecOn motive: {motive}"
  let brecOn :=
      Lean.mkConst (mkBRecOnName recArgInfo.indName) recArgInfo.indLevels
  let brecOn := mkAppN brecOn recArgInfo.indParams
  let brecOn := mkApp brecOn motive
  let brecOn := mkAppN brecOn recArgInfo.indIndices
  let brecOn := mkApp brecOn major
  check brecOn
  let brecOnType ← inferType brecOn
  trace[Elab.definition.structural] "brecOn     {brecOn}"
  trace[Elab.definition.structural] "brecOnType {brecOnType}"
  -- we need to close the telescope here, because the local context is used:
  -- The root cause was, that this copied code puts an ih : FType into the
  -- local context and later, when we use the local context to build the recursive
  -- call, it uses this ih. But that ih doesn't exist in the actual brecOn call.
  -- That's why it must go.
  let FType ← forallBoundedTelescope brecOnType (some 1) fun F _ => do
    let F := F[0]
    let FType ← inferType F
    trace[Elab.definition.structural] "FType: {FType}"
    let FType ← instantiateForall FType recArgInfo.indIndices
    instantiateForall FType #[major]
  forallBoundedTelescope FType (some 1) fun below _ => do
    let main ← mkFreshExprSyntheticOpaqueMVar FType
    let below := below[0]
    let valueNew     ← replaceIndPredRecApps recFnName recArgInfo motive value
    let Farg         ← mkLambdaFVars (recArgInfo.indIndices ++ #[major, below] ++ otherArgs) valueNew
    let brecOn       := mkApp brecOn Farg
    pure $ mkAppN brecOn otherArgs

private def shouldBetaReduce (e : Expr) (recFnName : Name) : Bool :=
  if e.isHeadBetaTarget then
    e.getAppFn.find? (·.isConstOf recFnName) |>.isSome
  else
    false

/--
  Beta reduce terms where the recursive function occurs in the lambda term.
  This is useful to improve the effectiveness of `elimRecursion`.
  Example:
  ```
  def f : Nat → Nat
    | 0 => 1
    | i+1 => (fun x => f x) i
  ```
-/
private def preprocess (e : Expr) (recFnName : Name) : CoreM Expr :=
  Core.transform e
   fun e => return TransformStep.visit <|
     if shouldBetaReduce e recFnName then
       e.headBeta
     else
       e

private def elimRecursion (preDef : PreDefinition) : M PreDefinition :=
  withoutModifyingEnv do lambdaTelescope preDef.value fun xs value => do
    addAsAxiom preDef
    let value ← preprocess value preDef.declName
    trace[Elab.definition.structural] "{preDef.declName} {xs} :=\n{value}"
    let numFixed ← getFixedPrefix preDef.declName xs value
    trace[Elab.definition.structural] "numFixed: {numFixed}"
    findRecArg numFixed xs fun recArgInfo => do
      -- when (recArgInfo.indName == `Nat) throwStructuralFailed -- HACK to skip Nat argument
      let valueNew ←
        if recArgInfo.indPred then mkIndPredBRecOn preDef.declName recArgInfo value
        else mkBRecOn preDef.declName recArgInfo value
      let valueNew ← mkLambdaFVars xs valueNew
      trace[Elab.definition.structural] "result: {valueNew}"
      -- Recursive applications may still occur in expressions that were not visited by replaceRecApps (e.g., in types)
      let valueNew ← ensureNoRecFn preDef.declName valueNew
      pure { preDef with value := valueNew }

partial def addSmartUnfoldingDefAux (preDef : PreDefinition) (matcherBelowDep : NameSet) : MetaM PreDefinition := do
  let recFnName := preDef.declName
  let isMarkedMatcherName (n : Name) : Bool    := matcherBelowDep.contains n
  let isMarkedMatcherConst (e : Expr) : Bool   := e.isConst && isMarkedMatcherName e.constName!
  let isMarkedMatcherApp (e : Expr) : Bool     := isMarkedMatcherConst e.getAppFn
  let containsMarkedMatcher (e : Expr) : Bool := e.find? isMarkedMatcherConst |>.isSome
  let rec visit (e : Expr) : MetaM Expr := do
    match e with
    | Expr.lam ..     => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← visit b)
    | Expr.forallE .. => forallTelescope e fun xs b => do mkForallFVars xs (← visit b)
    | Expr.letE n type val body _ =>
      withLetDecl n type (← visit val) fun x => do
        mkLetFVars #[x] (← visit (body.instantiate1 x))
    | Expr.mdata d b _   => return mkMData d (← visit b)
    | Expr.proj n i s _  => return mkProj n i (← visit s)
    | Expr.app .. =>
      let processApp (e : Expr) : MetaM Expr :=
        e.withApp fun f args => do
          return mkAppN (← visit f) (← args.mapM visit)
      match isMarkedMatcherApp e, (← matchMatcherApp? e) with
      | true, some matcherApp =>
        let altsNew ← (Array.zip matcherApp.alts matcherApp.altNumParams).mapM fun (alt, numParams) =>
          lambdaTelescope alt fun xs altBody => do
            unless xs.size >= numParams do
              throwError "unexpected matcher application alternative{indentExpr alt}\nat application{indentExpr e}"
            if containsMarkedMatcher altBody then
              -- continue
              mkLambdaFVars xs (← visit altBody)
            else
              -- add idRhs marker
              let altBody ← mkLambdaFVars xs[numParams:xs.size] altBody
              let altBody ← mkIdRhs altBody
              mkLambdaFVars xs[0:numParams] altBody
        pure { matcherApp with alts := altsNew }.toExpr
      | _, _ => processApp e
    | _ => pure e
  return { preDef with
    declName  := mkSmartUnfoldingNameFor preDef.declName,
    value     := (← visit preDef.value),
    modifiers := {}
  }

partial def addSmartUnfoldingDef (preDef : PreDefinition) (state : State) : TermElabM Unit := do
  if (← isProp preDef.type) then
    return ()
  else
    let preDefSUnfold ← addSmartUnfoldingDefAux preDef state.matcherBelowDep
    addNonRec preDefSUnfold

def structuralRecursion (preDefs : Array PreDefinition) : TermElabM Unit :=
  if preDefs.size != 1 then
    throwError "structural recursion does not handle mutually recursive functions"
  else do
    let (preDefNonRec, state) ← run $ elimRecursion preDefs[0]
    state.addMatchers.forM liftM
    mapError (addNonRec preDefNonRec) (fun msg => m!"structural recursion failed, produced type incorrect term{indentD msg}")
    addAndCompilePartialRec preDefs
    addSmartUnfoldingDef preDefs[0] state

builtin_initialize
  registerTraceClass `Elab.definition.structural

end Structural

export Structural (structuralRecursion)

end Lean.Elab


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import logic.eq

namespace unit
  notation `⋆` := star

  protected theorem eq (a b : unit) : a = b :=
  unit.rec_on a (unit.rec_on b rfl)

  theorem eq_star (a : unit) : a = star :=
  unit.eq a star

  protected theorem subsingleton [instance] : subsingleton unit :=
  subsingleton.intro (λ a b, unit.eq a b)

  protected definition is_inhabited [instance] : inhabited unit :=
  inhabited.mk unit.star

  protected definition has_decidable_eq [instance] : decidable_eq unit :=
  take (a b : unit), decidable.inl (unit.eq a b)
end unit


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

import control.uliftable
import data.bitvec.basic
import data.stream.defs
import tactic.norm_num

/-!
# Rand Monad and Random Class

This module provides tools for formulating computations guided by randomness and for
defining objects that can be created randomly.

## Main definitions
  * `rand` monad for computations guided by randomness;
  * `random` class for objects that can be generated randomly;
    * `random` to generate one object;
    * `random_r` to generate one object inside a range;
    * `random_series` to generate an infinite series of objects;
    * `random_series_r` to generate an infinite series of objects inside a range;
  * `io.mk_generator` to create a new random number generator;
  * `io.run_rand` to run a randomized computation inside the `io` monad;
  * `tactic.run_rand` to run a randomized computation inside the `tactic` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random monad io

## References

  * Similar library in Haskell: https://hackage.haskell.org/package/MonadRandom

-/

open list io applicative

universes u v w

/-- A monad to generate random objects using the generator type `g` -/
@[reducible]
def rand_g (g : Type) (α : Type u) : Type u := state (ulift.{u} g) α

/-- A monad to generate random objects using the generator type `std_gen` -/
@[reducible]
def rand := rand_g std_gen

instance (g : Type) : uliftable (rand_g.{u} g) (rand_g.{v} g) :=
@state_t.uliftable' _ _ _ _ _ (equiv.ulift.trans.{u u u u u} equiv.ulift.symm)

open ulift (hiding inhabited)

/-- Generate one more `ℕ` -/
def rand_g.next {g : Type} [random_gen g] : rand_g g ℕ :=
⟨ prod.map id up ∘ random_gen.next ∘ down ⟩

local infix ` .. `:41 := set.Icc

open stream

/-- `bounded_random α` gives us machinery to generate values of type `α` between certain bounds -/
class bounded_random (α : Type u) [preorder α] :=
(random_r : Π g [random_gen g] (x y : α),
              (x ≤ y) → rand_g g (x .. y))

/-- `random α` gives us machinery to generate values of type `α` -/
class random (α : Type u) :=
(random [] : Π (g : Type) [random_gen g], rand_g g α)

/-- shift_31_left = 2^31; multiplying by it shifts the binary
representation of a number left by 31 bits, dividing by it shifts it
right by 31 bits -/
def shift_31_left : ℕ :=
by apply_normed 2^31

namespace rand

open stream

variables (α : Type u)
variables (g : Type) [random_gen g]

/-- create a new random number generator distinct from the one stored in the state -/
def split : rand_g g g := ⟨ prod.map id up ∘ random_gen.split ∘ down ⟩

variables {g}

section random
variables [random α]

export random (random)

/-- Generate a random value of type `α`. -/
def random : rand_g g α :=
random.random α g

/-- generate an infinite series of random values of type `α` -/
def random_series : rand_g g (stream α) :=
do gen ← uliftable.up (split g),
   pure $ stream.corec_state (random.random α g) gen

end random

variables {α}

/-- Generate a random value between `x` and `y` inclusive. -/
def random_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) : rand_g g (x .. y) :=
bounded_random.random_r g x y h

/-- generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
def random_series_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) :
  rand_g g (stream (x .. y)) :=
do gen ← uliftable.up (split g),
   pure $ corec_state (bounded_random.random_r g x y h) gen

end rand

namespace io

private def accum_char (w : ℕ) (c : char) : ℕ :=
c.to_nat + 256 * w

/-- create and seed a random number generator -/
def mk_generator : io std_gen := do
seed ← io.rand 0 shift_31_left,
return $ mk_std_gen seed

variables {α : Type}

/-- Run `cmd` using a randomly seeded random number generator -/
def run_rand (cmd : _root_.rand α) : io α :=
do g ← io.mk_generator,
   return $ (cmd.run ⟨g⟩).1

/-- Run `cmd` using the provided seed. -/
def run_rand_with (seed : ℕ) (cmd : _root_.rand α) : io α :=
return $ (cmd.run ⟨mk_std_gen seed⟩).1

section random
variables [random α]

/-- randomly generate a value of type α -/
def random : io α :=
io.run_rand (rand.random α)

/-- randomly generate an infinite series of value of type α -/
def random_series : io (stream α) :=
io.run_rand (rand.random_series α)

end random

section bounded_random
variables [preorder α] [bounded_random α]

/-- randomly generate a value of type α between `x` and `y` -/
def random_r (x y : α) (p : x ≤ y) : io (x .. y) :=
io.run_rand (bounded_random.random_r _ x y p)

/-- randomly generate an infinite series of value of type α between `x` and `y` -/
def random_series_r (x y : α) (h : x ≤ y) : io (stream $ x .. y) :=
io.run_rand (rand.random_series_r x y h)

end bounded_random

end io

namespace tactic

/-- create a seeded random number generator in the `tactic` monad -/
meta def mk_generator : tactic std_gen := do
tactic.unsafe_run_io @io.mk_generator

/-- run `cmd` using the a randomly seeded random number generator
in the tactic monad -/
meta def run_rand {α : Type u} (cmd : rand α) : tactic α := do
⟨g⟩ ← tactic.up mk_generator,
return (cmd.run ⟨g⟩).1

variables {α : Type u}

section bounded_random
variables [preorder α] [bounded_random α]

/-- Generate a random value between `x` and `y` inclusive. -/
meta def random_r (x y : α) (h : x ≤ y) : tactic (x .. y) :=
run_rand (rand.random_r x y h)

/-- Generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
meta def random_series_r (x y : α) (h : x ≤ y) : tactic (stream $ x .. y) :=
run_rand (rand.random_series_r x y h)

end bounded_random

section random

variables [random α]

/-- randomly generate a value of type α -/
meta def random : tactic α :=
run_rand (rand.random α)

 /-- randomly generate an infinite series of value of type α -/
meta def random_series : tactic (stream α) :=
run_rand (rand.random_series α)

end random

end tactic

open nat (succ one_add mod_eq_of_lt zero_lt_succ add_one succ_le_succ)

variables {g : Type} [random_gen g]

open nat

namespace fin
variables {n : ℕ} [ne_zero n]

/-- generate a `fin` randomly -/
protected def random : rand_g g (fin n) :=
⟨ λ ⟨g⟩, prod.map of_nat' up $ rand_nat g 0 n ⟩

end fin

open nat

instance nat_bounded_random : bounded_random ℕ :=
{ random_r := λ g inst x y hxy,
  do z ← @fin.random g inst (succ $ y - x) _,
     pure ⟨z.val + x, nat.le_add_left _ _,
       by rw ← le_tsub_iff_right hxy; apply le_of_succ_le_succ z.is_lt⟩ }

/-- This `bounded_random` interval generates integers between `x` and
`y` by first generating a natural number between `0` and `y - x` and
shifting the result appropriately. -/
instance int_bounded_random : bounded_random ℤ :=
{ random_r := λ g inst x y hxy,
  do ⟨z,h₀,h₁⟩ ← @bounded_random.random_r ℕ _ _ g inst 0 (int.nat_abs $ y - x) dec_trivial,
     pure ⟨z + x,
       int.le_add_of_nonneg_left (int.coe_nat_nonneg _),
       int.add_le_of_le_sub_right $ le_trans
         (int.coe_nat_le_coe_nat_of_le h₁)
         (le_of_eq $ int.of_nat_nat_abs_eq_of_nonneg (int.sub_nonneg_of_le hxy)) ⟩ }

instance fin_random (n : ℕ) [ne_zero n] : random (fin n) :=
{ random := λ g inst, @fin.random g inst _ _ }

instance fin_bounded_random (n : ℕ) : bounded_random (fin n) :=
{ random_r := λ g inst (x y : fin n) p,
    do ⟨r, h, h'⟩ ← @rand.random_r ℕ g inst _ _ x.val y.val p,
       pure ⟨⟨r,lt_of_le_of_lt h' y.is_lt⟩, h, h'⟩ }

/-- A shortcut for creating a `random (fin n)` instance from
a proof that `0 < n` rather than on matching on `fin (succ n)`  -/
def random_fin_of_pos : ∀ {n : ℕ} (h : 0 < n), random (fin n)
| (succ n) _ := fin_random _
| 0 h := false.elim (nat.not_lt_zero _ h)

lemma bool_of_nat_mem_Icc_of_mem_Icc_to_nat (x y : bool) (n : ℕ) :
  n ∈ (x.to_nat .. y.to_nat) → bool.of_nat n ∈ (x .. y) :=
begin
  simp only [and_imp, set.mem_Icc], intros h₀ h₁,
  split;
    [ have h₂ := bool.of_nat_le_of_nat h₀, have h₂ := bool.of_nat_le_of_nat h₁ ];
    rw bool.of_nat_to_nat at h₂; exact h₂,
end

instance : random bool :=
{ random   := λ g inst,
  (bool.of_nat ∘ subtype.val) <$> @bounded_random.random_r ℕ _ _ g inst 0 1 (nat.zero_le _) }

instance : bounded_random bool :=
{ random_r := λ g _inst x y p,
  subtype.map bool.of_nat (bool_of_nat_mem_Icc_of_mem_Icc_to_nat x y) <$>
    @bounded_random.random_r ℕ _ _ g _inst x.to_nat y.to_nat (bool.to_nat_le_to_nat p) }

/-- generate a random bit vector of length `n` -/
def bitvec.random (n : ℕ) : rand_g g (bitvec n) :=
bitvec.of_fin <$> rand.random (fin $ 2^n)

/-- generate a random bit vector of length `n` -/
def bitvec.random_r {n : ℕ} (x y : bitvec n) (h : x ≤ y) : rand_g g (x .. y) :=
have h' : ∀ (a : fin (2 ^ n)), a ∈ (x.to_fin .. y.to_fin) → bitvec.of_fin a ∈ (x .. y),
begin
  simp only [and_imp, set.mem_Icc], intros z h₀ h₁,
  replace h₀ := bitvec.of_fin_le_of_fin_of_le h₀,
  replace h₁ := bitvec.of_fin_le_of_fin_of_le h₁,
  rw bitvec.of_fin_to_fin at h₀ h₁, split; assumption,
end,
subtype.map bitvec.of_fin h' <$> rand.random_r x.to_fin y.to_fin (bitvec.to_fin_le_to_fin_of_le h)

open nat

instance random_bitvec (n : ℕ) : random (bitvec n) :=
{ random := λ _ inst, @bitvec.random _ inst n }

instance bounded_random_bitvec (n : ℕ) : bounded_random (bitvec n) :=
{ random_r := λ _ inst x y p, @bitvec.random_r _ inst _ _ _ p }


import category_theory.comma
import category_theory.adjunction.basic
import category_theory.limits.shapes
import category_theory.epi_mono
import category_theory.limits.over
import category_theory.closed.cartesian
import category.binary_products
import category.adjunction

/-!
# Properties of the over category.

We can interpret the forgetful functor `forget : over B ⥤ C` as dependent sum,
(written `Σ_B`)
and when C has binary products, it has a right adjoint `B*` given by
`A ↦ (π₁ : B × A → B)`, denoted `star` in Lean.

Furthermore, if the original category C has pullbacks and terminal object (i.e.
all finite limits), `B*` has a right adjoint iff `B` is exponentiable in `C`.
This right adjoint is written `Π_B` and is interpreted as dependent product.

Given `f : A ⟶ B` in `C/B`, the iterated slice `(C/B)/f` is isomorphic to
`C/A`.
-/
noncomputable theory
namespace category_theory
open category limits

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

-- def has_finite_products_of_has_finite_limits [has_finite_limits.{v} C] : has_finite_products.{v} C :=
-- λ _ _ _, by resetI; apply_instance
def has_finite_coproducts_of_has_finite_colimits [has_finite_colimits.{v} C] : has_finite_coproducts.{v} C :=
λ _ _ _, by resetI; apply_instance

@[simps]
def over_iso {B : C} {f g : over B} (hl : f.left ≅ g.left) (hw : hl.hom ≫ g.hom = f.hom) : f ≅ g :=
{ hom := over.hom_mk hl.hom, inv := over.hom_mk hl.inv (by simp [iso.inv_comp_eq, hw]) }

section adjunction

variable (B : C)

section

variable [has_pullbacks.{v} C]

@[simps]
def real_pullback {A B : C} (f : A ⟶ B) : over B ⥤ over A :=
{ obj := λ g, over.mk (pullback.snd : pullback g.hom f ⟶ A),
  map := λ g h k, over.hom_mk (pullback.lift (pullback.fst ≫ k.left) pullback.snd (by simp [pullback.condition])) (by tidy) }

end

section
variable [has_binary_products.{v} C]

@[simps]
def star : C ⥤ over B :=
{ obj := λ A, over.mk (limits.prod.fst : B ⨯ A ⟶ B),
  map := λ X Y f, over.hom_mk (limits.prod.map (𝟙 _) f),
  map_id' := λ X,
  begin
    apply over.over_morphism.ext,
    dsimp,
    simp,
  end,
  map_comp' := λ X Y Z f g,
  begin
    apply over.over_morphism.ext,
    dsimp,
    ext,
    { rw [limits.prod.map_fst, comp_id, assoc, limits.prod.map_fst, comp_id, limits.prod.map_fst,
          comp_id] },
    { rw [limits.prod.map_snd, assoc, limits.prod.map_snd, limits.prod.map_snd_assoc] }
  end }

local attribute [tidy] tactic.case_bash

def forget_adj_star : over.forget B ⊣ star B :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g A,
  { to_fun := λ f, over.hom_mk (prod.lift g.hom f),
    inv_fun := λ k, k.left ≫ limits.prod.snd,
    left_inv := λ f, prod.lift_snd _ _,
    right_inv := λ k,
    begin
      ext;
      dsimp,
      rw prod.lift_fst,
      rw ← over.w k,
      refl,
      rw prod.lift_snd,
    end },
  hom_equiv_naturality_right' := λ X Y Y' f g,
  begin
    dsimp,
    ext1,
    dsimp,
    rw prod.lift_map,
    rw comp_id,
  end,
  hom_equiv_naturality_left_symm' := λ X' X Y f g, begin dsimp, rw assoc end }
end

def exponentiable_of_star_is_left_adj [has_finite_products C] (h : is_left_adjoint (star B)) :
  exponentiable B :=
{ is_adj :=
  { right := star B ⋙ h.right,
    adj := adjunction.comp _ _ h.adj (forget_adj_star B) } }

def dependent_sum {A B : C} (f : A ⟶ B) : over A ⥤ over B :=
(over.iterated_slice_equiv (over.mk f)).inverse ⋙ over.forget _

/--
`over.map f` gives nice definitional equalities but `dependent_sum` makes it easy to prove
adjunction properties
-/
def over_map_iso_dependent_sum {A B : C} (f : A ⟶ B) : dependent_sum f ≅ over.map f :=
begin
  refine nat_iso.of_components (λ X, over_iso (iso.refl _) (id_comp _)) (λ X Y g, _),
  { ext1,
    change g.left ≫ 𝟙 _ = 𝟙 _ ≫ g.left,
    rw [comp_id, id_comp] }
end

def over_map_id {A : C} : over.map (𝟙 A) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, over_iso (iso.refl _) (begin dsimp, simp end)) (λ X Y f, begin ext, dsimp, simp end)

def over_map_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : over.map (f ≫ g) ≅ over.map f ⋙ over.map g :=
nat_iso.of_components (λ X, over_iso (iso.refl _) (begin dsimp, simp end)) (λ X Y f, begin ext, dsimp, simp end)

-- local attribute [instance] has_finite_wide_pullbacks_of_has_finite_limits

def pullback_along {A B : C} (f : A ⟶ B) [has_binary_products (over B)] : over B ⥤ over A :=
star (over.mk f) ⋙ (over.iterated_slice_equiv _).functor

lemma jointly_mono {A B : C} [has_binary_products (over B)] {f g : over B} (t₁ t₂ : A ⟶ (g ⨯ f).left) :
  t₁ ≫ (limits.prod.fst : g ⨯ f ⟶ _).left = t₂ ≫ (limits.prod.fst : g ⨯ f ⟶ _).left →
  t₁ ≫ (limits.prod.snd : g ⨯ f ⟶ _).left = t₂ ≫ (limits.prod.snd : g ⨯ f ⟶ _).left →
  t₁ = t₂ :=
begin
  intros h₁ h₂,
  let A' : over B := over.mk (t₂ ≫ (g ⨯ f).hom), -- usually easier in practice to use the second one
  have : t₁ ≫ (g ⨯ f).hom = t₂ ≫ (g ⨯ f).hom,
    rw [← over.w (limits.prod.fst : g ⨯ f ⟶ _), reassoc_of h₁],
  let t₁' : A' ⟶ g ⨯ f := over.hom_mk t₁ this,
  let t₂' : A' ⟶ g ⨯ f := over.hom_mk t₂,
  suffices : t₁' = t₂',
    apply congr_arg comma_morphism.left this,
  apply prod.hom_ext;
  { ext1, assumption }
end

def iso_pb {A B : C} (f : A ⟶ B) [has_binary_products (over B)] [has_pullbacks C] :
  pullback_along f ≅ real_pullback f :=
begin
  refine nat_iso.of_components _ _,
  { intro X,
    let p : over B := over.mk (pullback.snd ≫ f : pullback X.hom f ⟶ B),
    let q : p ⟶ over.mk f ⨯ X := prod.lift (over.hom_mk pullback.snd rfl) (over.hom_mk pullback.fst pullback.condition),
    apply over_iso _ _,
    refine ⟨pullback.lift _ _ _, q.left, _, _⟩,
    { apply (limits.prod.snd : over.mk f ⨯ X ⟶ _).left },
    { apply (limits.prod.fst : over.mk f ⨯ X ⟶ _).left },
    { rw [over.w limits.prod.snd, ← over.w limits.prod.fst, over.mk_hom] },
    { apply jointly_mono;
      simp [← over.comp_left] },
    { apply pullback.hom_ext;
      simp [← over.comp_left] },
    { apply pullback.lift_snd } },
  { intros X Y g,
    ext1,
    dsimp [pullback_along],
    apply pullback.hom_ext,
    { simp only [assoc, pullback.lift_fst, ← over.comp_left, limits.prod.map_snd, pullback.lift_fst_assoc] },
    { simp only [assoc, pullback.lift_snd, ← over.comp_left, limits.prod.map_fst, comp_id] } },
end

section
-- local attribute [instance] over.construct_products.over_binary_product_of_pullback
def radj {A B : C} (f : A ⟶ B) [has_pullbacks C] :
  over.map f ⊣ real_pullback f :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g h,
  { to_fun := λ X, over.hom_mk (pullback.lift X.left g.hom (over.w X)) (pullback.lift_snd _ _ _),
    inv_fun := λ Y,
    begin
      refine over.hom_mk _ _,
      refine Y.left ≫ pullback.fst,
      dsimp,
      rw [← over.w Y, assoc, pullback.condition, assoc], refl,
    end,
    left_inv := by tidy,
    right_inv := λ Y, by { ext, dsimp, simp, dsimp, rw [pullback.lift_snd, ← over.w Y], refl } } }
-- (((over.mk f).iterated_slice_equiv.symm.to_adjunction.comp _ _ (forget_adj_star _)).of_nat_iso_left (over_map_iso_dependent_sum f)).of_nat_iso_right (iso_pb f)

def pullback_id {A : C} [has_pullbacks C] : real_pullback (𝟙 A) ≅ 𝟭 _ :=
adjunction.right_adjoint_uniq (radj _) (adjunction.id.of_nat_iso_left over_map_id.symm)

def pullback_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [has_pullbacks C] :
  real_pullback (f ≫ g) ≅ real_pullback g ⋙ real_pullback f :=
adjunction.right_adjoint_uniq (radj _) (((radj _).comp _ _ (radj _)).of_nat_iso_left (over_map_comp _ _).symm)

instance thing {A B : C} (f : A ⟶ B) [has_pullbacks C] : is_right_adjoint (real_pullback f) :=
⟨_, radj f⟩
end

variables [has_finite_products.{v} C] [has_pullbacks.{v} C]

def Pi_obj [exponentiable B] (f : over B) : C := pullback ((exp B).map f.hom) (internalize_hom (𝟙 B))

@[simps]
private def pi_obj.equiv [exponentiable B] (X : C) (Y : over B) :
  ((star B).obj X ⟶ Y) ≃ (X ⟶ Pi_obj B Y) :=
{ to_fun := λ f, pullback.lift (cartesian_closed.curry f.left) (terminal.from _)
    (by { rw [internalize_hom, comp_id, ← curry_natural_left, ← curry_natural_right,
              limits.prod.map_fst, comp_id, over.w f], refl }),
  inv_fun := λ g,
    begin
      apply over.hom_mk _ _,
      { apply (cartesian_closed.uncurry (g ≫ pullback.fst)) },
      { rw [← uncurry_natural_right, assoc, pullback.condition, ← assoc, uncurry_natural_left],
        dsimp [internalize_hom],
        rw [uncurry_curry, limits.prod.map_fst_assoc, comp_id, comp_id] }
    end,
  left_inv := λ f, by { ext1, simp },
  right_inv := λ g,
  by { ext1, { simp }, { apply subsingleton.elim } } }

private lemma pi_obj.natural_equiv [exponentiable B] (X' X : C) (Y : over B) (f : X' ⟶ X) (g : (star B).obj X ⟶ Y) :
  (pi_obj.equiv B X' Y).to_fun ((star B).map f ≫ g) = f ≫ (pi_obj.equiv B X Y).to_fun g :=
begin
  apply pullback.hom_ext,
  { simp [curry_natural_left] },
  { apply subsingleton.elim }
end

def Pi_functor [exponentiable B] : over B ⥤ C :=
  adjunction.right_adjoint_of_equiv (pi_obj.equiv B) (pi_obj.natural_equiv B)
def star_adj_pi_of_exponentiable [exponentiable B] : star B ⊣ Pi_functor B :=
  adjunction.adjunction_of_equiv_right _ _
instance star_is_left_adj_of_exponentiable [exponentiable B] : is_left_adjoint (star B) :=
  ⟨Pi_functor B, star_adj_pi_of_exponentiable B⟩

end adjunction

end category_theory


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.relator
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u

namespace Mathlib

/-!
# Quotient types

This module extends the core library's treatment of quotient types (`init.data.quot`).

## Tags

quotient
-/

namespace setoid

theorem ext {α : Sort u_1} {s : setoid α} {t : setoid α} : (∀ (a b : α), r a b ↔ r a b) → s = t :=
  sorry

end setoid

namespace quot

protected instance inhabited {α : Sort u_1} {ra : α → α → Prop} [Inhabited α] :
    Inhabited (Quot ra) :=
  { default := Quot.mk ra Inhabited.default }

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ {α : Sort u_1} {β : Sort u_2} {ra : α → α → Prop} {rb : β → β → Prop}
    {φ : Quot ra → Quot rb → Sort u_3} (qa : Quot ra) (qb : Quot rb)
    (f : (a : α) → (b : β) → φ (Quot.mk ra a) (Quot.mk rb b))
    (ca : ∀ {b : β} {a₁ a₂ : α}, ra a₁ a₂ → f a₁ b == f a₂ b)
    (cb : ∀ {a : α} {b₁ b₂ : β}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
  quot.hrec_on qa (fun (a : α) => quot.hrec_on qb (f a) sorry) sorry

/-- Map a function `f : α → β` such that `ra x y` implies `rb (f x) (f y)`
to a map `quot ra → quot rb`. -/
protected def map {α : Sort u_1} {β : Sort u_2} {ra : α → α → Prop} {rb : β → β → Prop} (f : α → β)
    (h : relator.lift_fun ra rb f f) : Quot ra → Quot rb :=
  Quot.lift (fun (x : α) => Quot.mk rb (f x)) sorry

/-- If `ra` is a subrelation of `ra'`, then we have a natural map `quot ra → quot ra'`. -/
protected def map_right {α : Sort u_1} {ra : α → α → Prop} {ra' : α → α → Prop}
    (h : ∀ (a₁ a₂ : α), ra a₁ a₂ → ra' a₁ a₂) : Quot ra → Quot ra' :=
  quot.map id h

/-- weaken the relation of a quotient -/
def factor {α : Type u_1} (r : α → α → Prop) (s : α → α → Prop) (h : ∀ (x y : α), r x y → s x y) :
    Quot r → Quot s :=
  Quot.lift (Quot.mk s) sorry

theorem factor_mk_eq {α : Type u_1} (r : α → α → Prop) (s : α → α → Prop)
    (h : ∀ (x y : α), r x y → s x y) : factor r s h ∘ Quot.mk r = Quot.mk s :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β`. -/
protected def lift₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂)
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) (q₁ : Quot r) (q₂ : Quot s) : γ :=
  Quot.lift (fun (a : α) => Quot.lift (f a) (hr a)) sorry q₁ q₂

@[simp] theorem lift₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} (a : α) (b : β) (f : α → β → γ)
    (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂)
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) :
    quot.lift₂ f hr hs (Quot.mk r a) (Quot.mk s b) = f a b :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` and applies it. -/
protected def lift_on₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} (p : Quot r) (q : Quot s) (f : α → β → γ)
    (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂)
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) : γ :=
  quot.lift₂ f hr hs p q

@[simp] theorem lift_on₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} (a : α) (b : β) (f : α → β → γ)
    (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂)
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) :
    quot.lift_on₂ (Quot.mk r a) (Quot.mk s b) f hr hs = f a b :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` wih values in a quotient of
`γ`. -/
protected def map₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} {t : γ → γ → Prop} (f : α → β → γ)
    (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → t (f a b₁) (f a b₂))
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → t (f a₁ b) (f a₂ b)) (q₁ : Quot r) (q₂ : Quot s) :
    Quot t :=
  quot.lift₂ (fun (a : α) (b : β) => Quot.mk t (f a b)) sorry sorry q₁ q₂

@[simp] theorem map₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} {t : γ → γ → Prop} (f : α → β → γ)
    (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → t (f a b₁) (f a b₂))
    (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → t (f a₁ b) (f a₂ b)) (a : α) (b : β) :
    quot.map₂ f hr hs (Quot.mk r a) (Quot.mk s b) = Quot.mk t (f a b) :=
  rfl

protected theorem induction_on₂ {α : Sort u_1} {β : Sort u_2} {r : α → α → Prop} {s : β → β → Prop}
    {δ : Quot r → Quot s → Prop} (q₁ : Quot r) (q₂ : Quot s)
    (h : ∀ (a : α) (b : β), δ (Quot.mk r a) (Quot.mk s b)) : δ q₁ q₂ :=
  Quot.ind (fun (a₁ : α) => Quot.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop}
    {s : β → β → Prop} {t : γ → γ → Prop} {δ : Quot r → Quot s → Quot t → Prop} (q₁ : Quot r)
    (q₂ : Quot s) (q₃ : Quot t)
    (h : ∀ (a : α) (b : β) (c : γ), δ (Quot.mk r a) (Quot.mk s b) (Quot.mk t c)) : δ q₁ q₂ q₃ :=
  Quot.ind (fun (a₁ : α) => Quot.ind (fun (a₂ : β) => Quot.ind (fun (a₃ : γ) => h a₁ a₂ a₃) q₃) q₂)
    q₁

end quot

namespace quotient

protected instance inhabited {α : Sort u_1} [sa : setoid α] [Inhabited α] :
    Inhabited (quotient sa) :=
  { default := quotient.mk Inhabited.default }

/-- Induction on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β]
    {φ : quotient sa → quotient sb → Sort u_3} (qa : quotient sa) (qb : quotient sb)
    (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b))
    (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
  quot.hrec_on₂ qa qb f sorry sorry

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] (f : α → β)
    (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) : quotient sa → quotient sb :=
  quot.map f h

@[simp] theorem map_mk {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] (f : α → β)
    (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) (x : α) :
    quotient.map f h (quotient.mk x) = quotient.mk (f x) :=
  rfl

/-- Map a function `f : α → β → γ` that sends equivalent elements to equivalent elements
to a function `f : quotient sa → quotient sb → quotient sc`.
Useful to define binary operations on quotients. -/
protected def map₂ {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] {γ : Sort u_4}
    [sc : setoid γ] (f : α → β → γ)
    (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) :
    quotient sa → quotient sb → quotient sc :=
  quotient.lift₂ (fun (x : α) (y : β) => quotient.mk (f x y)) sorry

end quotient

theorem quot.eq {α : Type u_1} {r : α → α → Prop} {x : α} {y : α} :
    Quot.mk r x = Quot.mk r y ↔ eqv_gen r x y :=
  { mp := quot.exact r, mpr := quot.eqv_gen_sound }

@[simp] theorem quotient.eq {α : Sort u_1} [r : setoid α] {x : α} {y : α} :
    quotient.mk x = quotient.mk y ↔ x ≈ y :=
  { mp := quotient.exact, mpr := quotient.sound }

theorem forall_quotient_iff {α : Type u_1} [r : setoid α] {p : quotient r → Prop} :
    (∀ (a : quotient r), p a) ↔ ∀ (a : α), p (quotient.mk a) :=
  { mp := fun (h : ∀ (a : quotient r), p a) (x : α) => h (quotient.mk x),
    mpr := fun (h : ∀ (a : α), p (quotient.mk a)) (a : quotient r) => quotient.induction_on a h }

@[simp] theorem quotient.lift_beta {α : Sort u_1} {β : Sort u_2} [s : setoid α] (f : α → β)
    (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α) : quotient.lift f h (quotient.mk x) = f x :=
  rfl

@[simp] theorem quotient.lift_on_beta {α : Sort u_1} {β : Sort u_2} [s : setoid α] (f : α → β)
    (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α) : quotient.lift_on (quotient.mk x) f h = f x :=
  rfl

@[simp] theorem quotient.lift_on_beta₂ {α : Sort u_1} {β : Sort u_2} [setoid α] (f : α → α → β)
    (h : ∀ (a₁ a₂ b₁ b₂ : α), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (x : α) (y : α) :
    quotient.lift_on₂ (quotient.mk x) (quotient.mk y) f h = f x y :=
  rfl

/-- `quot.mk r` is a surjective function. -/
theorem surjective_quot_mk {α : Sort u_1} (r : α → α → Prop) : function.surjective (Quot.mk r) :=
  quot.exists_rep

/-- `quotient.mk` is a surjective function. -/
theorem surjective_quotient_mk (α : Sort u_1) [s : setoid α] : function.surjective quotient.mk :=
  quot.exists_rep

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
def quot.out {α : Sort u_1} {r : α → α → Prop} (q : Quot r) : α :=
  classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
@[simp] theorem quot.out_eq {α : Sort u_1} {r : α → α → Prop} (q : Quot r) :
    Quot.mk r (quot.out q) = q :=
  classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
def quotient.out {α : Sort u_1} [s : setoid α] : quotient s → α := quot.out

@[simp] theorem quotient.out_eq {α : Sort u_1} [s : setoid α] (q : quotient s) :
    quotient.mk (quotient.out q) = q :=
  quot.out_eq q

theorem quotient.mk_out {α : Sort u_1} [s : setoid α] (a : α) : quotient.out (quotient.mk a) ≈ a :=
  quotient.exact (quotient.out_eq (quotient.mk a))

protected instance pi_setoid {ι : Sort u_1} {α : ι → Sort u_2} [(i : ι) → setoid (α i)] :
    setoid ((i : ι) → α i) :=
  setoid.mk (fun (a b : (i : ι) → α i) => ∀ (i : ι), a i ≈ b i) sorry

/-- Given a function `f : Π i, quotient (S i)`, returns the class of functions `Π i, α i` sending
each `i` to an element of the class `f i`. -/
def quotient.choice {ι : Type u_1} {α : ι → Type u_2} [S : (i : ι) → setoid (α i)]
    (f : (i : ι) → quotient (S i)) : quotient Mathlib.pi_setoid :=
  quotient.mk fun (i : ι) => quotient.out (f i)

theorem quotient.choice_eq {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → setoid (α i)]
    (f : (i : ι) → α i) : (quotient.choice fun (i : ι) => quotient.mk (f i)) = quotient.mk f :=
  quotient.sound fun (i : ι) => quotient.mk_out (f i)

theorem nonempty_quotient_iff {α : Sort u_1} (s : setoid α) : Nonempty (quotient s) ↔ Nonempty α :=
  sorry

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def trunc (α : Sort u) := Quot fun (_x _x : α) => True

theorem true_equivalence {α : Sort u_1} : equivalence fun (_x _x : α) => True :=
  { left := fun (_x : α) => trivial,
    right :=
      { left := fun (_x _x : α) (_x : True) => trivial,
        right := fun (_x _x _x : α) (_x _x : True) => trivial } }

namespace trunc

/-- Constructor for `trunc α` -/
def mk {α : Sort u_1} (a : α) : trunc α := Quot.mk (fun (_x _x : α) => True) a

protected instance inhabited {α : Sort u_1} [Inhabited α] : Inhabited (trunc α) :=
  { default := mk Inhabited.default }

/-- Any constant function lifts to a function out of the truncation -/
def lift {α : Sort u_1} {β : Sort u_2} (f : α → β) (c : ∀ (a b : α), f a = f b) : trunc α → β :=
  Quot.lift f sorry

theorem ind {α : Sort u_1} {β : trunc α → Prop} : (∀ (a : α), β (mk a)) → ∀ (q : trunc α), β q :=
  Quot.ind

protected theorem lift_beta {α : Sort u_1} {β : Sort u_2} (f : α → β) (c : ∀ (a b : α), f a = f b)
    (a : α) : lift f c (mk a) = f a :=
  rfl

/-- Lift a constant function on `q : trunc α`. -/
protected def lift_on {α : Sort u_1} {β : Sort u_2} (q : trunc α) (f : α → β)
    (c : ∀ (a b : α), f a = f b) : β :=
  lift f c q

protected theorem induction_on {α : Sort u_1} {β : trunc α → Prop} (q : trunc α)
    (h : ∀ (a : α), β (mk a)) : β q :=
  ind h q

theorem exists_rep {α : Sort u_1} (q : trunc α) : ∃ (a : α), mk a = q := quot.exists_rep q

protected theorem induction_on₂ {α : Sort u_1} {β : Sort u_2} {C : trunc α → trunc β → Prop}
    (q₁ : trunc α) (q₂ : trunc β) (h : ∀ (a : α) (b : β), C (mk a) (mk b)) : C q₁ q₂ :=
  trunc.induction_on q₁ fun (a₁ : α) => trunc.induction_on q₂ (h a₁)

protected theorem eq {α : Sort u_1} (a : trunc α) (b : trunc α) : a = b :=
  trunc.induction_on₂ a b fun (x y : α) => quot.sound trivial

protected instance subsingleton {α : Sort u_1} : subsingleton (trunc α) :=
  subsingleton.intro trunc.eq

/-- The `bind` operator for the `trunc` monad. -/
def bind {α : Sort u_1} {β : Sort u_2} (q : trunc α) (f : α → trunc β) : trunc β :=
  trunc.lift_on q f sorry

/-- A function `f : α → β` defines a function `map f : trunc α → trunc β`. -/
def map {α : Sort u_1} {β : Sort u_2} (f : α → β) (q : trunc α) : trunc β := bind q (mk ∘ f)

protected instance monad : Monad trunc := sorry

protected instance is_lawful_monad : is_lawful_monad trunc :=
  is_lawful_monad.mk (fun (α β : Type u_1) (q : α) (f : α → trunc β) => rfl)
    fun (α β γ : Type u_1) (x : trunc α) (f : α → trunc β) (g : β → trunc γ) =>
      trunc.eq (x >>= f >>= g) (x >>= fun (x : α) => f x >>= g)

/-- Recursion/induction principle for `trunc`. -/
protected def rec {α : Sort u_1} {C : trunc α → Sort u_3} (f : (a : α) → C (mk a))
    (h : ∀ (a b : α), Eq._oldrec (f a) (rec._proof_1 a b) = f b) (q : trunc α) : C q :=
  quot.rec f sorry q

/-- A version of `trunc.rec` taking `q : trunc α` as the first argument. -/
protected def rec_on {α : Sort u_1} {C : trunc α → Sort u_3} (q : trunc α) (f : (a : α) → C (mk a))
    (h : ∀ (a b : α), Eq._oldrec (f a) (rec_on._proof_1 a b) = f b) : C q :=
  trunc.rec f h q

/-- A version of `trunc.rec_on` assuming the codomain is a `subsingleton`. -/
protected def rec_on_subsingleton {α : Sort u_1} {C : trunc α → Sort u_3}
    [∀ (a : α), subsingleton (C (mk a))] (q : trunc α) (f : (a : α) → C (mk a)) : C q :=
  trunc.rec f sorry q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
def out {α : Sort u_1} : trunc α → α := quot.out

@[simp] theorem out_eq {α : Sort u_1} (q : trunc α) : mk (out q) = q := trunc.eq (mk (out q)) q

end trunc

theorem nonempty_of_trunc {α : Sort u_1} (q : trunc α) : Nonempty α :=
  (fun (_a : ∃ (a : α), trunc.mk a = q) =>
      Exists.dcases_on _a fun (w : α) (h : trunc.mk w = q) => idRhs (Nonempty α) (Nonempty.intro w))
    (trunc.exists_rep q)

namespace quotient

/- Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules -/

/-- A version of `quotient.mk` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def mk' {α : Sort u_1} {s₁ : setoid α} (a : α) : quotient s₁ := Quot.mk setoid.r a

/-- `quotient.mk'` is a surjective function. -/
theorem surjective_quotient_mk' {α : Sort u_1} {s₁ : setoid α} : function.surjective quotient.mk' :=
  quot.exists_rep

/-- A version of `quotient.lift_on` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def lift_on' {α : Sort u_1} {φ : Sort u_4} {s₁ : setoid α} (q : quotient s₁) (f : α → φ)
    (h : ∀ (a b : α), setoid.r a b → f a = f b) : φ :=
  quotient.lift_on q f h

@[simp] protected theorem lift_on'_beta {α : Sort u_1} {φ : Sort u_4} {s₁ : setoid α} (f : α → φ)
    (h : ∀ (a b : α), setoid.r a b → f a = f b) (x : α) :
    quotient.lift_on' (quotient.mk' x) f h = f x :=
  rfl

/-- A version of `quotient.lift_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
protected def lift_on₂' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β}
    (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ)
    (h :
      ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), setoid.r a₁ b₁ → setoid.r a₂ b₂ → f a₁ a₂ = f b₁ b₂) :
    γ :=
  quotient.lift_on₂ q₁ q₂ f h

@[simp] protected theorem lift_on₂'_beta {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3}
    {s₁ : setoid α} {s₂ : setoid β} (f : α → β → γ)
    (h : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), setoid.r a₁ b₁ → setoid.r a₂ b₂ → f a₁ a₂ = f b₁ b₂)
    (a : α) (b : β) : quotient.lift_on₂' (quotient.mk' a) (quotient.mk' b) f h = f a b :=
  rfl

/-- A version of `quotient.ind` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected theorem ind' {α : Sort u_1} {s₁ : setoid α} {p : quotient s₁ → Prop}
    (h : ∀ (a : α), p (quotient.mk' a)) (q : quotient s₁) : p q :=
  quotient.ind h q

/-- A version of `quotient.ind₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
protected theorem ind₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β}
    {p : quotient s₁ → quotient s₂ → Prop}
    (h : ∀ (a₁ : α) (a₂ : β), p (quotient.mk' a₁) (quotient.mk' a₂)) (q₁ : quotient s₁)
    (q₂ : quotient s₂) : p q₁ q₂ :=
  quotient.ind₂ h q₁ q₂

/-- A version of `quotient.induction_on` taking `{s : setoid α}` as an implicit argument instead
of an instance argument. -/
protected theorem induction_on' {α : Sort u_1} {s₁ : setoid α} {p : quotient s₁ → Prop}
    (q : quotient s₁) (h : ∀ (a : α), p (quotient.mk' a)) : p q :=
  quotient.induction_on q h

/-- A version of `quotient.induction_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit
arguments instead of instance arguments. -/
protected theorem induction_on₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β}
    {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂)
    (h : ∀ (a₁ : α) (a₂ : β), p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
  quotient.induction_on₂ q₁ q₂ h

/-- A version of `quotient.induction_on₃` taking `{s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}`
as implicit arguments instead of instance arguments. -/
protected theorem induction_on₃' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α}
    {s₂ : setoid β} {s₃ : setoid γ} {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
    (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
    (h : ∀ (a₁ : α) (a₂ : β) (a₃ : γ), p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) :
    p q₁ q₂ q₃ :=
  quotient.induction_on₃ q₁ q₂ q₃ h

/-- Recursion on a `quotient` argument `a`, result type depends on `⟦a⟧`. -/
protected def hrec_on' {α : Sort u_1} {s₁ : setoid α} {φ : quotient s₁ → Sort u_2}
    (qa : quotient s₁) (f : (a : α) → φ (quotient.mk' a))
    (c : ∀ (a₁ a₂ : α), a₁ ≈ a₂ → f a₁ == f a₂) : φ qa :=
  quot.hrec_on qa f c

@[simp] theorem hrec_on'_mk' {α : Sort u_1} {s₁ : setoid α} {φ : quotient s₁ → Sort u_2}
    (f : (a : α) → φ (quotient.mk' a)) (c : ∀ (a₁ a₂ : α), a₁ ≈ a₂ → f a₁ == f a₂) (x : α) :
    quotient.hrec_on' (quotient.mk' x) f c = f x :=
  rfl

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β}
    {φ : quotient s₁ → quotient s₂ → Sort u_3} (qa : quotient s₁) (qb : quotient s₂)
    (f : (a : α) → (b : β) → φ (quotient.mk' a) (quotient.mk' b))
    (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
  quotient.hrec_on₂ qa qb f c

@[simp] theorem hrec_on₂'_mk' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β}
    {φ : quotient s₁ → quotient s₂ → Sort u_3}
    (f : (a : α) → (b : β) → φ (quotient.mk' a) (quotient.mk' b))
    (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) (x : α)
    (qb : quotient s₂) :
    quotient.hrec_on₂' (quotient.mk' x) qb f c =
        quotient.hrec_on' qb (f x) fun (b₁ b₂ : β) => c x b₁ x b₂ (setoid.refl x) :=
  rfl

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} (f : α → β)
    (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) : quotient s₁ → quotient s₂ :=
  quot.map f h

@[simp] theorem map'_mk' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} (f : α → β)
    (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) (x : α) :
    quotient.map' f h (quotient.mk' x) = quotient.mk' (f x) :=
  rfl

/-- A version of `quotient.map₂` using curly braces and unification. -/
protected def map₂' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β}
    {s₃ : setoid γ} (f : α → β → γ)
    (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) :
    quotient s₁ → quotient s₂ → quotient s₃ :=
  quotient.map₂ f h

@[simp] theorem map₂'_mk' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α}
    {s₂ : setoid β} {s₃ : setoid γ} (f : α → β → γ)
    (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) (x : α) :
    quotient.map₂' f h (quotient.mk' x) = quotient.map' (f x) (h (setoid.refl x)) :=
  rfl

theorem exact' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} :
    quotient.mk' a = quotient.mk' b → setoid.r a b :=
  exact

theorem sound' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} :
    setoid.r a b → quotient.mk' a = quotient.mk' b :=
  sound

@[simp] protected theorem eq' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} :
    quotient.mk' a = quotient.mk' b ↔ setoid.r a b :=
  eq

/-- A version of `quotient.out` taking `{s₁ : setoid α}` as an implicit argument instead of an
instance argument. -/
def out' {α : Sort u_1} {s₁ : setoid α} (a : quotient s₁) : α := out a

@[simp] theorem out_eq' {α : Sort u_1} {s₁ : setoid α} (q : quotient s₁) :
    quotient.mk' (out' q) = q :=
  out_eq q

theorem mk_out' {α : Sort u_1} {s₁ : setoid α} (a : α) : setoid.r (out' (quotient.mk' a)) a :=
  exact (out_eq (quotient.mk' a))

end Mathlib


import for_mathlib.category_theory.localization.derived_functor_shift
import for_mathlib.category_theory.triangulated.is_triangulated_subcategory

open category_theory category_theory.category category_theory.limits

noncomputable theory

namespace category_theory

namespace right_derivability_structure

variables {C₀ C H D : Type*} [category C₀] [category C] [category D] [category H]
  {W₀ : morphism_property C₀} {W : morphism_property C} {Φ : localizor_morphism W₀ W}
  [localizor_morphism.is_localization_equivalence Φ]
  [morphism_property.multiplicative W₀] [morphism_property.multiplicative W]
  (β : right_derivability_structure.basic Φ)
  (F : C ⥤ D) (L : C ⥤ H)
  (hF : W₀.is_inverted_by (Φ.functor ⋙ F))
  [has_shift C₀ ℤ] [has_shift C ℤ] [has_shift H ℤ] [has_shift D ℤ]
  [F.has_comm_shift ℤ] [L.has_comm_shift ℤ] [Φ.functor.has_comm_shift ℤ]
  [preadditive C₀] [preadditive C] [preadditive H] [preadditive D]
  [has_zero_object C₀] [has_zero_object C] [has_zero_object H] [has_zero_object D]
  [∀ (n : ℤ ), (shift_functor C₀ n).additive]
  [∀ (n : ℤ ), (shift_functor C n).additive]
  [∀ (n : ℤ ), (shift_functor H n).additive]
  [∀ (n : ℤ ), (shift_functor D n).additive]
  [L.is_localization W]
  [pretriangulated C₀] [pretriangulated C] [pretriangulated H] [pretriangulated D]
  [functor.is_triangulated F] [functor.is_triangulated Φ.functor]

namespace basic

include β

lemma Φ_functor_comp_L_ess_surj_on_dist_triang [L.ess_surj_on_dist_triang] [L.is_triangulated]:
  (Φ.functor ⋙ L).ess_surj_on_dist_triang :=
⟨λ T hT, begin
  obtain ⟨T', hT', ⟨e⟩⟩ := functor.ess_surj_on_dist_triang.condition L T hT,
  obtain ⟨X₁, X₂, f', fac⟩ := β.nonempty_arrow_right_resolution T'.mor₁,
  obtain ⟨X₃, g, h, mem⟩ := pretriangulated.distinguished_cocone_triangle _ _ f',
  haveI : is_iso (L.map X₁.hom.f) := localization.inverts L W _ X₁.hom.hf,
  haveI : is_iso (L.map X₂.hom.f) := localization.inverts L W _ X₂.hom.hf,
  refine ⟨_, mem, ⟨iso.symm _ ≪≫ e⟩⟩,
  refine pretriangulated.iso_triangle_of_distinguished_of_is_iso₁₂ _ _
    (L.map_distinguished _ hT') ((Φ.functor ⋙ L).map_distinguished _ mem)
      (as_iso (L.map X₁.hom.f)) (as_iso (L.map X₂.hom.f))
      (by { dsimp, simp only [← L.map_comp, fac]}),
end⟩

variable [functor.ess_surj_on_dist_triang (Φ.functor ⋙ L)]

include hF

lemma derived_functor_is_triangulated' [F.has_right_derived_functor W] :
  (F.right_derived_functor L W).is_triangulated :=
⟨λ T hT, begin
  obtain ⟨T', hT', ⟨e⟩⟩ := functor.ess_surj_on_dist_triang.condition (Φ.functor ⋙ L) T hT,
  have E' := (functor.map_triangle_comp (Φ.functor ⋙ L) (F.right_derived_functor L W)).symm.app T',
  let τ : Φ.functor ⋙ F ⟶ (Φ.functor ⋙ L) ⋙ F.right_derived_functor L W :=
    whisker_left Φ.functor (F.right_derived_functor_α L W) ≫ (functor.associator _ _ _).inv,
  haveI : ∀ (X₀ : C₀), is_iso (τ.app X₀) := λ X₀, begin
    dsimp [τ],
    rw [comp_id],
    apply β.is_iso_app L F hF,
  end,
  haveI := nat_iso.is_iso_of_is_iso_app τ,
  haveI : (as_iso τ).hom.respects_comm_shift ℤ := by { dsimp [as_iso], apply_instance, },
  exact pretriangulated.isomorphic_distinguished _ (functor.map_distinguished _ _ hT') _
    ((F.right_derived_functor L W).map_triangle.map_iso e.symm ≪≫
    (functor.map_triangle_comp (Φ.functor ⋙ L) (F.right_derived_functor L W)).symm.app T' ≪≫
    (functor.map_triangle_nat_iso (as_iso τ)).symm.app T'),
end⟩

lemma derived_functor_is_triangulated (RF : H ⥤ D) (α : F ⟶ L ⋙ RF)
  [RF.is_right_derived_functor α] [RF.has_comm_shift ℤ] [α.respects_comm_shift ℤ] :
  RF.is_triangulated :=
begin
  haveI := functor.is_right_derived_functor.has_right_derived_functor F RF L α W,
  haveI := β.derived_functor_is_triangulated' F L hF,
  let e := nat_iso.right_derived (iso.refl F) (F.right_derived_functor_α L W) α,
  haveI : e.hom.respects_comm_shift ℤ,
  { refine ⟨λ n, _⟩,
    apply functor.is_right_derived_functor_to_ext
      (shift_functor H n ⋙ F.right_derived_functor L W)
      (functor.has_comm_shift.right_derived_shift_α F L W n),
    ext X,
    simp only [nat_trans.comp_app, whisker_left_app, whisker_right_app],
    erw functor.has_comm_shift.right_derived_comm_shift_comm_assoc,
    simp only [nat_iso.right_derived_hom, iso.refl_hom,
      functor.has_comm_shift.right_derived_α_shift_app, ← functor.map_comp,
      nat_trans.right_derived_app (𝟙 F) (F.right_derived_functor_α L W) α X,
      nat_trans.id_app, id_comp,
      functor.has_comm_shift.right_derived_shift_α_app,
      assoc, nat_trans.naturality_assoc, nat_trans.right_derived_app_assoc,
      nat_trans.respects_comm_shift.comm_app α n X,
      functor.has_comm_shift.comp_hom_app], },
  exact functor.is_triangulated.of_iso e,
end

end basic

end right_derivability_structure

end category_theory


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.linear.linear_functor
import category_theory.monoidal.preadditive

/-!
# Linear monoidal categories

A monoidal category is `monoidal_linear R` if it is monoidal preadditive and
tensor product of morphisms is `R`-linear in both factors.
-/

namespace category_theory

open category_theory.limits
open category_theory.monoidal_category

variables (R : Type*) [semiring R]
variables (C : Type*) [category C] [preadditive C] [linear R C]
variables [monoidal_category C] [monoidal_preadditive C]

/--
A category is `monoidal_linear R` if tensoring is `R`-linear in both factors.
-/
class monoidal_linear : Prop :=
(tensor_smul' : ∀ {W X Y Z : C} (f : W ⟶ X) (r : R) (g : Y ⟶ Z),
  f ⊗ (r • g) = r • (f ⊗ g) . obviously)
(smul_tensor' : ∀ {W X Y Z : C} (r : R) (f : W ⟶ X) (g : Y ⟶ Z),
  (r • f) ⊗ g = r • (f ⊗ g) . obviously)

restate_axiom monoidal_linear.tensor_smul'
restate_axiom monoidal_linear.smul_tensor'
attribute [simp] monoidal_linear.tensor_smul monoidal_linear.smul_tensor

variables {C} [monoidal_linear R C]

instance tensor_left_linear (X : C) : (tensor_left X).linear R := {}
instance tensor_right_linear (X : C) : (tensor_right X).linear R := {}
instance tensoring_left_linear (X : C) : ((tensoring_left C).obj X).linear R := {}
instance tensoring_right_linear (X : C) : ((tensoring_right C).obj X).linear R := {}

/-- A faithful linear monoidal functor to a linear monoidal category
ensures that the domain is linear monoidal. -/
lemma monoidal_linear_of_faithful
  {D : Type*} [category D] [preadditive D] [linear R D]
  [monoidal_category D] [monoidal_preadditive D]
  (F : monoidal_functor D C) [faithful F.to_functor]
  [F.to_functor.additive] [F.to_functor.linear R] :
  monoidal_linear R D :=
{ tensor_smul' := begin
    intros,
    apply F.to_functor.map_injective,
    simp only [F.to_functor.map_smul r (f ⊗ g), F.to_functor.map_smul r g, F.map_tensor,
      monoidal_linear.tensor_smul, linear.smul_comp, linear.comp_smul],
  end,
  smul_tensor' := begin
    intros,
    apply F.to_functor.map_injective,
    simp only [F.to_functor.map_smul r (f ⊗ g), F.to_functor.map_smul r f, F.map_tensor,
      monoidal_linear.smul_tensor, linear.smul_comp, linear.comp_smul],
  end, }

end category_theory