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

import order.category.Preorder

/-!
# Category of partial orders

This defines `PartialOrder`, the category of partial orders with monotone maps.
-/

open category_theory

universe u

/-- The category of partially ordered types. -/
def PartialOrder := bundled partial_order

namespace PartialOrder

instance : bundled_hom.parent_projection @partial_order.to_preorder := ⟨⟩

attribute [derive [large_category, concrete_category]] PartialOrder

instance : has_coe_to_sort PartialOrder Type* := bundled.has_coe_to_sort

/-- Construct a bundled PartialOrder from the underlying type and typeclass. -/
def of (α : Type*) [partial_order α] : PartialOrder := bundled.of α

instance : inhabited PartialOrder := ⟨of punit⟩

instance (α : PartialOrder) : partial_order α := α.str

instance has_forget_to_Preorder : has_forget₂ PartialOrder Preorder := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between partial orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : PartialOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def to_dual : PartialOrder ⥤ PartialOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `PartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : PartialOrder ≌ PartialOrder :=
equivalence.mk to_dual to_dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end PartialOrder

lemma PartialOrder_dual_equiv_comp_forget_to_Preorder :
  PartialOrder.dual_equiv.functor ⋙ forget₂ PartialOrder Preorder
  = forget₂ PartialOrder Preorder ⋙ Preorder.dual_equiv.functor := rfl


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.int.basic
import algebra.group_power.lemmas
import category_theory.pi.basic
import category_theory.shift
import category_theory.concrete_category.basic

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

open category_theory.pi
open category_theory.limits

namespace category_theory

universes w v u

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def graded_object (β : Type w) (C : Type u) : Type (max w u) := β → C

-- Satisfying the inhabited linter...
instance inhabited_graded_object (β : Type w) (C : Type u) [inhabited C] :
  inhabited (graded_object β C) :=
⟨λ b, inhabited.default⟩

/--
A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
@[nolint unused_arguments] -- `s` is here to distinguish type synonyms asking for different shifts
abbreviation graded_object_with_shift {β : Type w} [add_comm_group β] (s : β) (C : Type u) :
  Type (max w u) := graded_object β C

namespace graded_object

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

instance category_of_graded_objects (β : Type w) : category.{max w v} (graded_object β C) :=
category_theory.pi (λ _, C)

/-- The projection of a graded object to its `i`-th component. -/
@[simps] def eval {β : Type w} (b : β) : graded_object β C ⥤ C :=
{ obj := λ X, X b,
  map := λ X Y f, f b, }

section
variable (C)

/--
The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
@[simps]
def comap_eq {β γ : Type w} {f g : β → γ} (h : f = g) : comap (λ _, C) f ≅ comap (λ _, C) g :=
{ hom := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end },
  inv := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end }, }

lemma comap_eq_symm {β γ : Type w} {f g : β → γ} (h : f = g) :
  comap_eq C h.symm = (comap_eq C h).symm :=
by tidy

lemma comap_eq_trans {β γ : Type w} {f g h : β → γ} (k : f = g) (l : g = h) :
  comap_eq C (k.trans l) = comap_eq C k ≪≫ comap_eq C l :=
begin
  ext X b,
  simp,
end

@[simp] lemma eq_to_hom_apply {β : Type w} {X Y : Π b : β, C} (h : X = Y) (b : β) :
  (eq_to_hom h : X ⟶ Y) b = eq_to_hom (by subst h) :=
by { subst h, refl }

/--
The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
@[simps]
def comap_equiv {β γ : Type w} (e : β ≃ γ) :
  (graded_object β C) ≌ (graded_object γ C) :=
{ functor := comap (λ _, C) (e.symm : γ → β),
  inverse := comap (λ _, C) (e : β → γ),
  counit_iso := (comap_comp (λ _, C) _ _).trans (comap_eq C (by { ext, simp } )),
  unit_iso := (comap_eq C (by { ext, simp } )).trans (comap_comp _ _ _).symm,
  functor_unit_iso_comp' := λ X, by { ext b, dsimp, simp, }, }  -- See note [dsimp, simp].

end

instance has_shift {β : Type*} [add_comm_group β] (s : β) :
  has_shift (graded_object_with_shift s C) ℤ :=
has_shift_mk _ _
{ F := λ n, comap (λ _, C) $ λ (b : β), b + n • s,
  ε := (comap_id β (λ _, C)).symm ≪≫ (comap_eq C (by { ext, simp })),
  μ := λ m n, comap_comp _ _ _ ≪≫ comap_eq C (by { ext, simp [add_zsmul, add_comm] }),
  left_unitality := by { introv, ext, dsimp, simpa },
  right_unitality := by { introv, ext, dsimp, simpa },
  associativity := by { introv, ext, dsimp, simp } }

@[simp] lemma shift_functor_obj_apply {β : Type*} [add_comm_group β]
  (s : β) (X : β → C) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).obj X t = X (t + n • s) :=
rfl

@[simp] lemma shift_functor_map_apply {β : Type*} [add_comm_group β] (s : β)
  {X Y : graded_object_with_shift s C} (f : X ⟶ Y) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).map f t = f (t + n • s) :=
rfl

instance has_zero_morphisms [has_zero_morphisms C] (β : Type w) :
  has_zero_morphisms.{max w v} (graded_object β C) :=
{ has_zero := λ X Y,
  { zero := λ b, 0 } }

@[simp]
lemma zero_apply [has_zero_morphisms C] (β : Type w) (X Y : graded_object β C) (b : β) :
  (0 : X ⟶ Y) b = 0 := rfl

section
open_locale zero_object

instance has_zero_object [has_zero_object C] [has_zero_morphisms C] (β : Type w) :
  has_zero_object.{max w v} (graded_object β C) :=
by { refine ⟨⟨λ b, 0, λ X, ⟨⟨⟨λ b, 0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨λ b, 0⟩, λ f, _⟩⟩⟩⟩; ext, }
end

end graded_object

namespace graded_object
-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.
-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.
-- If you're grading by things in higher universes, have fun!
variables (β : Type)
variables (C : Type u) [category.{v} C]
variables [has_coproducts C]

section
local attribute [tidy] tactic.discrete_cases

/--
The total object of a graded object is the coproduct of the graded components.
-/
noncomputable def total : graded_object β C ⥤ C :=
{ obj := λ X, ∐ (λ i : ulift.{v} β, X i.down),
  map := λ X Y f, limits.sigma.map (λ i, f i.down) }.

end

variables [has_zero_morphisms C]

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
instance : faithful (total β C) :=
{ map_injective' := λ X Y f g w,
  begin
    classical,
    ext i,
    replace w := sigma.ι (λ i : ulift.{v} β, X i.down) ⟨i⟩ ≫= w,
    erw [colimit.ι_map, colimit.ι_map] at w,
    exact mono.right_cancellation _ _ w,
  end }

end graded_object

namespace graded_object

noncomputable theory

variables (β : Type)
variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_coproducts C] [has_zero_morphisms C]

instance : concrete_category (graded_object β C) :=
{ forget := total β C ⋙ forget C }

instance : has_forget₂ (graded_object β C) C :=
{ forget₂ := total β C }

end graded_object

end category_theory


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.shapes.pullbacks
import ring_theory.tensor_product
import algebra.category.Ring.limits
import algebra.category.Ring.colimits
import category_theory.limits.shapes.strict_initial
import ring_theory.subring.basic
import ring_theory.ideal.local_ring
import category_theory.limits.preserves.limits

/-!
# Constructions of (co)limits in CommRing

In this file we provide the explicit (co)cones for various (co)limits in `CommRing`, including
* tensor product is the pushout
* `Z` is the initial object
* `0` is the strict terminal object
* cartesian product is the product
* `ring_hom.eq_locus` is the equalizer

-/

universes u u'

open category_theory category_theory.limits
open_locale tensor_product

namespace CommRing

section pushout

variables {R A B : CommRing.{u}} (f : R ⟶ A) (g : R ⟶ B)

/-- The explicit cocone with tensor products as the fibered product in `CommRing`. -/
def pushout_cocone : limits.pushout_cocone f g :=
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  apply limits.pushout_cocone.mk,
  show CommRing, from CommRing.of (A ⊗[R] B),
  show A ⟶ _,  from algebra.tensor_product.include_left.to_ring_hom,
  show B ⟶ _,  from algebra.tensor_product.include_right.to_ring_hom,
  ext r,
  transitivity algebra_map R (A ⊗[R] B) r,
  { exact algebra.tensor_product.include_left.commutes r },
  { exact (algebra.tensor_product.include_right.commutes r).symm }
end

@[simp]
lemma pushout_cocone_inl : (pushout_cocone f g).inl = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_left.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_inr : (pushout_cocone f g).inr = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_right.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_X : (pushout_cocone f g).X = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI CommRing.of (A ⊗[R] B) }) := rfl

/-- Verify that the `pushout_cocone` is indeed the colimit. -/
def pushout_cocone_is_colimit : limits.is_colimit (pushout_cocone f g) :=
limits.pushout_cocone.is_colimit_aux' _ (λ s,
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  letI := ring_hom.to_algebra (f ≫ s.inl),
  let f' : A →ₐ[R] s.X := { commutes' := λ r, by
      { change s.inl.to_fun (f r) = (f ≫ s.inl) r, refl }, ..s.inl },
  let g' : B →ₐ[R] s.X := { commutes' := λ r, by
      { change (g ≫ s.inr) r = (f ≫ s.inl) r,
        congr' 1,
        exact (s.ι.naturality limits.walking_span.hom.snd).trans
          (s.ι.naturality limits.walking_span.hom.fst).symm }, ..s.inr },
  /- The factor map is a ⊗ b ↦ f(a) * g(b). -/
  use alg_hom.to_ring_hom (algebra.tensor_product.product_map f' g'),
  simp only [pushout_cocone_inl, pushout_cocone_inr],
  split, { ext x, exact algebra.tensor_product.product_map_left_apply  _ _ x, },
  split, { ext x, exact algebra.tensor_product.product_map_right_apply _ _ x, },
  intros h eq1 eq2,
  let h' : (A ⊗[R] B) →ₐ[R] s.X :=
    { commutes' := λ r, by
    { change h ((f r) ⊗ₜ[R] 1) = s.inl (f r),
      rw ← eq1, simp }, ..h },
  suffices : h' = algebra.tensor_product.product_map f' g',
  { ext x,
    change h' x = algebra.tensor_product.product_map f' g' x,
    rw this },
  apply algebra.tensor_product.ext,
  intros a b,
  simp [← eq1, ← eq2, ← h.map_mul],
end)

end pushout

section terminal

/-- The trivial ring is the (strict) terminal object of `CommRing`. -/
def punit_is_terminal : is_terminal (CommRing.of.{u} punit) :=
begin
  apply_with is_terminal.of_unique { instances := ff },
  tidy
end

instance CommRing_has_strict_terminal_objects : has_strict_terminal_objects CommRing.{u} :=
begin
  apply has_strict_terminal_objects_of_terminal_is_strict (CommRing.of punit),
  intros X f,
  refine ⟨⟨by tidy, by ext, _⟩⟩,
  ext,
  have e : (0 : X) = 1 := by { rw [← f.map_one, ← f.map_zero], congr },
  replace e : 0 * x = 1 * x := congr_arg (λ a, a * x) e,
  rw [one_mul, zero_mul, ← f.map_zero] at e,
  exact e,
end

lemma subsingleton_of_is_terminal {X : CommRing} (hX : is_terminal X) : subsingleton X :=
(hX.unique_up_to_iso punit_is_terminal).CommRing_iso_to_ring_equiv.to_equiv
  .subsingleton_congr.mpr (show subsingleton punit, by apply_instance)

/-- `ℤ` is the initial object of `CommRing`. -/
def Z_is_initial : is_initial (CommRing.of ℤ) :=
begin
  apply_with is_initial.of_unique { instances := ff },
  exact λ R, ⟨⟨int.cast_ring_hom R⟩, λ a, a.ext_int _⟩,
end

end terminal

section product

variables (A B : CommRing.{u})

/-- The product in `CommRing` is the cartesian product. This is the binary fan. -/
@[simps X]
def prod_fan : binary_fan A B :=
binary_fan.mk (CommRing.of_hom $ ring_hom.fst A B) (CommRing.of_hom $ ring_hom.snd A B)

/-- The product in `CommRing` is the cartesian product. -/
def prod_fan_is_limit : is_limit (prod_fan A B) :=
{ lift := λ c, ring_hom.prod (c.π.app ⟨walking_pair.left⟩) (c.π.app ⟨walking_pair.right⟩),
  fac' := λ c j, by { ext, rcases j with ⟨⟨⟩⟩;
    simpa only [binary_fan.π_app_left, binary_fan.π_app_right, comp_apply, ring_hom.prod_apply] },
  uniq' := λ s m h, by { ext, { simpa using congr_hom (h ⟨walking_pair.left⟩) x },
    { simpa using congr_hom (h ⟨walking_pair.right⟩) x } } }

end product

section equalizer

variables {A B : CommRing.{u}} (f g : A ⟶ B)

/-- The equalizer in `CommRing` is the equalizer as sets. This is the equalizer fork. -/
def equalizer_fork : fork f g :=
fork.of_ι (CommRing.of_hom (ring_hom.eq_locus f g).subtype) (by { ext ⟨x, e⟩, simpa using e })

/-- The equalizer in `CommRing` is the equalizer as sets. -/
def equalizer_fork_is_limit : is_limit (equalizer_fork f g) :=
begin
  fapply fork.is_limit.mk',
  intro s,
  use s.ι.cod_restrict _ (λ x, (concrete_category.congr_hom s.condition x : _)),
  split,
  { ext, refl },
  { intros m hm, ext x, exact concrete_category.congr_hom hm x }
end

instance : is_local_ring_hom (equalizer_fork f g).ι :=
begin
  constructor,
  rintros ⟨a, (h₁ : _ = _)⟩ (⟨⟨x,y,h₃,h₄⟩,(rfl : x = _)⟩ : is_unit a),
  have : y ∈ ring_hom.eq_locus f g,
  { apply (f.is_unit_map ⟨⟨x,y,h₃,h₄⟩,rfl⟩ : is_unit (f x)).mul_left_inj.mp,
    conv_rhs { rw h₁ },
    rw [← f.map_mul, ← g.map_mul, h₄, f.map_one, g.map_one] },
  rw is_unit_iff_exists_inv,
  exact ⟨⟨y, this⟩, subtype.eq h₃⟩,
end

instance equalizer_ι_is_local_ring_hom (F : walking_parallel_pair.{u} ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F walking_parallel_pair.zero) :=
begin
  have := lim_map_π (diagram_iso_parallel_pair F).hom walking_parallel_pair.zero,
  rw ← is_iso.comp_inv_eq at this,
  rw ← this,
  rw ← limit.iso_limit_cone_hom_π ⟨_, equalizer_fork_is_limit
    (F.map walking_parallel_pair_hom.left) (F.map walking_parallel_pair_hom.right)⟩
    walking_parallel_pair.zero,
  change is_local_ring_hom ((lim.map _ ≫ _ ≫ (equalizer_fork _ _).ι) ≫ _),
  apply_instance
end

open category_theory.limits.walking_parallel_pair opposite
open category_theory.limits.walking_parallel_pair_hom

instance equalizer_ι_is_local_ring_hom' (F : walking_parallel_pair.{u}ᵒᵖ ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F (opposite.op walking_parallel_pair.one)) :=
begin
  have : _ = limit.π F (walking_parallel_pair_op_equiv.{u u}.functor.obj _) :=
    (limit.iso_limit_cone_inv_π ⟨_, is_limit.whisker_equivalence (limit.is_limit F)
      walking_parallel_pair_op_equiv⟩ walking_parallel_pair.zero : _),
  erw ← this,
  apply_instance
end

end equalizer

end CommRing


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

/-!
# Binary disjoint unions of categories

We define the category instance on `C ⊕ D` when `C` and `D` are categories.

We define:
* `inl_`      : the functor `C ⥤ C ⊕ D`
* `inr_`      : the functor `D ⥤ C ⊕ D`
* `swap`      : the functor `C ⊕ D ⥤ D ⊕ C`
    (and the fact this is an equivalence)

We further define sums of functors and natural transformations, written `F.sum G` and `α.sum β`.
-/

namespace category_theory

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

open sum

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

/--
`sum C D` gives the direct sum of two categories.
-/
instance sum : category.{v₁} (C ⊕ D) :=
{ hom :=
    λ X Y, match X, Y with
    | inl X, inl Y := X ⟶ Y
    | inl X, inr Y := pempty
    | inr X, inl Y := pempty
    | inr X, inr Y := X ⟶ Y
    end,
  id :=
    λ X, match X with
    | inl X := 𝟙 X
    | inr X := 𝟙 X
    end,
  comp :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := f ≫ g
    | inr X, inr Y, inr Z, f, g := f ≫ g
    end }

@[simp] lemma sum_comp_inl {P Q R : C} (f : (inl P : C ⊕ D) ⟶ inl Q) (g : inl Q ⟶ inl R) :
  f ≫ g = (f : P ⟶ Q) ≫ (g : Q ⟶ R) := rfl
@[simp] lemma sum_comp_inr {P Q R : D} (f : (inr P : C ⊕ D) ⟶ inr Q) (g : inr Q ⟶ inr R) :
  f ≫ g = (f : P ⟶ Q) ≫ (g : Q ⟶ R) := rfl
end

namespace sum

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

/-- `inl_` is the functor `X ↦ inl X`. -/
-- Unfortunate naming here, suggestions welcome.
@[simps] def inl_ : C ⥤ C ⊕ D :=
{ obj := λ X, inl X,
  map := λ X Y f, f }

/-- `inr_` is the functor `X ↦ inr X`. -/
@[simps] def inr_ : D ⥤ C ⊕ D :=
{ obj := λ X, inr X,
  map := λ X Y f, f }

/-- The functor exchanging two direct summand categories. -/
def swap : C ⊕ D ⥤ D ⊕ C :=
{ obj :=
    λ X, match X with
    | inl X := inr X
    | inr X := inl X
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := f
    | inr X, inr Y, f := f
    end }

@[simp] lemma swap_obj_inl (X : C) : (swap C D).obj (inl X) = inr X := rfl
@[simp] lemma swap_obj_inr (X : D) : (swap C D).obj (inr X) = inl X := rfl
@[simp] lemma swap_map_inl {X Y : C} {f : inl X ⟶ inl Y} : (swap C D).map f = f := rfl
@[simp]

namespace swap

/-- `swap` gives an equivalence between `C ⊕ D` and `D ⊕ C`. -/
def equivalence : C ⊕ D ≌ D ⊕ C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))

instance is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (equivalence C D).functor)

/-- The double swap on `C ⊕ D` is naturally isomorphic to the identity functor. -/
def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C ⊕ D) :=
(equivalence C D).unit_iso.symm

end swap

end sum

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₁} [category.{v₁} B]
          {C : Type u₁} [category.{v₁} C]
          {D : Type u₁} [category.{v₁} D]

namespace functor

/-- The sum of two functors. -/
def sum (F : A ⥤ B) (G : C ⥤ D) : A ⊕ C ⥤ B ⊕ D :=
{ obj :=
    λ X, match X with
    | inl X := inl (F.obj X)
    | inr X := inr (G.obj X)
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := F.map f
    | inr X, inr Y, f := G.map f
    end,
  map_id' := λ X, begin cases X; unfold_aux, erw F.map_id, refl, erw G.map_id, refl end,
  map_comp' :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := by { unfold_aux, erw F.map_comp, refl }
    | inr X, inr Y, inr Z, f, g := by { unfold_aux, erw G.map_comp, refl }
    end }

@[simp] lemma sum_obj_inl (F : A ⥤ B) (G : C ⥤ D) (a : A) :
  (F.sum G).obj (inl a) = inl (F.obj a) := rfl
@[simp] lemma sum_obj_inr (F : A ⥤ B) (G : C ⥤ D) (c : C) :
  (F.sum G).obj (inr c) = inr (G.obj c) := rfl
@[simp] lemma sum_map_inl (F : A ⥤ B) (G : C ⥤ D) {a a' : A} (f : inl a ⟶ inl a') :
  (F.sum G).map f = F.map f := rfl
@[simp] lemma sum_map_inr (F : A ⥤ B) (G : C ⥤ D) {c c' : C} (f : inr c ⟶ inr c') :
  (F.sum G).map f = G.map f := rfl
end functor

namespace nat_trans

/-- The sum of two natural transformations. -/
def sum {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) : F.sum H ⟶ G.sum I :=
{ app         :=
    λ X, match X with
    | inl X := α.app X
    | inr X := β.app X
    end,
  naturality' :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := begin unfold_aux, erw α.naturality, refl, end
    | inr X, inr Y, f := begin unfold_aux, erw β.naturality, refl, end
    end }

@[simp] lemma sum_app_inl {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (a : A) :
  (sum α β).app (inl a) = α.app a := rfl
@[simp] lemma sum_app_inr {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (c : C) :
  (sum α β).app (inr c) = β.app c := rfl
end nat_trans

end category_theory


import .basic group_theory.submonoid.operations

variables {ι : Type*} {M : ι → Type*}
variables [decidable_eq ι] [Π i, decidable_eq (M i)]
variables [Π i, monoid (M i)]

open coprod  submonoid function

lemma mul_aux_mem (S : Π i, submonoid (M i)) : ∀ (l₁ l₂ : list (Σ i, M i))
  (h₁ : ∀ a : Σ i, M i, a ∈ l₁ → a.2 ∈ S a.1)
  (h₂ : ∀ a : Σ i, M i, a ∈ l₂ → a.2 ∈ S a.1)
  {i : ι} {a : M i} (ha : (⟨i, a⟩ : Σ i, M i) ∈ pre.mul_aux l₁ l₂),
  a ∈ S i
| []           l₂      := by simp [pre.mul_aux]
| (⟨j, b⟩::l₁) []      := begin
    assume h₁ _ i a ha,
    simp only [pre.mul_aux, list.mem_reverse, list.mem_cons_iff] at ha,
    rcases ha with ⟨rfl, hab⟩ | hia,
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₁ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ hia) }
  end
| (⟨j, b⟩::l₁) (⟨k, c⟩::l₂) := begin
  assume h₁ h₂ i a ha,
  simp only [pre.mul_aux] at ha,
  split_ifs at ha,
  { exact mul_aux_mem _ _
      (λ d hd, h₁ d (list.mem_cons_of_mem _ hd))
      (λ d hd, h₂ d (list.mem_cons_of_mem _ hd))
      ha },
  { dsimp at h,
    subst j,
    simp only [list.reverse_core_eq, list.mem_append, list.mem_cons_iff,
      list.mem_reverse, cast_eq] at ha,
    simp only [cast_eq] at *,
    rcases ha with ha | ⟨rfl, h, h⟩ | ha,
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) },
    { exact submonoid.mul_mem _
        (h₁ ⟨i, b⟩ (list.mem_cons_self _ _))
        (h₂ ⟨i, c⟩ (list.mem_cons_self _ _)) },
    { exact h₂ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) } },
  { clear_aux_decl,
    simp only [list.reverse_core_eq, list.mem_append, list.mem_cons_iff,
      list.mem_reverse] at ha,
    rcases ha with ha | ⟨rfl, hab⟩ | ⟨rfl, hab⟩ | ha,
    { exact h₁ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) },
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₁ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { rw [heq_iff_eq] at hab,
      subst hab,
      exact h₂ ⟨i, a⟩ (list.mem_cons_self _ _) },
    { exact h₂ ⟨i, a⟩ (list.mem_cons_of_mem _ ha) } }
end

def blah (S : Π i, submonoid (M i)) : submonoid (coprod M) :=
{ carrier  := { w : coprod M | ∀ (a : Σ i, M i), a ∈ w.to_list → a.2 ∈ S a.1 },
  one_mem' := λ a h, h.elim,
  mul_mem' := begin
    rintros ⟨l₁, hl₁⟩ ⟨l₂, hl₂⟩ h₁ h₂ ⟨i, a⟩ h,
    exact mul_aux_mem S l₁.reverse l₂ (by simpa using h₁) (by simpa using h₂) h
  end }

lemma mem_blah (S : Π i, submonoid (M i)) (w : coprod M) :
  w ∈ blah S ↔ ∀ (a : Σ i, M i), a ∈ w.to_list → a.2 ∈ S a.1 := iff.rfl

variable {S : Π i, submonoid (M i)}

@[simp] lemma of_mem_blah_iff {i : ι} {a : M i} : of i a ∈ blah S ↔ a ∈ S i :=
begin
  simp only [mem_blah, to_list_of],
  split_ifs,
  { simp [*, submonoid.one_mem] },
  { simp only [list.mem_singleton],
    split,
    { exact λ h, h ⟨i, a⟩ rfl },
    { assume ha j hj,
      subst j,
      exact ha } }
end

lemma blah_eq_supr : blah S = ⨆ i, (S i).map (of i) :=
le_antisymm
  (λ w hw, begin
    cases w with l hl,
    induction l with i l ih,
    { simp [submonoid.one_mem] },
    { rw [cons_eq_of_mul],
      refine submonoid.mul_mem _ _ _,
      { exact le_supr (λ i, (S i).map (of i)) i.1
        (mem_map.2 ⟨i.2, hw _ (list.mem_cons_self _ _), rfl⟩) },
      { exact ih _ (λ j hj, hw _ (list.mem_cons_of_mem _ hj)) } }
  end)
  (supr_le (λ i a ha, begin
    rw [mem_map] at ha,
    rcases ha with ⟨a, ha, rfl⟩,
    simp only [to_list_of, mem_blah],
    split_ifs,
    { simp },
    { simp only [list.mem_singleton],
      assume a ha,
      subst a,
      exact ha }
  end))


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# simps attribute

This file defines the `@[simps]` attribute, to automatically generate simp-lemmas
reducing a definition when projections are applied to it.

## Implementation Notes

There are three attributes being defined here
* `@[simps]` is the attribute for objects of a structure or instances of a class. It will
  automatically generate simplification lemmas for each projection of the object/instance that
  contains data. See the doc strings for `simps_attr` and `simps_cfg` for more details and
  configuration options.
* `@[_simps_str]` is automatically added to structures that have been used in `@[simps]` at least
  once. This attribute contains the data of the projections used for this structure by all following
  invocations of `@[simps]`.
* `@[notation_class]` should be added to all classes that define notation, like `has_mul` and
  `has_zero`. This specifies that the projections that `@[simps]` used are the projections from
  these notation classes instead of the projections of the superclasses.
  Example: if `has_mul` is tagged with `@[notation_class]` then the projection used for `semigroup`
  will be `λ α hα, @has_mul.mul α (@semigroup.to_has_mul α hα)` instead of `@semigroup.mul`.

## Tags

structures, projections, simp, simplifier, generates declarations
-/

/--
The `@[_simps_str]` attribute specifies the preferred projections of the given structure,
used by the `@[simps]` attribute.
- This will usually be tagged by the `@[simps]` tactic.
- You can also generate this with the command `initialize_simps_projections`.
- To change the default value, see Note [custom simps projection].
- You are strongly discouraged to add this attribute manually.
- The first argument is the list of names of the universe variables used in the structure
- The second argument is a list that consists of
  - a custom name for each projection of the structure
  - an expressions for each projections of the structure (definitionally equal to the
    corresponding projection). These expressions can contain the universe parameters specified
    in the first argument).
-/
/--
  The `@[notation_class]` attribute specifies that this is a notation class,
  and this notation should be used instead of projections by @[simps].
  * The first argument `tt` for notation classes and `ff` for classes applied to the structure,
    like `has_coe_to_sort` and `has_coe_to_fun`
  * The second argument is the name of the projection (by default it is the first projection
    of the structure)
-/
/--
  Get the projections used by `simps` associated to a given structure `str`. The second component is
  the list of projections, and the first component the (shared) list of universe levels used by the
  projections.

  The returned information is also stored in a parameter of the attribute `@[_simps_str]`, which
  is given to `str`. If `str` already has this attribute, the information is read from this
  attribute instead.

  The returned universe levels are the universe levels of the structure. For the projections there
  are three cases
  * If the declaration `{structure_name}.simps.{projection_name}` has been declared, then the value
    of this declaration is used (after checking that it is definitionally equal to the actual
    projection
  * Otherwise, for every class with the `notation_class` attribute, and the structure has an
    instance of that notation class, then the projection of that notation class is used for the
    projection that is definitionally equal to it (if there is such a projection).
    This means in practice that coercions to function types and sorts will be used instead of
    a projection, if this coercion is definitionally equal to a projection. Furthermore, for
    notation classes like `has_mul` and `has_zero` those projections are used instead of the
    corresponding projection
  * Otherwise, the projection of the structure is chosen.
    For example: ``simps_get_raw_projections env `prod`` gives the default projections
```
  ([u, v], [prod.fst.{u v}, prod.snd.{u v}])
```
    while ``simps_get_raw_projections env `equiv`` gives
```
  ([u_1, u_2], [λ α β, coe_fn, λ {α β} (e : α ≃ β), ⇑(e.symm), left_inv, right_inv])
```
    after declaring the coercion from `equiv` to function and adding the declaration
```
  def equiv.simps.inv_fun {α β} (e : α ≃ β) : β → α := e.symm
```

  Optionally, this command accepts two optional arguments
  * If `trace_if_exists` the command will always generate a trace message when the structure already
    has the attribute `@[_simps_str]`.
  * The `name_changes` argument accepts a list of pairs `(old_name, new_name)`. This is used to
    change the projection name `old_name` to the custom projection name `new_name`. Example:
    for the structure `equiv` the projection `to_fun` could be renamed `apply`. This name will be
    used for parsing and generating projection names. This argument is ignored if the structure
    already has an existing attribute.
-/
-- if performance becomes a problem, possible heuristic: use the names of the projections to

-- skip all classes that don't have the corresponding field.

/--
  You can specify custom projections for the `@[simps]` attribute.
  To do this for the projection `my_structure.awesome_projection` by adding a declaration
  `my_structure.simps.awesome_projection` that is definitionally equal to
  `my_structure.awesome_projection` but has the projection in the desired (simp-normal) form.

  You can initialize the projections `@[simps]` uses with `initialize_simps_projections`
  (after declaring any custom projections). This is not necessary, it has the same effect
  if you just add `@[simps]` to a declaration.

  If you do anything to change the default projections, make sure to call either `@[simps]` or
  `initialize_simps_projections` in the same file as the structure declaration. Otherwise, you might
  have a file that imports the structure, but not your custom projections.
-/
/-- Specify simps projections, see Note [custom simps projection].
  You can specify custom names by writing e.g.
  `initialize_simps_projections equiv (to_fun → apply, inv_fun → symm_apply)`.
  Set `trace.simps.verbose` to true to see the generated projections.
  If the projections were already specified before, you can call `initialize_simps_projections`
  again to see the generated projections. -/
/--
  Get the projections of a structure used by `@[simps]` applied to the appropriate arguments.
  Returns a list of quadruples
  (projection expression, given projection name, original (full) projection name,
    corresponding right-hand-side),
  one for each projection. The given projection name is the name for the projection used by the user
  used to generate (and parse) projection names. The original projection name is the actual
  projection name in the structure, which is only used to check whether the expression is an
  eta-expansion of some other expression. For example, in the structure

  Example 1: ``simps_get_projection_exprs env `(α × β) `(⟨x, y⟩)`` will give the output
  ```
    [(`(@prod.fst.{u v} α β), `fst, `prod.fst, `(x)),
     (`(@prod.snd.{u v} α β), `snd, `prod.snd, `(y))]
  ```

  Example 2: ``simps_get_projection_exprs env `(α ≃ α) `(⟨id, id, λ _, rfl, λ _, rfl⟩)``
  will give the output
  ```
    [(`(@equiv.to_fun.{u u} α α), `apply, `equiv.to_fun, `(id)),
     (`(@equiv.inv_fun.{u u} α α), `symm_apply, `equiv.inv_fun, `(id)),
     ...,
     ...]
  ```
  The last two fields of the list correspond to the propositional fields of the structure,
  and are rarely/never used.
-/
-- This function does not use `tactic.mk_app` or `tactic.mk_mapp`, because the the given arguments

-- might not uniquely specify the universe levels yet.

/--
  Configuration options for the `@[simps]` attribute.
  * `attrs` specifies the list of attributes given to the generated lemmas. Default: ``[`simp]``.
    The attributes can be either basic attributes, or user attributes without parameters.
    There are two attributes which `simps` might add itself:
    * If ``[`simp]`` is in the list, then ``[`_refl_lemma]`` is added automatically if appropriate.
    * If the definition is marked with `@[to_additive ...]` then all generated lemmas are marked
      with `@[to_additive]`
  * `short_name` gives the generated lemmas a shorter name. This only has an effect when multiple
    projections are applied in a lemma. When this is `ff` (default) all projection names will be
    appended to the definition name to form the lemma name, and when this is `tt`, only the
    last projection name will be appended.
  * if `simp_rhs` is `tt` then the right-hand-side of the generated lemmas will be put in
    simp-normal form. More precisely: `dsimp, simp` will be called on all these expressions.
    See note [dsimp, simp].
  * `type_md` specifies how aggressively definitions are unfolded in the type of expressions
    for the purposes of finding out whether the type is a function type.
    Default: `instances`. This will unfold coercion instances (so that a coercion to a function type
    is recognized as a function type), but not declarations like `set`.
  * `rhs_md` specifies how aggressively definition in the declaration are unfolded for the purposes
    of finding out whether it is a constructor.
    Default: `none`
    Exception: `@[simps]` will automatically add the options
    `{rhs_md := semireducible, simp_rhs := tt}` if the given definition is not a constructor with
    the given reducibility setting for `rhs_md`.
  * If `fully_applied` is `ff` then the generated simp-lemmas will be between non-fully applied
    terms, i.e. equalities between functions. This does not restrict the recursive behavior of
    `@[simps]`, so only the "final" projection will be non-fully applied.
    However, it can be used in combination with explicit field names, to get a partially applied
    intermediate projection.
  * The option `not_recursive` contains the list of names of types for which `@[simps]` doesn't
    recursively apply projections. For example, given an equivalence `α × β ≃ β × α` one usually
    wants to only apply the projections for `equiv`, and not also those for `×`. This option is
    only relevant if no explicit projection names are given as argument to `@[simps]`.
-/
structure simps_cfg
where
  attrs : List name
  short_name : Bool
  simp_rhs : Bool
  type_md : tactic.transparency
  rhs_md : tactic.transparency
  fully_applied : Bool
  not_recursive : List name

/-- Add a lemma with `nm` stating that `lhs = rhs`. `type` is the type of both `lhs` and `rhs`,
  `args` is the list of local constants occurring, and `univs` is the list of universe variables.
  If `add_simp` then we make the resulting lemma a simp-lemma. -/
/-- Derive lemmas specifying the projections of the declaration.
  If `todo` is non-empty, it will generate exactly the names in `todo`. -/
/-- `simps_tac` derives simp-lemmas for all (nested) non-Prop projections of the declaration.
  If `todo` is non-empty, it will generate exactly the names in `todo`.
  If `short_nm` is true, the generated names will only use the last projection name. -/
/-- The parser for the `@[simps]` attribute. -/
/- note: we don't check whether the user has written a nonsense namespace in an argument. -/

/--
The `@[simps]` attribute automatically derives lemmas specifying the projections of this
declaration.

Example:
```lean
@[simps] def foo : ℕ × ℤ := (1, 2)
```
derives two simp-lemmas:
```lean
@[simp] lemma foo_fst : foo.fst = 1
@[simp] lemma foo_snd : foo.snd = 2
```

* It does not derive simp-lemmas for the prop-valued projections.
* It will automatically reduce newly created beta-redexes, but will not unfold any definitions.
* If the structure has a coercion to either sorts or functions, and this is defined to be one
  of the projections, then this coercion will be used instead of the projection.
* If the structure is a class that has an instance to a notation class, like `has_mul`, then this
  notation is used instead of the corresponding projection.
* You can specify custom projections, by giving a declaration with name
  `{structure_name}.simps.{projection_name}`. See Note [custom simps projection].

  Example:
  ```lean
  def equiv.simps.inv_fun (e : α ≃ β) : β → α := e.symm
  @[simps] def equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
  ⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm⟩
  ```
  generates
  ```
  @[simp] lemma equiv.trans_to_fun : ∀ {α β γ} (e₁ e₂) (a : α), ⇑(e₁.trans e₂) a = (⇑e₂ ∘ ⇑e₁) a
  @[simp] lemma equiv.trans_inv_fun : ∀ {α β γ} (e₁ e₂) (a : γ),
    ⇑((e₁.trans e₂).symm) a = (⇑(e₁.symm) ∘ ⇑(e₂.symm)) a
  ```

* You can specify custom projection names, by specifying the new projection names using
  `initialize_simps_projections`.
  Example: `initialize_simps_projections equiv (to_fun → apply, inv_fun → symm_apply)`.

* If one of the fields itself is a structure, this command will recursively create
  simp-lemmas for all fields in that structure.
  * Exception: by default it will not recursively create simp-lemmas for fields in the structures
    `prod` and `pprod`. Give explicit projection names to override this behavior.

  Example:
  ```lean
  structure my_prod (α β : Type*) := (fst : α) (snd : β)
  @[simps] def foo : prod ℕ ℕ × my_prod ℕ ℕ := ⟨⟨1, 2⟩, 3, 4⟩
  ```
  generates
  ```lean
  @[simp] lemma foo_fst : foo.fst = (1, 2)
  @[simp] lemma foo_snd_fst : foo.snd.fst = 3
  @[simp] lemma foo_snd_snd : foo.snd.snd = 4
  ```

* You can use `@[simps proj1 proj2 ...]` to only generate the projection lemmas for the specified
  projections.
* Recursive projection names can be specified using `proj1_proj2_proj3`.
  This will create a lemma of the form `foo.proj1.proj2.proj3 = ...`.

  Example:
  ```lean
  structure my_prod (α β : Type*) := (fst : α) (snd : β)
  @[simps fst fst_fst snd] def foo : prod ℕ ℕ × my_prod ℕ ℕ := ⟨⟨1, 2⟩, 3, 4⟩
  ```
  generates
  ```lean
  @[simp] lemma foo_fst : foo.fst = (1, 2)
  @[simp] lemma foo_fst_fst : foo.fst.fst = 1
  @[simp] lemma foo_snd : foo.snd = {fst := 3, snd := 4}
  ```
* If one of the values is an eta-expanded structure, we will eta-reduce this structure.

  Example:
  ```lean
  structure equiv_plus_data (α β) extends α ≃ β := (data : bool)
  @[simps] def bar {α} : equiv_plus_data α α := { data := tt, ..equiv.refl α }
  ```
  generates the following, even though Lean inserts an eta-expanded version of `equiv.refl α` in the
  definition of `bar`:
  ```lean
  @[simp] lemma bar_to_equiv : ∀ {α : Sort u_1}, bar.to_equiv = equiv.refl α
  @[simp] lemma bar_data : ∀ {α : Sort u_1}, bar.data = tt
  ```
* For configuration options, see the doc string of `simps_cfg`.
* The precise syntax is `('simps' ident* e)`, where `e` is an expression of type `simps_cfg`.
* `@[simps]` reduces let-expressions where necessary.
* If one of the fields is a partially applied constructor, we will eta-expand it
  (this likely never happens).
* When option `trace.simps.verbose` is true, `simps` will print the projections it finds and the
  lemmas it generates.
* Use `@[to_additive, simps]` to apply both `to_additive` and `simps` to a definition, making sure
  that `simps` comes after `to_additive`. This will also generate the additive versions of all
  simp-lemmas. Note however, that the additive versions of the simp-lemmas always use the default
  name generated by `to_additive`, even if a custom name is given for the additive version of the
  definition.
  -/


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.currying
import category_theory.limits.over
import category_theory.monad.adjunction

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
@[derive [category]]
def mono_over (X : C) := {f : over X // mono f.hom}

namespace mono_over

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : mono f] : mono_over X := { val := over.mk f, property := hf }

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : mono_over X ⥤ over X := full_subcategory_inclusion _

instance : has_coe (mono_over X) C :=
{ coe := λ Y, Y.val.left, }

@[simp]
lemma forget_obj_left {f} : ((forget X).obj f).left = (f : C) := rfl

@[simp] lemma mk'_coe' {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f : C) = A := rfl

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbreviation arrow (f : mono_over X) : (f : C) ⟶ X := ((forget X).obj f).hom

@[simp] lemma mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f).arrow = f := rfl

@[simp]
lemma forget_obj_hom {f} : ((forget X).obj f).hom = f.arrow := rfl

instance : full (forget X) := full_subcategory.full _
instance : faithful (forget X) := full_subcategory.faithful _

instance mono (f : mono_over X) : mono f.arrow := f.property

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance is_thin {X : C} (f g : mono_over X) : subsingleton (f ⟶ g) :=
⟨begin
  intros h₁ h₂,
  ext1,
  erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
end⟩

@[reassoc] lemma w {f g : mono_over X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbreviation hom_mk {f g : mono_over X} (h : f.val.left ⟶ g.val.left) (w : h ≫ g.arrow = f.arrow) :
  f ⟶ g :=
over.hom_mk h w

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def iso_mk {f g : mono_over X} (h : f.val.left ≅ g.val.left) (w : h.hom ≫ g.arrow = f.arrow) :
  f ≅ g :=
{ hom := hom_mk h.hom w,
  inv := hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp] def mk'_arrow_iso {X : C} (f : mono_over X) : (mk' f.arrow) ≅ f :=
iso_mk (iso.refl _) (by simp)

/--
Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  mono_over Y ⥤ mono_over X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (mono_over.forget X).preimage ((mono_over.forget Y ⋙ F).map k), }

/--
Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def lift_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  lift F₁ h₁ ≅ lift F₂ h₂ :=
fully_faithful_cancel_right (mono_over.forget X) (iso_whisker_left (mono_over.forget Y) i)

/-- `mono_over.lift` commutes with composition of functors. -/
def lift_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

/-- `mono_over.lift` preserves the identity functor. -/
def lift_id :
  lift (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

@[simp]
lemma lift_comm (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  lift F h ⋙ mono_over.forget X = mono_over.forget Y ⋙ F :=
rfl

@[simp]
lemma lift_obj_arrow {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) (f : mono_over Y) :
  ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).hom :=
rfl

/--
Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : over A} (h₁ h₂) : mono_over f ≌ mono_over f.left :=
{ functor := mono_over.lift f.iterated_slice_equiv.functor h₁,
  inverse := mono_over.lift f.iterated_slice_equiv.inverse h₂,
  unit_iso := mono_over.lift_id.symm ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫
    (mono_over.lift_comp _ _ _ _).symm,
  counit_iso := mono_over.lift_comp _ _ _ _ ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫
    mono_over.lift_id }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : mono_over Y ⥤ mono_over X :=
mono_over.lift (over.pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
lift_iso _ _ (over.pullback_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullback_id : pullback (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.pullback_id ≪≫ lift_id

@[simp] lemma pullback_obj_left (f : X ⟶ Y) (g : mono_over Y) :
  (((pullback f).obj g) : C) = limits.pullback g.arrow f :=
rfl

@[simp] lemma pullback_obj_arrow (f : X ⟶ Y) (g : mono_over Y) :
  ((pullback f).obj g).arrow = pullback.snd :=
rfl

end pullback

section map

attribute [instance] mono_comp

/--
We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y :=
lift (over.map f)
(λ g, by apply mono_comp g.arrow f)

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  map (f ≫ g) ≅ map f ⋙ map g :=
lift_iso _ _ (over.map_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def map_id : map (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.map_id ≪≫ lift_id

@[simp] lemma map_obj_left (f : X ⟶ Y) [mono f] (g : mono_over X) :
  (((map f).obj g) : C) = g.val.left :=
rfl

@[simp]
lemma map_obj_arrow (f : X ⟶ Y) [mono f] (g : mono_over X) :
  ((map f).obj g).arrow = g.arrow ≫ f :=
rfl

instance full_map (f : X ⟶ Y) [mono f] : full (map f) :=
{ preimage := λ g h e,
  begin
    refine hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply w e,
  end }

instance faithful_map (f : X ⟶ Y) [mono f] : faithful (map f) := {}.

/--
Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps] def map_iso {A B : C} (e : A ≅ B) : mono_over A ≌ mono_over B :=
{ functor := map e.hom,
  inverse := map e.inv,
  unit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id).symm,
  counit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id) }

section
variables (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps] def congr (e : C ≌ D) : mono_over X ≌ mono_over (e.functor.obj X) :=
{ functor := lift (over.post e.functor) $ λ f, by { dsimp, apply_instance },
  inverse := (lift (over.post e.inverse) $ λ f, by { dsimp, apply_instance })
    ⋙ (map_iso (e.unit_iso.symm.app X)).functor,
  unit_iso := nat_iso.of_components (λ Y, iso_mk (e.unit_iso.app Y) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ Y, iso_mk (e.counit_iso.app Y) (by tidy)) (by tidy) }

end

section
variable [has_pullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def map_pullback_adj (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
adjunction.restrict_fully_faithful
  (forget X) (forget Y) (over.map_pullback_adj f) (iso.refl _) (iso.refl _)

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullback_map_self (f : X ⟶ Y) [mono f] :
  map f ⋙ pullback f ≅ 𝟭 _ :=
(as_iso (mono_over.map_pullback_adj f).unit).symm

end

end map

section image
variables (f : X ⟶ Y) [has_image f]

/--
The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def image_mono_over (f : X ⟶ Y) [has_image f] : mono_over Y := mono_over.mk' (image.ι f)

@[simp] lemma image_mono_over_arrow (f : X ⟶ Y) [has_image f] :
  (image_mono_over f).arrow = image.ι f :=
rfl

end image

section image

variables [has_images C]

/--
Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : over X ⥤ mono_over X :=
{ obj := λ f, image_mono_over f.hom,
  map := λ f g k,
  begin
    apply (forget X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

/--
`mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def image_forget_adj : image ⊣ forget X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.val.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance : is_right_adjoint (forget X) :=
{ left := image, adj := image_forget_adj }

instance reflective : reflective (forget X) := {}.

/--
Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forget_image : forget X ⋙ image ≅ 𝟭 (mono_over X) :=
as_iso (adjunction.counit image_forget_adj)

end image

section «exists»
variables [has_images C]

/--
In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def «exists» (f : X ⟶ Y) : mono_over X ⥤ mono_over Y :=
forget _ ⋙ over.map f ⋙ image

instance faithful_exists (f : X ⟶ Y) : faithful («exists» f) := {}.

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f ≅ map f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget _).obj ((«exists» f).obj Z) ≅ (forget _).obj ((map f).obj Z),
    apply preimage_iso this,
  apply over.iso_mk _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- `exists` is adjoint to `pullback` when images exist -/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
adjunction.restrict_fully_faithful (forget X) (𝟭 _)
  ((over.map_pullback_adj f).comp _ _ image_forget_adj)
  (iso.refl _)
  (iso.refl _)

end «exists»

end mono_over

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.concrete_category.basic
import tactic.fresh_names
import tactic.reassoc_axiom
import tactic.slice

/-!
# Tools to reformulate category-theoretic lemmas in concrete categories

## The `elementwise` attribute

The `elementwise` attribute can be applied to a lemma

```lean
@[elementwise]
lemma some_lemma {C : Type*} [category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) : f ≫ g = h := ...
```

and will produce

```lean
lemma some_lemma_apply {C : Type*} [category C] [concrete_category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) (x : X) : g (f x) = h x := ...
```

Here `X` is being coerced to a type via `concrete_category.has_coe_to_sort` and
`f`, `g`, and `h` are being coerced to functions via `concrete_category.has_coe_to_fun`.
Further, we simplify the type using `concrete_category.coe_id : ((𝟙 X) : X → X) x = x` and
`concrete_category.coe_comp : (f ≫ g) x = g (f x)`,
replacing morphism composition with function composition.

The name of the produced lemma can be specified with `@[elementwise other_lemma_name]`.
If `simp` is added first, the generated lemma will also have the `simp` attribute.

## Implementation

This closely follows the implementation of the `@[reassoc]` attribute, due to Simon Hudon.
Thanks to Gabriel Ebner for help diagnosing universe issues.

-/

namespace tactic

open interactive lean.parser category_theory

/--
From an expression `f = g`,
where `f g : X ⟶ Y` for some objects `X Y : V` with `[S : category V]`,
extract the expression for `S`.
-/
meta def extract_category : expr → tactic expr
| `(@eq (@quiver.hom ._ (@category_struct.to_quiver _
     (@category.to_category_struct _ %%S)) _ _) _ _) := pure S
| _ := failed

/-- (internals for `@[elementwise]`)
Given a lemma of the form `f = g`, where `f g : X ⟶ Y` and `X Y : V`,
proves a new lemma of the form
`∀ (x : X), f x = g x`
if we are already in a concrete category, or
`∀ [concrete_category.{w} V] (x : X), f x = g x`
otherwise.

Returns the type and proof of this lemma,
and the universe parameter `w` for the `concrete_category` instance, if it was not synthesized.
-/
-- This is closely modelled on `reassoc_axiom`.
meta def prove_elementwise (h : expr) : tactic (expr × expr × option name) :=
do
   (vs,t) ← infer_type h >>= open_pis,
   (f, g) ← match_eq t,
   S ← extract_category t <|> fail "no morphism equation found in statement",
   `(@quiver.hom _ %%H %%X %%Y) ← infer_type f,
   C ← infer_type X,
   CC_type ← to_expr ``(@concrete_category %%C %%S),
   (CC, CC_found) ← (do CC ← mk_instance CC_type, pure (CC, tt)) <|>
     (do CC ← mk_local' `I binder_info.inst_implicit CC_type, pure (CC, ff)),
   -- This is need to fill in universe levels fixed by `mk_instance`:
   CC_type ← instantiate_mvars CC_type,
   x_type ← to_expr ``(@coe_sort %%C _
     (@category_theory.concrete_category.has_coe_to_sort %%C %%S %%CC) %%X),
   x ← mk_local_def `x x_type,
   t' ← to_expr ``(@coe_fn (@quiver.hom %%C %%H %%X %%Y) _
     (@category_theory.concrete_category.has_coe_to_fun %%C %%S %%CC %%X %%Y) %%f %%x =
       @coe_fn (@quiver.hom %%C %%H %%X %%Y) _
         (@category_theory.concrete_category.has_coe_to_fun %%C %%S %%CC %%X %%Y) %%g %%x),
   let c' := h.mk_app vs,
   (_,pr) ← solve_aux t' (rewrite_target c'; reflexivity),
   -- The codomain of forget lives in a new universe, which may be now a universe metavariable
   -- if we didn't synthesize an instance:
   [w, _, _] ← pure CC_type.get_app_fn.univ_levels,
   -- We unify that with a fresh universe parameter.
   n ← match w with
   | level.mvar _ := (do
      n ← get_unused_name_reserved [`w] mk_name_set,
      unify (expr.sort (level.param n)) (expr.sort w),
      pure (option.some n))
   | _ := pure option.none
   end,
   t' ← instantiate_mvars t',
   CC ← instantiate_mvars CC,
   x ← instantiate_mvars x,
   -- Now the key step: replace morphism composition with function composition,
   -- and identity morphisms with nothing.
   let s := simp_lemmas.mk,
   s ← s.add_simp ``id_apply,
   s ← s.add_simp ``comp_apply,
   (t'', pr', _) ← simplify s [] t' {fail_if_unchanged := ff},
   pr' ← mk_eq_mp pr' pr,
   -- Further, if we're in `Type`, get rid of the coercions entirely.
   let s := simp_lemmas.mk,
   s ← s.add_simp ``concrete_category.has_coe_to_fun_Type,
   (t'', pr'', _) ← simplify s [] t'' {fail_if_unchanged := ff},
   pr'' ← mk_eq_mp pr'' pr',
   t'' ← pis (vs ++ (if CC_found then [x] else [CC, x])) t'',
   pr'' ← lambdas (vs ++ (if CC_found then [x] else [CC, x])) pr'',
   pure (t'', pr'', n)

/-- (implementation for `@[elementwise]`)
Given a declaration named `n` of the form `∀ ..., f = g`, proves a new lemma named `n'`
of the form `∀ ... [concrete_category V] (x : X), f x = g x`.
-/
meta def elementwise_lemma (n : name) (n' : name := n.append_suffix "_apply") : tactic unit :=
do d ← get_decl n,
   let c := @expr.const tt n d.univ_levels,
   (t'',pr',l') ← prove_elementwise c,
   let params := l'.to_list ++ d.univ_params,
   add_decl $ declaration.thm n' params t'' (pure pr'),
   copy_attribute `simp n n'

/--
The `elementwise` attribute can be applied to a lemma

```lean
@[elementwise]
lemma some_lemma {C : Type*} [category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) : f ≫ g = h := ...
```

and will produce

```lean
lemma some_lemma_apply {C : Type*} [category C] [concrete_category C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : X ⟶ Z) (w : ...) (x : X) : g (f x) = h x := ...
```

Here `X` is being coerced to a type via `concrete_category.has_coe_to_sort` and
`f`, `g`, and `h` are being coerced to functions via `concrete_category.has_coe_to_fun`.
Further, we simplify the type using `concrete_category.coe_id : ((𝟙 X) : X → X) x = x` and
`concrete_category.coe_comp : (f ≫ g) x = g (f x)`,
replacing morphism composition with function composition.

The `[concrete_category C]` argument will be omitted if it is possible to synthesize an instance.

The name of the produced lemma can be specified with `@[elementwise other_lemma_name]`.
If `simp` is added first, the generated lemma will also have the `simp` attribute.
-/
@[user_attribute]
meta def elementwise_attr : user_attribute unit (option name) :=
{ name := `elementwise,
  descr := "create a companion lemma for a morphism equation applied to an element",
  parser := optional ident,
  after_set := some (λ n _ _,
    do some n' ← elementwise_attr.get_param n | elementwise_lemma n (n.append_suffix "_apply"),
       elementwise_lemma n $ n.get_prefix ++ n' ) }

add_tactic_doc
{ name                     := "elementwise",
  category                 := doc_category.attr,
  decl_names               := [`tactic.elementwise_attr],
  tags                     := ["category theory"] }

namespace interactive

setup_tactic_parser

/--
`elementwise h`, for assumption `w : ∀ ..., f ≫ g = h`, creates a new assumption
`w : ∀ ... (x : X), g (f x) = h x`.

`elementwise! h`, does the same but deletes the initial `h` assumption.
(You can also add the attribute `@[elementwise]` to lemmas to generate new declarations generalized
in this way.)
-/
meta def elementwise (del : parse (tk "!")?) (ns : parse ident*) : tactic unit :=
do ns.mmap' (λ n,
   do h ← get_local n,
      (t,pr,u) ← prove_elementwise h,
      assertv n t pr,
      when del.is_some (tactic.clear h) )

end interactive

/-- Auxiliary definition for `category_theory.elementwise_of`. -/
meta def derive_elementwise_proof : tactic unit :=
do `(calculated_Prop %%v %%h) ← target,
   (t,pr,n) ← prove_elementwise h,
   unify v t,
   exact pr

end tactic

/--
With `w : ∀ ..., f ≫ g = h` (with universal quantifiers tolerated),
`elementwise_of w : ∀ ... (x : X), g (f x) = h x`.

The type and proof of `elementwise_of h` is generated by `tactic.derive_elementwise_proof`
which makes `elementwise_of` meta-programming adjacent. It is not called as a tactic but as
an expression. The goal is to avoid creating assumptions that are dismissed after one use:

```lean
example (M N K : Mon.{u}) (f : M ⟶ N) (g : N ⟶ K) (h : M ⟶ K) (w : f ≫ g = h) (m : M) :
  g (f m) = h m :=
begin
  rw elementwise_of w,
end
```
-/
theorem category_theory.elementwise_of {α} (hh : α) {β}
  (x : tactic.calculated_Prop β hh . tactic.derive_elementwise_proof) : β := x

/--
With `w : ∀ ..., f ≫ g = h` (with universal quantifiers tolerated),
`elementwise_of w : ∀ ... (x : X), g (f x) = h x`.

Although `elementwise_of` is not a tactic or a meta program, its type is generated
through meta-programming to make it usable inside normal expressions.
-/
add_tactic_doc
{ name                     := "category_theory.elementwise_of",
  category                 := doc_category.tactic,
  decl_names               := [`category_theory.elementwise_of],
  tags                     := ["category theory"] }


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

import ProofChecker.Data.ICnf
import ProofChecker.Data.Pog
import ProofChecker.Model.PropVars
import ProofChecker.Model.Extensions
import ProofChecker.Count.PropForm

/-! Justifications of CPOG steps. -/

open PropTerm

theorem addDisj_new_var_equiv {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm Var) :
    s ∉ A → X ⊆ A → ↑Γ.semVars ⊆ A → ↑l₁.semVars ⊆ A → ↑l₂.semVars ⊆ A →
    equivalentOver X (l₁ ⊓ Γ) φ₁ → equivalentOver X (l₂ ⊓ Γ) φ₂ →
    equivalentOver X (.var s ⊓ Γ ⊓ (.biImpl (.var s) (l₁ ⊔ l₂))) (φ₁ ⊔ φ₂) := by
  intro hNMem hXA hΓ hL₁ hL₂ e₁ e₂ τ
  have hMem : s ∉ X := fun h => absurd (hXA h) hNMem
  have hΓ : s ∉ Γ.semVars := fun h => absurd (hΓ h) hNMem
  have hL₁ : s ∉ l₁.semVars := fun h => absurd (hL₁ h) hNMem
  have hL₂ : s ∉ l₂.semVars := fun h => absurd (hL₂ h) hNMem
  constructor
  case mp =>
    intro ⟨σ₁, hAgree, h₁⟩
    simp at h₁
    have : σ₁ ⊨ Γ := by tauto
    have : σ₁ ⊨ l₁ ⊔ l₂ := by simp; tauto
    cases satisfies_disj.mp this with
    | inl h =>
      have : σ₁ ⊨ l₁ ⊓ Γ := by simp; tauto
      have ⟨σ₂, hAgree₂, h₂⟩ := e₁ τ |>.mp ⟨σ₁, hAgree, this⟩
      exact ⟨σ₂, hAgree₂, satisfies_disj.mpr (.inl h₂)⟩
    | inr h =>
      have : σ₁ ⊨ l₂ ⊓ Γ := by simp; tauto
      have ⟨σ₂, hAgree₂, h₂⟩ := e₂ τ |>.mp ⟨σ₁, hAgree, this⟩
      exact ⟨σ₂, hAgree₂, satisfies_disj.mpr (.inr h₂)⟩
  case mpr =>
    intro ⟨σ₂, hAgree, h₂⟩
    cases satisfies_disj.mp h₂ with
    | inl h =>
      have ⟨σ₁, hAgree₁, h₁⟩ := e₁ τ |>.mpr ⟨σ₂, hAgree, h⟩
      let σ₁' := σ₁.set s ⊤
      have : σ₁' ⊨ .var s := by simp
      have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem
      have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁
      have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr
        (satisfies_conj.mp h₁).right
      have : σ₁' ⊨ l₁ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₁) |>.mpr
        (satisfies_conj.mp h₁).left
      exact ⟨σ₁', by assumption, by simp; tauto⟩
    | inr h =>
      have ⟨σ₁, hAgree₁, h₁⟩ := e₂ τ |>.mpr ⟨σ₂, hAgree, h⟩
      let σ₁' := σ₁.set s true
      have : σ₁' ⊨ .var s := by simp
      have hAgree₁' : σ₁'.agreeOn X σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem
      have : σ₁'.agreeOn X τ := hAgree₁'.trans hAgree₁
      have : σ₁' ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr
        (satisfies_conj.mp h₁).right
      have : σ₁' ⊨ l₂ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₂) |>.mpr
        (satisfies_conj.mp h₁).left
      exact ⟨σ₁', by assumption, by simp; tauto⟩

theorem addDisj_partitioned {A : Set Var} (Γ l₁ l₂ : PropTerm Var) (φ₁ φ₂ : PropForm Var) :
    -- Note: also works with l₁.semVars ⊆ A
    ↑l₂.semVars ⊆ A → hasUniqueExtension X A Γ →
    Γ ⊓ l₁ ⊓ l₂ ≤ ⊥ → equivalentOver X (l₁ ⊓ Γ) ⟦φ₁⟧ → equivalentOver X (l₂ ⊓ Γ) ⟦φ₂⟧ →
    φ₁.partitioned → φ₂.partitioned → (φ₁.disj φ₂).partitioned := by
  intro hL₂ hUep hImp e₁ e₂ hD₁ hD₂
  refine ⟨hD₁, hD₂, fun τ ⟨h₁, h₂⟩ => ?_⟩
  have h₁ : τ ⊨ ⟦φ₁⟧ := h₁
  have h₂ : τ ⊨ ⟦φ₂⟧ := h₂
  have ⟨σ₁, hAgree₁, hσ₁⟩ := e₁ τ |>.mpr ⟨τ, PropAssignment.agreeOn_refl _ _, h₁⟩
  have ⟨σ₂, hAgree₂, hσ₂⟩ := e₂ τ |>.mpr ⟨τ, PropAssignment.agreeOn_refl _ _, h₂⟩
  simp at hσ₁ hσ₂
  have hσ₁Γ : σ₁ ⊨ Γ := by tauto
  have hσ₂Γ : σ₂ ⊨ Γ := by tauto
  have hAgree : σ₁.agreeOn A σ₂ := hUep hσ₁Γ hσ₂Γ (hAgree₁.trans hAgree₂.symm)
  have : σ₂ ⊨ l₂ := by tauto
  have : σ₁ ⊨ l₂ := agreeOn_semVars (hAgree.subset hL₂) |>.mpr this
  have : σ₁ ⊨ ⊥ := entails_ext.mp hImp _ (by simp; tauto)
  simp at this

-- Alternative: use disjoint variables condition on φ₁/φ₂ to put together pair of assignments?!
theorem addConj_new_var_equiv₂ {A : Set Var} (Γ l₁ l₂ φ₁ φ₂ : PropTerm Var) :
    -- Note: also works with φ₁.semVars ⊆ X
    p ∉ X → p ∉ Γ.semVars → p ∉ l₁.semVars → p ∉ l₂.semVars → φ₂.semVars ⊆ X →
    -- Note: also works with l₁.semVars ⊆ A
    ↑l₂.semVars ⊆ A → hasUniqueExtension X A Γ →
    equivalentOver X (l₁ ⊓ Γ) φ₁ → equivalentOver X (l₂ ⊓ Γ) φ₂ →
    equivalentOver X (.var p ⊓ (.biImpl (.var p) (l₁ ⊓ l₂)) ⊓ Γ) (φ₁ ⊓ φ₂) := by
  intro hMem hΓ hL₁ hL₂ hφ₂ hL₂Γ hUep e₁ e₂ τ
  constructor
  case mp =>
    intro ⟨σ₁, hAgree, h₁⟩
    simp at h₁
    have ⟨σ₂, hAgree₂, h₂⟩ := e₁ τ |>.mp ⟨σ₁, hAgree, by simp; tauto⟩
    have ⟨σ₂', hAgree₂', h₂'⟩ := e₂ τ |>.mp ⟨σ₁, hAgree, by simp; tauto⟩
    have : σ₂.agreeOn X σ₂' := hAgree₂.trans hAgree₂'.symm
    have : σ₂ ⊨ φ₂ := agreeOn_semVars (this.subset hφ₂) |>.mpr h₂'
    exact ⟨σ₂, hAgree₂, by simp; tauto⟩
  case mpr =>
    intro ⟨σ₂, hAgree, h₂⟩
    simp at h₂
    have ⟨σ₁, hAgree₁, h₁⟩ := e₁ τ |>.mpr ⟨σ₂, hAgree, by tauto⟩
    have ⟨σ₁', hAgree₁', h₁'⟩ := e₂ τ |>.mpr ⟨σ₂, hAgree, by tauto⟩
    simp at h₁ h₁'
    have hσ₁Γ : σ₁ ⊨ Γ := by tauto
    have hσ₁'Γ : σ₁' ⊨ Γ := by tauto
    have hAgree₁₁' : σ₁.agreeOn A σ₁' := hUep hσ₁Γ hσ₁'Γ (hAgree₁.trans hAgree₁'.symm)
    have : σ₁ ⊨ l₂ := agreeOn_semVars (hAgree₁₁'.subset hL₂Γ) |>.mpr (by tauto)
    let σ₃ := σ₁.set p true
    have : σ₃ ⊨ .var p := by simp
    have : σ₃ ⊨ l₁ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₁) |>.mpr (by tauto)
    have : σ₃ ⊨ l₂ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hL₂) |>.mpr (by tauto)
    have : σ₃ ⊨ Γ := agreeOn_semVars (σ₁.agreeOn_set_of_not_mem _ hΓ) |>.mpr (by tauto)
    exact ⟨σ₃, σ₁.agreeOn_set_of_not_mem _ hMem |>.trans hAgree₁, by simp; tauto⟩

theorem addConj_new_var_equiv {A : Set Var} (G : Pog) (Γ : PropTerm Var) (ls : Array ILit) :
    p ∉ A → X ⊆ A → ↑Γ.semVars ⊆ A → hasUniqueExtension X A Γ →
    (∀ σ₁, ∃ (σ₂ : PropAssignment Var), σ₂.agreeOn X σ₁ ∧ σ₂ ⊨ Γ) →
    (∀ l ∈ ls.data, l.var ∈ A ∧ ↑(PropTerm.semVars ⟦G.toPropForm l⟧) ⊆ X ∧
      equivalentOver X (l.toPropTerm ⊓ Γ) ⟦G.toPropForm l⟧) →
    equivalentOver X
      (.var p ⊓ (Γ ⊓ .biImpl (.var p) ⟦PropForm.arrayConj (ls.map ILit.toPropForm)⟧))
      ⟦PropForm.arrayConj (ls.map G.toPropForm)⟧ := by
  intro hMem hX hΓ hUep hExt hLs τ
  refine ⟨?mp, ?mpr⟩ <;>
    simp only [PropForm.mk_arrayConj, satisfies_conj, satisfies_biImpl,
      PropForm.satisfies_arrayConjTerm, Array.map_data, List.mem_map', and_imp,
      forall_apply_eq_imp_iff₂, forall_exists_index, ILit.mk_toPropForm]
  case mp =>
    intro σ₁ hAgree hσ₁p hσ₁Γ hσ₁
    simp only [hσ₁p, true_iff, ILit.mk_toPropForm] at hσ₁
    refine ⟨σ₁, hAgree, ?_⟩
    intro l hL
    have ⟨_, hTpf, hEquiv⟩ := hLs l hL
    have : σ₁ ⊨ l.toPropTerm := hσ₁ l hL
    have : σ₁ ⊨ l.toPropTerm ⊓ Γ := by simp [this, hσ₁Γ]
    have ⟨σ₂, hAgree₂, hσ₂⟩ := hEquiv τ |>.mp ⟨σ₁, hAgree, this⟩
    apply agreeOn_semVars ?_ |>.mp hσ₂
    exact (hAgree₂.trans hAgree.symm).subset hTpf
  case mpr =>
    intro σ₂ hAgree₂ hTpfs
    have ⟨σ₁, hAgree₁, h₁⟩ := hExt τ
    let σ₁' := σ₁.set p true
    have hσ₁'p : σ₁' ⊨ .var p := by simp
    have hAgree₁'A : σ₁'.agreeOn A σ₁ := σ₁.agreeOn_set_of_not_mem _ hMem
    have hAgree₁' : σ₁'.agreeOn X τ := hAgree₁'A.subset hX |>.trans hAgree₁
    have hσ₁'Γ : σ₁' ⊨ Γ := agreeOn_semVars (hAgree₁'A.subset hΓ) |>.mpr h₁
    refine ⟨σ₁', hAgree₁', hσ₁'p, hσ₁'Γ, ⟨fun _ => ?_, fun _ => hσ₁'p⟩⟩
    intro l hL
    have : σ₂ ⊨ ⟦G.toPropForm l⟧ := hTpfs l hL
    have ⟨σ₃, hAgree₃, h₃⟩ := (hLs l hL).right.right τ |>.mpr ⟨σ₂, hAgree₂, this⟩
    refine agreeOn_semVars ?_ |>.mp (satisfies_conj.mp h₃).left
    have : ↑l.toPropTerm.semVars ⊆ A := by simp [(hLs l hL).left]
    apply PropAssignment.agreeOn.subset this
    exact hUep (satisfies_conj.mp h₃).right hσ₁'Γ (hAgree₃.trans hAgree₁'.symm)

/-! Other stuff that doesn't fit anywhere. -/

theorem partitioned_lit (l : ILit) : l.toPropForm.partitioned := by
  dsimp [ILit.toPropForm]
  cases l.polarity <;> simp [PropForm.partitioned]


import phase2.flexible

/-!
# Reductions of supports
-/

universe u

open mul_action quiver set sum with_bot
open_locale cardinal

namespace con_nf
variables [params.{u}] (α : Λ) [position_data.{}] [phase_2_assumptions α]

variables (β : Λ) (G : Type*) {τ : Type*} [has_smul G (support_condition β)] [has_smul G τ]

variables {β G} {x : τ}

/-- A support condition is *reduced* if it is an atom or a litter. -/
@[mk_iff] inductive reduced {β : type_index} : support_condition β → Prop
| mk_atom (a : atom) (B : extended_index β) : reduced (inl a, B)
| mk_litter (L : litter) (B : extended_index β) : reduced (inr L.to_near_litter, B)

/-- The *reduction* of a set of support conditions is the downward closure of the set under
the constrains relation, but we only keep reduced conditions. -/
def reduction (S : set (support_condition β)) : set (support_condition β) :=
{c | ∃ d ∈ S, relation.refl_trans_gen (constrains α β) c d} ∩ set_of reduced

lemma reduction_singleton (c : support_condition β) :
  reduction α {c} = ({c} ∪ {d | relation.trans_gen (constrains α β) d c}) ∩ set_of reduced :=
by simp only [reduction, mem_singleton_iff, exists_prop, exists_eq_left,
  relation.refl_trans_gen_iff_eq_or_trans_gen, set_of_or, set_of_eq_eq_singleton']

lemma reduction_singleton_of_not_reduced (c : support_condition β) (hc : ¬reduced c) :
  reduction α {c} = {d | relation.trans_gen (constrains α β) d c} ∩ {d | reduced d} :=
begin
  simp only [reduction_singleton, inter_distrib_right, union_eq_right_iff_subset,
    subset_inter_iff, inter_subset_right, and_true],
  rintros d ⟨hd, hd'⟩,
  cases hd,
  cases hc hd',
end

lemma small_constrains (c : support_condition β) : small {d | d ≺[α] c} :=
begin
  obtain ⟨a | N, A⟩ := c,
  { simp only [constrains_atom, set_of_eq_eq_singleton, small_singleton], },
  simp_rw constrains_iff,
  refine small.union _ (small.union _ (small.union _ (small.union _ _)));
    rw small_set_of,
  { simp only [prod.mk.inj_iff, false_and, and_false,
      exists_false, set_of_false, small_empty], },
  { simp only [ne.def, prod.mk.inj_iff, exists_eq_right_right'],
    by_cases litter_set N.fst = N.snd,
    simp only [h, eq_self_iff_true, not_true, false_and, set_of_false, small_empty],
    simp only [h, not_false_iff, true_and, set_of_eq_eq_singleton, small_singleton], },
  { simp only [prod.mk.inj_iff, exists_eq_right_right'],
    have : small {c : support_condition β | ∃ a, a ∈ litter_set N.fst ∆ N.snd ∧ c = (inl a, A)},
    { refine lt_of_le_of_lt _ N.2.prop,
      refine ⟨⟨λ c, ⟨_, c.2.some_spec.1⟩, _⟩⟩,
      rintros ⟨c, hc⟩ ⟨d, hd⟩,
      simp only [subtype.val_eq_coe, subtype.mk_eq_mk],
      intro h,
      rw [hc.some_spec.2, hd.some_spec.2, h], },
    convert this using 1,
    ext ⟨a | N, A⟩ : 1,
    { simp only [mem_set_of_eq, prod.mk.inj_iff],
      split,
      { rintro ⟨_, a', h₁, h₂, rfl⟩,
        exact ⟨a', h₁, h₂⟩, },
      { rintro ⟨a', h₁, h₂⟩,
        exact ⟨N, a', h₁, h₂, rfl⟩, } },
    { simp only [mem_set_of_eq, prod.mk.inj_iff, false_and, and_false, exists_false], }, },
  { by_cases ∃ ⦃γ : Iic α⦄ ⦃δ : Iio α⦄ ⦃ε : Iio α⦄ (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ)
      (hδε : δ ≠ ε) (B : path (β : type_index) γ) (t : tangle δ),
      N = (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter ∧
      A = (B.cons (coe_lt hε)).cons (bot_lt_coe _),
    { obtain ⟨γ, δ, ε, hδ, hε, hδε, B, t, rfl, rfl⟩ := h,
      refine lt_of_le_of_lt _ (designated_support t).small,
      suffices : #{a : support_condition β | ∃ c : designated_support t,
        a = ⟨c.val.fst, (B.cons (coe_lt hδ)).comp c.val.snd⟩} ≤ #(designated_support t),
      { refine le_trans (cardinal.mk_subtype_le_of_subset _) this,
        rintros x ⟨_, _, _, _, _, _, _, _, c, hc, rfl, h⟩,
        simp only [prod.mk.inj_iff, litter.to_near_litter_injective.eq_iff, f_map] at h,
        cases subtype.coe_inj.mp (coe_inj.mp h.1.2.1),
        cases subtype.coe_inj.mp h.1.2.2,
        cases choose_wf_injective h.1.1,
        cases subtype.coe_inj.mp (coe_inj.mp
          (path.obj_eq_of_cons_eq_cons (path.heq_of_cons_eq_cons h.2).eq)),
        cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons h.2).eq).eq,
        exact ⟨⟨c, hc⟩, rfl⟩, },
      refine ⟨⟨λ a, a.prop.some, _⟩⟩,
      intros a b h,
      refine subtype.coe_inj.mp _,
      simp only [subtype.val_eq_coe] at h,
      rw [a.prop.some_spec, b.prop.some_spec],
      simp only [h, subtype.val_eq_coe], },
    { refine small_of_forall_not_mem _,
      rintro x ⟨γ, δ, ε, hδ, hε, hδε, B, t, c, hN, rfl, hA⟩,
      simp only [prod.mk.inj_iff] at hA,
      refine h ⟨γ, δ, ε, hδ, hε, hδε, B, t, hA⟩, }, },
  { refine subsingleton.small _,
    rintros ⟨c, C⟩ ⟨γ, ε, hε, C', a, hc₁, hc₂⟩ ⟨d, D⟩ ⟨γ, ε, hε, D', b, hd₁, hd₂⟩,
    simp only [prod.mk.inj_iff] at hc₁ hc₂ hd₁ hd₂,
    rw [hc₁.1, hc₁.2, hd₁.1, hd₁.2],
    rw [hc₂.1, hc₂.2, litter.to_near_litter_injective.eq_iff] at hd₂,
    cases subtype.coe_inj.mp (coe_inj.mp (path.obj_eq_of_cons_eq_cons hd₂.2)),
    cases subtype.coe_inj.mp (coe_inj.mp (path.obj_eq_of_cons_eq_cons
      (path.heq_of_cons_eq_cons hd₂.2).eq)),
    cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons hd₂.2).eq).eq,
    rw (f_map_injective bot_ne_coe).eq_iff at hd₂,
    cases hd₂.1,
    refl, },
end

def nth_reduction (S : set (support_condition β)) : ℕ → set (support_condition β)
| 0 := S
| (n + 1) := {c | ∃ d, d ∈ nth_reduction n ∧ c ≺[α] d}

lemma small_nth_reduction {S : set (support_condition β)} {n : ℕ} (h : small S) :
  small (nth_reduction α S n) :=
begin
  induction n with n hn,
  exact h,
  rw nth_reduction,
  simp_rw [← exists_prop, subtype.exists', set_of_exists],
  refine small_Union hn _,
  rintro ⟨c, hc⟩,
  exact small_constrains α c,
end

lemma mem_nth_reduction_iff {S : set (support_condition β)} {n : ℕ}
  {c : support_condition β} :
  c ∈ nth_reduction α S n ↔
  ∃ l, list.chain (constrains α β) c l ∧ l.length = n ∧ (c :: l).last (list.cons_ne_nil _ _) ∈ S :=
begin
  induction n with n hn generalizing c,
  { rw nth_reduction,
    split,
    { intro h,
      exact ⟨[], list.chain.nil, rfl, h⟩, },
    { rintro ⟨l, h₁, h₂, h₃⟩,
      rw list.length_eq_zero at h₂,
      cases h₂,
      exact h₃, }, },
  { simp only [nth_reduction, mem_set_of_eq],
    split,
    { rintro ⟨d, hd₁, hd₂⟩,
      obtain ⟨l, hl₁, hl₂, hl₃⟩ := hn.mp hd₁,
      refine ⟨d :: l, list.chain.cons hd₂ hl₁, _, _⟩,
      { rw [list.length_cons, hl₂], },
      { rw list.last_cons,
        exact hl₃, }, },
    { rintro ⟨_ | ⟨d, l⟩, hl₁, hl₂, hl₃⟩,
      { cases hl₂, },
      obtain _ | ⟨hcd, hl₁⟩ := hl₁,
      rw list.last_cons at hl₃,
      have := hn.mpr ⟨l, hl₁, nat.succ.inj hl₂, hl₃⟩,
      exact ⟨d, this, hcd⟩, }, },
end

lemma reduction_eq_Union {S : set (support_condition β)} :
  {c | ∃ d ∈ S, relation.refl_trans_gen (constrains α β) c d} = ⋃ n, nth_reduction α S n :=
begin
  refine subset_antisymm _ _,
  { rintros c ⟨d, hdS, hd⟩,
    obtain ⟨l, hl, rfl⟩ := list.exists_chain_of_relation_refl_trans_gen hd,
    rw mem_Union,
    refine ⟨l.length, _⟩,
    rw mem_nth_reduction_iff,
    refine ⟨l, hl, rfl, hdS⟩, },
  { intros c hc,
    rw mem_Union at hc,
    obtain ⟨i, hc⟩ := hc,
    rw mem_nth_reduction_iff at hc,
    obtain ⟨l, hl₁, hl₂, hl₃⟩ := hc,
    exact ⟨(c :: l).last (list.cons_ne_nil _ _), hl₃,
      list.relation_refl_trans_gen_of_exists_chain l hl₁ rfl⟩, },
end

lemma reduction_small' {S : set (support_condition β)} (h : small S) :
  small {c | ∃ d ∈ S, relation.refl_trans_gen (constrains α β) c d} :=
begin
  rw reduction_eq_Union,
  have : small ⋃ (n : ulift ℕ), nth_reduction α S n.down,
  { refine small_Union _ (λ _, small_nth_reduction α h),
    rw cardinal.mk_denumerable,
    exact Λ_limit.aleph_0_le.trans_lt Λ_lt_κ, },
  { convert this using 1,
    ext x : 1,
    simp only [mem_Union, ulift.exists], },
end

lemma reduction_small {S : set (support_condition β)} (h : small S) :
  small (reduction α S) :=
lt_of_le_of_lt (cardinal.mk_subtype_le_of_subset (λ c hc, hc.1)) (reduction_small' α h)

end con_nf