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

/-!
# Category instances for group, add_group, comm_group, and add_comm_group.

We introduce the bundled categories:
* `Group`
* `AddGroup`
* `CommGroup`
* `AddCommGroup`
along with the relevant forgetful functors between them, and to the bundled monoid categories.
-/

universes u v

open category_theory

/-- The category of groups and group morphisms. -/
@[to_additive AddGroup]
def Group : Type (u+1) := bundled group

/-- The category of additive groups and group morphisms -/
add_decl_doc AddGroup

namespace Group

@[to_additive]
instance : bundled_hom.parent_projection group.to_monoid := ⟨⟩

attribute [derive [large_category, concrete_category]] Group
attribute [to_additive] Group.large_category Group.concrete_category

@[to_additive] instance : has_coe_to_sort Group Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Group` from the underlying type and typeclass. -/
@[to_additive] def of (X : Type u) [group X] : Group := bundled.of X

/-- Construct a bundled `AddGroup` from the underlying type and typeclass. -/
add_decl_doc AddGroup.of

/-- Typecheck a `monoid_hom` as a morphism in `Group`. -/
@[to_additive] def of_hom {X Y : Type u} [group X] [group Y] (f : X →* Y) : of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddGroup`. -/
add_decl_doc AddGroup.of_hom

@[simp, to_additive] lemma of_hom_apply {X Y : Type*} [group X] [group Y] (f : X →* Y) (x : X) :
  of_hom f x = f x := rfl

@[to_additive]
instance (G : Group) : group G := G.str

@[simp, to_additive] lemma coe_of (R : Type u) [group R] : (Group.of R : Type u) = R := rfl

@[to_additive]
instance : inhabited Group := ⟨Group.of punit⟩

@[to_additive]
instance of_unique (G : Type*) [group G] [i : unique G] : unique (Group.of G) := i

@[simp, to_additive]
lemma one_apply (G H : Group) (g : G) : (1 : G ⟶ H) g = 1 := rfl

@[ext, to_additive]

@[to_additive has_forget_to_AddMon]
instance has_forget_to_Mon : has_forget₂ Group Mon := bundled_hom.forget₂ _ _

@[to_additive] instance : has_coe Group.{u} Mon.{u} :=
{ coe := (forget₂ Group Mon).obj, }

end Group

/-- The category of commutative groups and group morphisms. -/
@[to_additive AddCommGroup]
def CommGroup : Type (u+1) := bundled comm_group

/-- The category of additive commutative groups and group morphisms. -/
add_decl_doc AddCommGroup

/-- `Ab` is an abbreviation for `AddCommGroup`, for the sake of mathematicians' sanity. -/
abbreviation Ab := AddCommGroup

namespace CommGroup

@[to_additive]
instance : bundled_hom.parent_projection comm_group.to_group := ⟨⟩

attribute [derive [large_category, concrete_category]] CommGroup
attribute [to_additive] CommGroup.large_category CommGroup.concrete_category

@[to_additive] instance : has_coe_to_sort CommGroup Type* := bundled.has_coe_to_sort

/-- Construct a bundled `CommGroup` from the underlying type and typeclass. -/
@[to_additive] def of (G : Type u) [comm_group G] : CommGroup := bundled.of G

/-- Construct a bundled `AddCommGroup` from the underlying type and typeclass. -/
add_decl_doc AddCommGroup.of

/-- Typecheck a `monoid_hom` as a morphism in `CommGroup`. -/
@[to_additive] def of_hom {X Y : Type u} [comm_group X] [comm_group Y] (f : X →* Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddCommGroup`. -/
add_decl_doc AddCommGroup.of_hom

@[simp, to_additive] lemma of_hom_apply {X Y : Type*} [comm_group X] [comm_group Y] (f : X →* Y)
  (x : X) : of_hom f x = f x := rfl

@[to_additive]
instance comm_group_instance (G : CommGroup) : comm_group G := G.str

@[simp, to_additive] lemma coe_of (R : Type u) [comm_group R] : (CommGroup.of R : Type u) = R := rfl

@[to_additive]
instance : inhabited CommGroup := ⟨CommGroup.of punit⟩

@[to_additive]
instance of_unique (G : Type*) [comm_group G] [i : unique G] : unique (CommGroup.of G) := i

@[simp, to_additive]
lemma one_apply (G H : CommGroup) (g : G) : (1 : G ⟶ H) g = 1 := rfl

@[ext, to_additive]
lemma ext (G H : CommGroup) (f₁ f₂ : G ⟶ H) (w : ∀ x, f₁ x = f₂ x) : f₁ = f₂ :=
by { ext1, apply w }

@[to_additive has_forget_to_AddGroup]
instance has_forget_to_Group : has_forget₂ CommGroup Group := bundled_hom.forget₂ _ _

@[to_additive] instance : has_coe CommGroup.{u} Group.{u} :=
{ coe := (forget₂ CommGroup Group).obj, }

@[to_additive has_forget_to_AddCommMon]
instance has_forget_to_CommMon : has_forget₂ CommGroup CommMon :=
induced_category.has_forget₂ (λ G : CommGroup, CommMon.of G)

@[to_additive] instance : has_coe CommGroup.{u} CommMon.{u} :=
{ coe := (forget₂ CommGroup CommMon).obj, }

end CommGroup

-- This example verifies an improvement possible in Lean 3.8.
-- Before that, to have `monoid_hom.map_map` usable by `simp` here,
-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.
-- Now, it just works.
@[to_additive]
example {R S : CommGroup} (i : R ⟶ S) (r : R) (h : r = 1) : i r = 1 :=
by simp [h]

namespace AddCommGroup

/-- Any element of an abelian group gives a unique morphism from `ℤ` sending
`1` to that element. -/
-- Note that because `ℤ : Type 0`, this forces `G : AddCommGroup.{0}`,
-- so we write this explicitly to be clear.
-- TODO generalize this, requiring a `ulift_instances.lean` file
def as_hom {G : AddCommGroup.{0}} (g : G) : (AddCommGroup.of ℤ) ⟶ G :=
zmultiples_hom G g

@[simp]
lemma as_hom_apply {G : AddCommGroup.{0}} (g : G) (i : ℤ) : (as_hom g) i = i • g := rfl

lemma as_hom_injective {G : AddCommGroup.{0}} : function.injective (@as_hom G) :=
λ h k w, by convert congr_arg (λ k : (AddCommGroup.of ℤ) ⟶ G, (k : ℤ → G) (1 : ℤ)) w; simp

@[ext]
lemma int_hom_ext
  {G : AddCommGroup.{0}} (f g : (AddCommGroup.of ℤ) ⟶ G) (w : f (1 : ℤ) = g (1 : ℤ)) : f = g :=
add_monoid_hom.ext_int w

-- TODO: this argument should be generalised to the situation where
-- the forgetful functor is representable.
lemma injective_of_mono {G H : AddCommGroup.{0}} (f : G ⟶ H) [mono f] : function.injective f :=
λ g₁ g₂ h,
begin
  have t0 : as_hom g₁ ≫ f = as_hom g₂ ≫ f :=
  begin
    ext,
    simpa [as_hom_apply] using h,
  end,
  have t1 : as_hom g₁ = as_hom g₂ := (cancel_mono _).1 t0,
  apply as_hom_injective t1,
end

end AddCommGroup

/-- Build an isomorphism in the category `Group` from a `mul_equiv` between `group`s. -/
@[to_additive add_equiv.to_AddGroup_iso, simps]
def mul_equiv.to_Group_iso {X Y : Group} (e : X ≃* Y) : X ≅ Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

/-- Build an isomorphism in the category `AddGroup` from an `add_equiv` between `add_group`s. -/
add_decl_doc add_equiv.to_AddGroup_iso

/-- Build an isomorphism in the category `CommGroup` from a `mul_equiv` between `comm_group`s. -/
@[to_additive add_equiv.to_AddCommGroup_iso, simps]
def mul_equiv.to_CommGroup_iso {X Y : CommGroup} (e : X ≃* Y) : X ≅ Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

/-- Build an isomorphism in the category `AddCommGroup` from a `add_equiv` between
`add_comm_group`s. -/
add_decl_doc add_equiv.to_AddCommGroup_iso

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Group`. -/
@[to_additive AddGroup_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddGroup`.", simps]
def Group_iso_to_mul_equiv {X Y : Group} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

/-- Build a `mul_equiv` from an isomorphism in the category `CommGroup`. -/
@[to_additive AddCommGroup_iso_to_add_equiv "Build an `add_equiv` from an isomorphism
in the category `AddCommGroup`.", simps]
def CommGroup_iso_to_mul_equiv {X Y : CommGroup} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

end category_theory.iso

/-- multiplicative equivalences between `group`s are the same as (isomorphic to) isomorphisms
in `Group` -/
@[to_additive add_equiv_iso_AddGroup_iso "additive equivalences between `add_group`s are the same
as (isomorphic to) isomorphisms in `AddGroup`"]
def mul_equiv_iso_Group_iso {X Y : Group.{u}} : (X ≃* Y) ≅ (X ≅ Y) :=
{ hom := λ e, e.to_Group_iso,
  inv := λ i, i.Group_iso_to_mul_equiv, }

/-- multiplicative equivalences between `comm_group`s are the same as (isomorphic to) isomorphisms
in `CommGroup` -/
@[to_additive add_equiv_iso_AddCommGroup_iso "additive equivalences between `add_comm_group`s are
the same as (isomorphic to) isomorphisms in `AddCommGroup`"]
def mul_equiv_iso_CommGroup_iso {X Y : CommGroup.{u}} : X ≃* Y ≅ (X ≅ Y) :=
{ hom := λ e, e.to_CommGroup_iso,
  inv := λ i, i.CommGroup_iso_to_mul_equiv, }

namespace category_theory.Aut

/-- The (bundled) group of automorphisms of a type is isomorphic to the (bundled) group
of permutations. -/
def iso_perm {α : Type u} : Group.of (Aut α) ≅ Group.of (equiv.perm α) :=
{ hom := ⟨λ g, g.to_equiv, (by tidy), (by tidy)⟩,
  inv := ⟨λ g, g.to_iso, (by tidy), (by tidy)⟩ }

/-- The (unbundled) group of automorphisms of a type is `mul_equiv` to the (unbundled) group
of permutations. -/
def mul_equiv_perm {α : Type u} : Aut α ≃* equiv.perm α :=
iso_perm.Group_iso_to_mul_equiv

end category_theory.Aut

@[to_additive]
instance Group.forget_reflects_isos : reflects_isomorphisms (forget Group.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Group).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Group_iso).1⟩,
  end }

@[to_additive]
instance CommGroup.forget_reflects_isos : reflects_isomorphisms (forget CommGroup.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommGroup).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommGroup_iso).1⟩,
  end }


import analysis.complex.isometry
import analysis.complex.real_deriv
import analysis.calculus.conformal

noncomputable theory

open complex linear_isometry linear_isometry_equiv continuous_linear_map
     finite_dimensional linear_map

section A

variables (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
variables {𝕜' : Type*} [nondiscrete_normed_field 𝕜'] [normed_algebra 𝕜 𝕜']
variables {E : Type*} [normed_group E] [normed_space 𝕜 E] [normed_space 𝕜' E]
variables [is_scalar_tower 𝕜 𝕜' E]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F] [normed_space 𝕜' F]
variables [is_scalar_tower 𝕜 𝕜' F]
variables {f : E → F} {f' : E →L[𝕜'] F} {s : set E} {x : E}

lemma differentiable_at_iff_exists_linear_map (hf : differentiable_at 𝕜 f x) :
  differentiable_at 𝕜' f x ↔ ∃ (g' : E →L[𝕜'] F), g'.restrict_scalars 𝕜 = fderiv 𝕜 f x :=
sorry

end A

section B

variables {E : Type*} [normed_group E] [normed_space ℝ E] [normed_space ℂ E]
  [is_scalar_tower ℝ ℂ E] {z : ℂ} {g : ℂ →L[ℝ] E} {f : ℂ → E}

lemma is_conformal_map_of_complex_linear
  {map : ℂ →L[ℂ] E} (nonzero : map ≠ 0) : is_conformal_map (map.restrict_scalars ℝ) :=
sorry

lemma conformal_at_of_holomorph_or_antiholomorph_at_aux
  (hf : differentiable_at ℝ f z) (hf' : fderiv ℝ f z ≠ 0)
  (h : differentiable_at ℂ f z ∨ differentiable_at ℂ (f ∘ conj) (conj z)) :
  conformal_at f z :=
begin
  rw [conformal_at_iff_is_conformal_map_fderiv],
  cases h with h₁ h₂,
  { rw [differentiable_at_iff_exists_linear_map ℝ hf] at h₁;
       [skip, apply_instance, apply_instance, apply_instance],
    rcases h₁ with ⟨map, hmap⟩,
    have minor₁ : fderiv ℝ f z = map.restrict_scalars ℝ := hmap.symm,
    rw minor₁,
    refine is_conformal_map_of_complex_linear _,},
end

end B


import set_category.diagram_lemmas
import set_category.category_set
import set_category.limits.Equalizer
import help_functions
import coalgebra.Coalgebra
import coalgebra.subcoalgebra

import tactic.tidy

universes u

namespace coalgebra_equalizer

open category_theory
     set
     coalgebra
     classical
     function
     help_functions
     Equalizer
     coalgebra.Coalgebra
     category_set
     subcoalgebra

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

variables   {F : Type u ⥤ Type u}
            {𝔸 Β: Coalgebra F}
            (ϕ ψ : 𝔸 ⟶ Β)

theorem largest_subcoalgebra_equalizer
    {C : set (equalizer_set ϕ ψ)}
    (lar : is_largest_coalgebra C):
    let E := equalizer_set ϕ ψ in
    let e : E → 𝔸 := (E ↪ 𝔸) in
    let ℂ : Coalgebra F := ⟨C , some lar.1⟩  in
    let σ : ℂ ⟶ 𝔸 := ⟨(e ∘ (C ↪ E))  , some_spec lar.1⟩ in
    is_equalizer ϕ ψ σ :=
    begin
        intros E e ℂ σ,

        split,

        exact eq_in_set.1
            (funext (λ c, ((C ↪ E) c).property)),

        intros Q q ϕq_ψq,

        have is_eq := (eqaulizer_set_is_equalizer ϕ ψ).2 q
                    (eq_in_set.2 ϕq_ψq),

        let f : Q → E := some is_eq,
        have eq_f := some_spec is_eq,

        have fact : q.val = e ∘ f := eq_f.1,

        let f₁ : Q → (range f) := range_factorization f,

        let e₁ : range f → 𝔸 := e ∘ (range f ↪ E),

        have inj_e₁ : injective e₁ :=
            begin
                intros a₁ a₂ k,
                have inj_e : ∀ r₁ r₂, e r₁ = e r₂ → r₁ = r₂ :=
                    inj_inclusion 𝔸 E,
                have ra : (range f ↪ E) a₁ = (range f ↪ E) a₂ :=
                    inj_e a₁ a₂ k,
                have inj_r : ∀ q₁ q₂,
                    (range f ↪ E) q₁ = (range f ↪ E) q₂ → q₁ = q₂ :=
                        inj_inclusion E (range f),
                exact (inj_r) a₁ a₂ ra,
            end,

        have inj_σ : injective σ :=
            begin
                intros a₁ a₂ k,
                have inj_e : ∀ r₁ r₂, e r₁ = e r₂ → r₁ = r₂ :=
                    inj_inclusion 𝔸 E,
                have ra : (C ↪ E) a₁ = (C ↪ E) a₂ :=
                    inj_e a₁ a₂ k,
                have inj_r : ∀ q₁ q₂, (C ↪ E) q₁ = (C ↪ E) q₂ → q₁ = q₂ :=
                    inj_inclusion E C,
                exact inj_r a₁ a₂ ra,
            end,

        have ex := Factorization q f₁ e₁ fact
            ((epi_iff_surjective f₁).2 surjective_onto_range) inj_e₁,

        let α_ℝ : range f → F.obj (range f) := some ex,

        have Rf_C : range f ⊆ C :=
            lar.2 (range f) (exists.intro α_ℝ (some_spec ex).1.2),

        let fc : Q.carrier → ℂ.carrier := λ q₁ , ⟨f q₁, Rf_C (f₁ q₁).property ⟩,

        have f_fc : ∀ q₁, f q₁ = fc q₁ := λ q₁, rfl,

        have q_fc_σ_el : ∀ q₁ , q.val q₁ = (σ ∘ fc) q₁ :=
            λ q₁,
            have s0 : (σ ∘ fc) q₁ = (e ∘ f) q₁ := rfl,
            by rw [fact, s0],

        have q_fc_σ : q.val = σ ∘ fc := funext q_fc_σ_el,

        have hom_σ_fc : @is_coalgebra_homomorphism F Q 𝔸 (σ ∘ fc) :=
            q_fc_σ ▸ q.property,

        have hom_fc : @is_coalgebra_homomorphism F Q ℂ fc :=
            inj_to_hom fc σ hom_σ_fc σ.property inj_σ,

        let h_fc : Q ⟶ ℂ := ⟨fc , hom_fc ⟩,

        use h_fc,
        have s1 : q.val = (σ ⊚ h_fc).val := q_fc_σ,
        split,
        exact eq_in_set.1 s1,

        intros g q_σ_g,

        let σ₁ : ℂ.carrier ⟶ 𝔸.carrier := σ.val,

        have inj_σ₁ : injective σ₁ := inj_σ,

        haveI mo : mono σ₁ := (mono_iff_injective σ).2 inj_σ₁,

        have s2 : (σ ⊚ g).val = (σ ⊚ h_fc).val :=
             q_σ_g ▸ s1,

        have s3 : σ.val ∘ g.val = σ.val ∘ h_fc.val :=
             s2,

        have s4 : g.val = h_fc.val :=  left_cancel σ₁ s3,

        exact eq_in_set.1 s4

    end

end coalgebra_equalizer


import algebra.order.monoid
import data.rat.basic
import topology.algebra.infinite_sum

open function

variables {M : Type*} {N : Type*}

def with_top.cast_fun (f : M → N) : with_top M → with_top N
| ⊤ := ⊤
| (x : M) := f x

variables [hM : add_monoid M] [hN : add_monoid N] {f : add_monoid_hom M N}
include hM hN

lemma with_top.cast_fun_zero : with_top.cast_fun f (0 : M) = 0:=
by { rw with_top.cast_fun, rw map_zero, refl }

lemma with_top.cast_fun_add :
∀ a b : with_top M, (a + b).cast_fun f = a.cast_fun f + b.cast_fun f
| ⊤ b := show _ = ⊤ + _, by simp only [with_top.top_add]; refl
| a ⊤ := show _ = _ + ⊤, by simp only [with_top.add_top]; refl
| (a : M) (b : M) :=
by rw [← with_top.coe_add, with_top.cast_fun, with_top.cast_fun, with_top.cast_fun,
    ← with_top.coe_add, with_top.coe_eq_coe, map_add]

lemma with_top.cast_fun_eq_top : ∀ {x : with_top M}, x.cast_fun f = ⊤ → x = ⊤
| ⊤ := λ h, rfl
| (x : M) := λ h, absurd h with_top.coe_ne_top

lemma with_top.cast_fun_inj (hf : injective f) : injective (with_top.cast_fun f)
| ⊤ y h := (with_top.cast_fun_eq_top h.symm).symm
| x ⊤ h := with_top.cast_fun_eq_top h
| (x : M) (y : M) h :=
by { injections, exact with_top.coe_eq_coe.mpr ((injective.eq_iff hf).mp h_1)}

variable (f)

def with_top.cast_add_monoid_hom : with_top M →+ with_top N :=
{ to_fun   := with_top.cast_fun f,
  map_zero' := with_top.cast_fun_zero,
  map_add' := with_top.cast_fun_add }

def mulcast : multiplicative (order_dual (with_top M)) →*
  multiplicative (order_dual (with_top N)) :=
{ to_fun   := with_top.cast_fun f,
  map_one' := with_top.cast_fun_zero,
  map_mul' := with_top.cast_fun_add }

omit hM hN

def mulcast' {E F : Type*} [linear_ordered_add_comm_monoid E] [linear_ordered_add_comm_monoid F]
  (g : add_monoid_hom E F) : multiplicative (order_dual (with_top E)) →*₀
  multiplicative (order_dual (with_top F)) :=
{ to_fun  := with_top.cast_fun g,
  map_zero' := rfl,
  map_one'  := with_top.cast_fun_zero,
  map_mul'  := with_top.cast_fun_add }

variable {f}

lemma mulcast_injective (hf : injective f) : function.injective (mulcast f):=
with_top.cast_fun_inj hf

section comm_group
variables (f) [linear_ordered_add_comm_group M] [linear_ordered_add_comm_group N]

lemma mulcast_map_zero : mulcast f 0 = 0 := rfl

variable {f}

lemma mulcast_eq_zero_iff (hf : injective f) (x : multiplicative (order_dual (with_top M))) :
  mulcast f x = 0 ↔ x = 0 :=
begin
  rw [← mulcast_map_zero f],
  exact ⟨λ h, mulcast_injective hf h, congr_arg _⟩
end

/- lemma mulcast_map_gen :
  mulcast (mul_gen (with_top ℤ)) = mul_gen (with_top ℚ) :=
show ↑_ = ↑_, by rw int.cast_one -/

lemma with_top_cast_le_with_top_cast (hf : strict_mono f) : ∀ (x y : with_top M),
  with_top.cast_fun f x ≤ with_top.cast_fun f y ↔  x ≤ y
| ⊤ b :=
by erw [top_le_iff, top_le_iff]; exact ⟨with_top.cast_fun_eq_top, λ h, h.symm ▸ rfl⟩
| a ⊤ := ⟨λ h, le_top, λ h, le_top⟩
| (a : M) (b : M) := by { rw [with_top.cast_fun, with_top.cast_fun, with_top.coe_le_coe,
  with_top.coe_le_coe], exact hf.le_iff_le}

lemma with_top_cast_lt_with_top_cast (hf : strict_mono f) : ∀ (x y : with_top M),
  with_top.cast_fun f x < with_top.cast_fun f y ↔  x < y
| ⊤ ⊤ := by simp only [lt_self_iff_false]
| ⊤ (b : M) := by { simp only [not_top_lt, iff_false, not_lt], exact le_top }
| (a : M) ⊤ := ⟨λ h, with_top.coe_lt_top _, λ h, with_top.coe_lt_top _⟩
| (a : M) (b : M) :=
by { rw [with_top.cast_fun, with_top.cast_fun, with_top.coe_lt_coe, with_top.coe_lt_coe],
  exact hf.lt_iff_lt }

lemma mulcast_le_mulcast (hf : strict_mono f) (x y : multiplicative (order_dual (with_top M))) :
  mulcast f x ≤ mulcast f y ↔ x ≤ y :=
with_top_cast_le_with_top_cast hf _ _

lemma mulcast_lt_mulcast (hf : strict_mono f) (x y : multiplicative (order_dual (with_top M))) :
  mulcast f x < mulcast f y ↔ x < y :=
with_top_cast_lt_with_top_cast hf _ _

end comm_group

section ring

variables [linear_ordered_comm_ring M] -- [linear_ordered_comm_ring N]

lemma with_top_add_mul (m : M) (hm : m ≠ 0) : ∀ a b : with_top M,
  (a + b) * m = a * m + b * m
| ⊤ _ :=
by rw [top_add, with_top.top_mul (show (m : with_top M) ≠ 0, by norm_cast; exact hm), top_add]
| _ ⊤ :=
by rw [add_top, with_top.top_mul (show (m : with_top M) ≠ 0, by norm_cast; exact hm), add_top]
| (some a) (some b) :=
by simp only [with_top.some_eq_coe, ←with_top.coe_add, ←with_top.coe_mul, add_mul]

lemma mul_eq_top_iff (m : M) (hm : m ≠ 0) : ∀ a : with_top M,
  a * m = ⊤ ↔ a = ⊤
| ⊤ := ⟨λ h, rfl, λ h, by rw [with_top.top_mul]; norm_cast; exact hm⟩
| (some m) :=
⟨λ h, absurd (by rwa [with_top.some_eq_coe, ←with_top.coe_mul] at h) with_top.coe_ne_top,
 λ h, absurd h with_top.coe_ne_top⟩

lemma succ_nsmul_top (m : ℕ) : ((m + 1) • ⊤ : with_top M) = ⊤ :=
begin
  induction m with m hm,
  { simp only [one_nsmul] },
  { simp only [succ_nsmul, with_top.top_add] },
end

lemma nsmul_top_mul (m : ℕ) (q : M) :
  (m • (⊤ : with_top M)) * q = ⊤ * (m * q : M) :=
begin
  induction m with m hm,
  { simp only [zero_smul, zero_mul, nat.cast_zero, with_top.coe_zero, mul_zero], },
  { rw succ_nsmul_top,
    by_cases q = 0,
    { simp only [h, with_top.coe_zero, mul_zero] },
    { rw with_top.top_mul (show (q : with_top M) ≠ 0, by norm_cast; exact h),
      refine (with_top.top_mul _).symm,
      norm_cast,
      exact (λ hn, h $ or.resolve_left (mul_eq_zero.1 hn)
        (by norm_cast; exact nat.succ_ne_zero _))}}
end

lemma zero_le_mul_inv (m : M) (hm : 0 < m) : ∀ x : with_top M,
  0 ≤ x ↔ 0 ≤ x * m
| ⊤ := by {rw with_top.top_mul, norm_cast, linarith }
| (some a) :=
begin
  simp only [with_top.some_eq_coe, ←with_top.coe_zero, ←with_top.coe_mul,
    with_top.coe_le_coe, zero_le_mul_right hm],
end

lemma nsmul_coe (m : ℕ) (x : M) : m • (x : with_top M) = m * x :=
begin
  induction m with m hm,
  { rw [zero_smul, nat.cast_zero, zero_mul] },
  { rw [succ_nsmul, hm],
    norm_cast,
    rw [nat.cast_succ, add_mul, one_mul, add_comm] }
end

lemma nsmul_top (m : ℕ) : m • (⊤ : with_top M) = m * ⊤ :=
begin
  induction m with m hm,
  { simp only [zero_smul, nat.cast_zero, zero_mul] },
  { rw [succ_nsmul_top,  with_top.mul_top],
    exact nat.cast_ne_zero.mpr (nat.succ_ne_zero _) }
end

lemma nsmul_with_top (m : ℕ) : ∀ (x : with_top M), m • x = m * x
| ⊤ := nsmul_top _
| (some x) := nsmul_coe _ _

lemma nsmul_coe_mul (m : ℕ) (x q : M) :
  (m • (x : with_top M)) * q = x * (m * q : M) :=
begin
  rw [nsmul_coe, mul_comm ↑m, mul_assoc],
  congr,
  norm_cast,
end

lemma nsmul_mul (m : ℕ) (q : M) : ∀ x : with_top M,
  (m • x : with_top M) * q = x * (m * q : M)
| ⊤ := nsmul_top_mul _ _
| (some x) := nsmul_coe_mul m x q

lemma nsmul_comm (m : ℕ) (q : M) (x : with_top M) :
  (m • x : with_top M) * q = m • (x * q) :=
begin
  rw [nsmul_mul, with_top.coe_mul, ←mul_assoc, mul_comm x, mul_assoc, nsmul_with_top],
  congr' 1,
end

lemma mul_coe_one (x : with_top M) :
  x * (1 : M) = x := mul_one _

instance multiplicative_order_dual.has_pow :
  has_pow (multiplicative (order_dual (with_top M))) M :=
⟨λ x y, ((x : with_top M) * y : with_top M)⟩

lemma mulM_mul_pow {m : M} (hm : m ≠ 0) (g h : multiplicative (order_dual (with_top M)))  :
  (g * h) ^ m = g ^ m * h ^ m :=
with_top_add_mul _ hm _ _

lemma mulM_zero_pow (n : M) (h : n ≠ 0) : (0 : multiplicative (order_dual (with_top M))) ^ n = 0 :=
with_top.top_mul (by norm_cast; exact h)

lemma mulM_one_pow (n : M) : (1 : multiplicative (order_dual (with_top M))) ^ n = 1 := zero_mul _

lemma mulM_pow_one (x : multiplicative (order_dual (with_top M))) : x ^ (1 : M) = x :=
mul_coe_one x

lemma mulM_pow_le_one (q : M) (h : 0 < q) (x : multiplicative (order_dual (with_top M))) :
 x ≤ 1 ↔ x ^ q ≤ 1 :=
zero_le_mul_inv _ h _

lemma mulM_pow_eq_zero_iff (x : multiplicative (order_dual (with_top M))) {q : M} (h : q ≠ 0) :
  x ^ q = 0 ↔ x = 0 :=
mul_eq_top_iff _ h _

lemma mulM_pow_mul (n : ℕ) (q : M) (x : multiplicative (order_dual (with_top M))) :
  (x ^ n) ^ q = x ^ ((n : M) * q) :=
nsmul_mul _ _ _

lemma mulM_pow_comm (n : ℕ) (q : M) (x : multiplicative (order_dual (with_top M))) :
  (x ^ n) ^ q = (x ^ q) ^ n :=
nsmul_comm _ _ _

end ring

section field

variable [linear_ordered_field M]

lemma mul_inv_le_mul_inv (m : ℕ) (h : m ≠ 0) :
  ∀ g h : with_top M, g ≤ h → g * (m⁻¹ : M) ≤ h * (m⁻¹ : M)
| ⊤ a H :=
begin
  rw [top_le_iff.1 H, with_top.top_mul],
  { exact le_refl _},
  { simp [h] }
end
| a ⊤ H :=
begin
  rw with_top.top_mul,
  { exact le_top },
  { simp [h] }
end
| (some a) (some b) H := by { simp only [with_top.some_eq_coe, ←with_top.coe_mul,
    with_top.coe_le_coe, with_top.some_eq_coe] at ⊢ H,
    exact (mul_le_mul_right (by {rw [inv_pos], norm_cast, exact pos_iff_ne_zero.2 h})).2 H }

lemma mulM_pow_le_of_le {m : ℕ} {g h : multiplicative (order_dual (with_top M))} (hm : m ≠ 0)
  (H : h ≤ g) : h ^ (m⁻¹ : M) ≤ g ^ (m⁻¹ : M) :=
mul_inv_le_mul_inv m hm g h H

end field

--#lint


import util.control.applicative

universes u v

variable {m : Type u → Type v}
variable [monad m]
variables {α β γ : Type u}

open functor nat

namespace monad

lemma map_bind (f : γ → β) (x : m α) (g : α → m γ)
: f <$> (x >>= g) = x >>= (map f ∘ g) :=
sorry

lemma bind_map (f : α → β) (x : m α) (g : β → m γ)
: f <$> x >>= g = x >>= g ∘ f :=
sorry

def mmap₂  (f : α → β → m γ) : list α → list β → m (list γ)
| (x :: xs) (y :: ys) := (::) <$> f x y <*> mmap₂ xs ys
| [] _ := pure []
| _ [] := pure []

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

end monad

open applicative

def monad.mrepeat : ℕ → m α → m (list α)
 | 0 _ := return []
 | (succ n) m := lift₂ (::) m (monad.mrepeat n m)

def monad.mrepeat' : ℕ → m α → m punit
 | 0 _ := return punit.star
 | (succ n) m := m *> monad.mrepeat' n m


import FirstOrderLeaning

open Classical

inductive Asrt where
  | literal : Bool → Asrt
  | emp : Asrt
  | singleton : Nat → Nat → Asrt
  | sep : Asrt → Asrt → Asrt
--  | sepimp : Asrt → Asrt → Asrt
open Asrt

def Partial (A B : Type): Type := A → Option B

def Store : Type := Nat → Nat
def Heap : Type := Partial Nat Nat

def Subset (A : Type) : Type := A → Prop

def empty_set {A : Type} : Subset A :=
λ x => false

def set_union {A : Type} (s1 s2 : Subset A) : Subset A :=
λ x => (s1 x) ∨ (s2 x)

def set_intersection {A : Type} (s1 s2 : Subset A) : Subset A :=
λ x => (s1 x) ∧ (s2 x)

def set_disjoint {A : Type} (s1 s2 : Subset A) : Prop :=
∀ x , ¬((s1 x) ∧ (s2 x))

def set_subset {A : Type} (s1 s2 : Subset A) : Prop :=
∀ x , (s1 x) → (s2 x)

-- s1 / s2
def set_difference {A : Type} (s1 s2 : Subset A) : Subset A :=
λ x => (s1 x) ∧ ¬(s2 x)

@[simp] def equal {A : Type} (s1 s2 : Subset A) : Prop :=
  ∀ x , s1 x ↔ s2 x

@[simp] def dom {A B : Type}  (p : Partial A B) : Subset A := λ a => (p a).isSome

def empty_partial {A B : Type} : Partial A B := λ x => none

noncomputable def singleton_partial {A B : Type} (a : A) (b : B) : Partial A B := λ x => if (x = a) then some b else none

noncomputable def singleton_partial_some {A B : Type} (a : A) (b : Option B) : Partial A B := match b with
  | some x => singleton_partial a x
  | none => empty_partial

def disjoint {A B : Type} (p1 p2 : Partial A B) : Prop :=
set_intersection (dom p1) (dom p2) = empty_set

infix:60 " ⊥ " => disjoint

theorem disjoint_symm {A B : Type} {p1 p2 : Partial A B} : p1 ⊥ p2 ↔ p2 ⊥ p1 := by {
  simp[disjoint];
  simp[set_intersection];
  simp[empty_set];
  apply Iff.intro;
  case mp  => {
    intro lhs;
    rw[← lhs];
    apply funext;
    intro x;
    rw[and_symm];
  }
  case mpr => {
    intro lhs;
    rw[← lhs];
    apply funext;
    intro x;
    rw[and_symm];
  }
}

@[simp]
def in_partial {A B : Type} (a : A) (p : Partial A B) : Prop := (p a).isSome

def partial_of {A B : Type} (p1 p2 : Partial A B) : Prop :=
  ∀ x , match p1 x with
  | some y => (p2 x) = some y
  | none   => True

infix:60 " ⊆ " => partial_of

@[simp] theorem partial_of_emp {A B : Type} (p : Partial A B) : empty_partial ⊆ p := by {
  simp[partial_of, empty_partial];
}

@[simp] theorem partial_of_singleton {A B : Type} (a : A) (b : B) (p : Partial A B) : ((singleton_partial a b) ⊆ p) ↔ (p a = some b) := by {
  simp [partial_of];
  simp [singleton_partial];
  apply Iff.intro;
  case mp  => {
    intro precondition ;
    have p1 := precondition a;
    simp at p1;
    exact p1;
  }
  case mpr => {
    intro pred a1;
    apply Or.elim (Classical.em (a1 = a));
    case left => {
      intro temp;
      simp[temp];
      exact pred;
    }
    case right => {
      intro temp;
      simp[temp];
    }
  }
}

theorem partial_of_self (p : Partial A B) : p ⊆ p := by {
  simp[partial_of];
  intro x;
  apply Or.elim (Classical.em (p x).isSome);
  case left  => {
    rw[is_some];
    intro ⟨ witness, proof ⟩;
    rw[proof];
  }
  case right => {
    rw[is_not_some];
    intro p_x_none;
    rw[p_x_none];
    simp;
  }
}

theorem partial_of_transitive {p1 p2 p3 : Partial A B} : p1 ⊆ p2 → p2 ⊆ p3 → p1 ⊆ p3 := by {
  simp[partial_of];
  intro p1_p2 p2_p3;
  intro x;
  have := p1_p2 x;
  apply Or.elim (Classical.em (p1 x).isSome);
  case left  => {
    simp[is_some];
    intro ⟨ witness, proof ⟩;
    rw[proof];
    simp;
    rw[proof] at this;
    simp at this;
    have p2_x := this;
    have := p2_p3 x;
    rw[p2_x] at this;
    simp at this;
    exact this;
  }
  case right => {
    rw[is_not_some];
    intro not_p1_x;
    rw[not_p1_x];
    simp;
  }
}

theorem disjoint_partial {p1 p2 p1' : Partial A B} : p1 ⊥ p2 → p1' ⊆ p1 → p1' ⊥ p2 := by {
  simp[disjoint, partial_of, set_intersection, empty_set];
  intro disjoint_proof;
  intro partial_proof;
  apply funext;
  intro x;
  have partial_proof1 := partial_proof x;
  have disjoint_proof1 := congrFun disjoint_proof x;
  apply Or.elim (Classical.em (p1' x).isSome);
  case left  => {
    intro temp;
    simp[temp];
    revert temp;
    rw[is_some];
    intro ⟨ witness, proof ⟩;
    revert disjoint_proof1;
    simp[proof] at partial_proof1;
    simp[partial_proof1];
    simp[Option.isSome];
    split <;> simp;
  }
  case right => {
    intro temp;
    simp[temp];
  }
}

noncomputable def union {A : Type} (p1 p2 : Partial A B) : Partial A B :=
λ x => if (p1 x) = none then (p2 x) else (p1 x)

infix:60 " ∪ " => union

theorem union_disjoint_symm : p1 ⊥ p2 → p1 ∪ p2 = p2 ∪ p1 := by {
  simp[disjoint, union, set_intersection, empty_set];
  intro disjoint_proof;
  apply funext;
  intro x;
  have disjoint_proof1 := congrFun disjoint_proof x;
  simp[de_morgan''] at disjoint_proof1;
  simp[is_not_some''] at disjoint_proof1;
  apply Or.elim (Classical.em (p1 x).isSome);
  case left  => {
    simp[is_some];
    intro ⟨ witness, proof ⟩;
    simp[proof];
    simp[proof] at disjoint_proof1;
    simp[disjoint_proof1];
  }
  case right => {
    simp[is_not_some''];
    intro temp;
    simp[temp];
    match p2 x with
    | some _ => simp;
    | none   => simp;
  }
}

theorem partial_of_p1_union : p1 ⊥ p2 → p = p1 ∪ p2 → p1 ⊆ p := by {
  simp[union];
  intro disjoint_proof p_defn;
  simp[partial_of];
  rw[p_defn];
  intro x;
  apply Or.elim (Classical.em (p1 x).isSome);
  case left  => {
    simp[is_some];
    intro ⟨ witness, proof ⟩;
    rw[proof];
    simp;
  }
  case right => {
    simp[is_not_some''];
    intro h1x_none;
    simp[h1x_none];
  }
}

theorem partial_of_union : p1 ⊥ p2 → p = p1 ∪ p2 → p1 ⊆ p ∧ p2 ⊆ p := by {
  intro disjoint_proof_p1_p2 p_p1_p2;
  have disjoint_proof_p2_p1 := (disjoint_symm.mp disjoint_proof_p1_p2);
  have p_p2_p1 : p = (union p2 p1) := by { rw[(union_disjoint_symm disjoint_proof_p1_p2)] at p_p1_p2; exact p_p1_p2;};
  apply And.intro (partial_of_p1_union disjoint_proof_p1_p2 p_p1_p2)
                  (partial_of_p1_union disjoint_proof_p2_p1 p_p2_p1);
}

noncomputable def partial_difference {A B : Type} (p1 p2 : Partial A B) : Partial A B :=
λ x => match (p2 x) with
  | some _ => none
  | none => p1 x

infix:60 "\\" => partial_difference

theorem eq_false'' {A : Prop} : (A = False) → ¬ A := by {
  intro a_false;
  intro a;
  rw[a_false] at a;
  exact a;
}

theorem exists_witness {A : Type} : (witness : A) → (∃ (a : A) , witness = a) := by {
  intro witness;
  apply Exists.intro witness;
  simp;
}

theorem partial_of_disjoint_subtraction {A B : Type} {p1 p2 p3 : Partial A B} : p1 ⊆ p3 ∧ disjoint p1 p2 → p1 ⊆ (partial_difference p3 p2) := by {
  simp [partial_of, partial_difference, disjoint, set_intersection, empty_set];
  intro ⟨ partial_p1_p3 , disjoint_p1_p2 ⟩ x;
  have partial_p1_p3_x := partial_p1_p3 x;
  apply Or.elim (Classical.em (p1 x).isSome);
  case left  => {
    rw[is_some];
    intro ⟨ witness, proof⟩;
    rw[proof];
    simp;
    rw[proof] at partial_p1_p3_x;
    simp at partial_p1_p3_x;
    have := (congrFun disjoint_p1_p2) x;
    rw[proof] at this;
    rw[is_some] at this;
    simp at this;
    have := eq_false'' this;
    simp[(exists_witness witness)] at this;
    rw[is_not_some''] at this;
    simp[this];
    assumption;
  }
  case right => {
    rw[is_not_some];
    intro p1_x_none;
    rw[p1_x_none];
    simp;
  }
}

theorem partial_of_difference_self {A B : Type} (p1 p2 : Partial A B) : partial_difference p1 p2 ⊆ p1 := by {
  simp[partial_of, partial_difference];
  intro x;
  apply Or.elim (Classical.em (p2 x).isSome);
  case left  => {
    rw[is_some];
    intro ⟨ proof , witness ⟩;
    simp[witness];
  }
  case right => {
    rw[is_not_some];
    intro not_p2_x;
    simp[not_p2_x];
    apply Or.elim (Classical.em (p1 x).isSome);
    case left  => {
      rw[is_some];
      intro ⟨ witness , proof ⟩;
      simp[proof];
    }
    case right => {
      rw[is_not_some];
      intro not_p1_x;
      simp[not_p1_x];
    }
  }
}

theorem difference_disjoint {A B : Type} (p1 p2 : Partial A B) : partial_difference p1 p2 ⊥ p2 := by {
  simp[partial_difference, disjoint, set_intersection, empty_set];
  apply funext;
  intro x;
  apply Or.elim (Classical.em (p2 x).isSome);
  case left  => {
    rw[is_some];
    intro ⟨ witness, proof ⟩;
    rw[proof];
    simp[Option.isSome];
  }
  case right => {
    rw[is_not_some];
    intro p2_x_none;
    simp[p2_x_none, Option.isSome];
  }
}

theorem difference_union_opposite {p1 p2 : Partial A B} : p2 ⊆ p1 → p1 = (partial_difference p1 p2) ∪ p2 := by {
  simp[partial_difference, union, partial_of];
  intro p2_p1;
  apply funext;
  intro x;
  apply Or.elim (Classical.em (p2 x).isSome);
  case left  => {
    rw[is_some];
    intro ⟨ witness, proof ⟩;
    simp[proof];
    have := p2_p1 x;
    rw[proof] at this;
    simp at this;
    exact this;
  }
  case right => {
    rw[is_not_some];
    intro p2_x_none;
    simp[p2_x_none];
    apply Or.elim (Classical.em (p1 x).isSome);
    · rw[is_some]; intro ⟨ witness , proof ⟩ ; simp[proof];
    · rw[is_not_some]; intro temp; simp[temp];
  }
}

theorem difference_union_opposite' {p1 p2 : Partial A B} : p2 ⊆ p1 → p1 = p2 ∪ (partial_difference p1 p2) := by {
  rw[union_disjoint_symm];
  exact difference_union_opposite;
  exact disjoint_symm.mp (difference_disjoint p1 p2);
}

def asrt (q : Asrt) (s : Store) (h : Heap) : Prop := match q with
  | literal b => b
  | emp       => ∀ x , (dom h) x = false
  | singleton v1 v2 => h (s v1) = some (s v2) ∧ ∀ x , (dom h) x ↔ (x = (s v1))
  | sep q1 q2 => ∃ h1 h2 , (asrt q1 s h1) ∧ (asrt q2 s h2) ∧ (disjoint h1 h2) ∧ h = (union h1 h2)
--  | sepimp q1 q2 => ∀ h' , (asrt q1 s h') ∧ disjoint h h' -> asrt q2 s (union h h')

@[simp]
noncomputable def check (q : Asrt) (s : Store) (h : Heap) : (Prop × Heap) := match q with
  | literal b => (b , empty_partial)
  | emp       => (True, empty_partial)
  | singleton v1 v2 => (h (s v1) = some (s v2) , singleton_partial_some (s v1) (h (s v1)))
  | sep q1 q2 => let ⟨ b1 , m1 ⟩ := (check q1 s h); let ⟨ b2 , m2 ⟩ := (check q2 s h); (b1 ∧ b2 ∧ (disjoint m1 m2) , (union m1 m2))
--  | sepimp q1 q2 => let ⟨ b1 , m1 , t1 ⟩ := (check q1 s h); let ⟨ b2 , m2 , t2 ⟩ := (check q2 s h); (b1 → b2 ∧ m1 ⊆ m2 , partial_difference m2 m1 , sorry)

def tight (q : Asrt) : Prop := match q with
  | literal lit => False
  | emp => True
  | singleton v1 v2 => True
  | sep q1 q2 => tight q1 ∧ tight q2
--  | sepimp q1 q2 => False;

theorem partiality (q : Asrt) (s : Store) (h_tilde : Heap) : (check q s h_tilde).2 ⊆ h_tilde := by {
  match q with
  | literal lit => simp;
  | emp => simp;
  | singleton v1 v2 => {
    simp[check];
    simp[singleton_partial_some];
    apply Or.elim (Classical.em (h_tilde (s v1)).isSome);
    case left => {
      rw[is_some];
      intro ⟨ a, b ⟩;
      simp[b];
    }
    case right => {
      rw[is_not_some];
      intro temp;
      rw [temp];
      simp;
    }
  }
  | sep q1 q2 => {
    have partial1 := partiality q1 s h_tilde;
    have partial2 := partiality q2 s h_tilde;
    simp[check];
    simp[partial_of];
    intro x;
    simp[union];
    simp[partial_of] at partial1;
    have partial1_1 := partial1 x;
    simp[partial_of] at partial2;
    have partial2_1 := partial2 x;
    apply Or.elim (Classical.em ((check q1 s h_tilde).2 x = none));
    case left  => {
      apply Or.elim (Classical.em ((check q2 s h_tilde).2 x = none));
      case left => intro temp1 temp2; simp[temp1, temp2];
      case right => {
        intro temp1 temp2;
        rw[← is_not_some] at temp1;
        simp[dne] at temp1;
        rw[is_some] at temp1;
        have ⟨ witness, proof ⟩ := temp1;
        simp[proof, temp2];
        rw[proof] at partial2_1;
        simp at partial2_1;
        exact partial2_1;
      }
    }
    case right => {
      apply Or.elim (Classical.em ((check q2 s h_tilde).2 x = none));
      case left  => {
        intro temp1 temp2;
        simp[temp1, temp2];
        rw[← is_not_some] at temp2;
        simp[dne] at temp2;
        rw[is_some] at temp2;
        have ⟨ witness, proof ⟩ := temp2;
        simp[proof];
        rw[proof] at partial1_1;
        simp at partial1_1;
        exact partial1_1;
      }
      case right => {
        intro temp1 temp2;
        simp[temp1, temp2];
        rw[← is_not_some] at temp2;
        simp[dne] at temp2;
        rw[is_some] at temp2;
        have ⟨ witness, proof ⟩ := temp2;
        simp[proof];
        rw[proof] at partial1_1;
        simp at partial1_1;
        exact partial1_1;
      }
    }
  }
/-  | sepimp q1 q2 => {
    have partial1 := partiality q1 s h_tilde;
    have partial2 := partiality q2 s h_tilde;
    simp[check];
    simp[partial_of];
    intro x;
    simp[partial_difference];
    simp[partial_of] at partial1;
    have partial1_1 := partial1 x;
    simp[partial_of] at partial2;
    have partial2_1 := partial2 x;
    apply Or.elim (Classical.em ((check q1 s h_tilde).2.1 x = none));
    case left  => {
      apply Or.elim (Classical.em ((check q2 s h_tilde).2.1 x = none));
      case left => intro temp1 temp2; simp[temp1, temp2];
      case right => {
        intro temp1 temp2;
        rw[← is_not_some] at temp1;
        simp[dne] at temp1;
        rw[is_some] at temp1;
        have ⟨ witness, proof ⟩ := temp1;
        simp[proof, temp2];
        rw[proof] at partial2_1;
        simp at partial2_1;
        exact partial2_1;
      }
    }
    case right => {
      apply Or.elim (Classical.em ((check q2 s h_tilde).2.1 x = none));
      case left  => {
        intro temp1 temp2;
        simp[temp1, temp2];
        rw[← is_not_some] at temp2;
        simp[dne] at temp2;
        rw[is_some] at temp2;
        have ⟨ witness, proof ⟩ := temp2;
        simp[proof];
      }
      case right => {
        intro temp1 temp2;
        simp[temp1, temp2];
        rw[← is_not_some] at temp2;
        simp[dne] at temp2;
        rw[is_some] at temp2;
        have ⟨ witness, proof ⟩ := temp2;
        simp[proof];
      }
    }
  }-/
}

theorem uniqueness :
  (check q s h_tilde).1 ∧ tight q → ∀ h h' , (asrt q s h ∧ asrt q s h' → h = h') := by {
    match q with
  | literal lit => simp[asrt, tight];
  | emp => {
    intro ⟨ a, b ⟩ h h';
    simp[asrt];
    simp[is_not_some'];
    intro ⟨ hx , h'x ⟩;
    apply funext;
    intro x;
    rw[(hx x)];
    rw[(h'x x)];
  }
  | singleton v1 v2 => {
    simp[asrt];
    intro points;
    intro h h';
    intro ⟨ ⟨ a , b ⟩ , c , d ⟩;
    apply funext;
    intro x;
    have bx := b x;
    have dx := d x;
    have p := partiality q s h_tilde;
    apply Or.elim (Classical.em (x = s v1));
    case left  => {
      intro xsv1;
      simp[xsv1];
      simp[a, c];
    }
    case right => {
      intro xnsv1;
      simp[xnsv1] at bx;
      simp[xnsv1] at dx;
      simp[is_not_some''] at bx;
      simp[is_not_some''] at dx;
      simp[bx, dx];
    }
  }
  | sep q1 q2 => {
    simp[asrt];
    intro ⟨ ⟨ a1 , a2, a3  ⟩, b, c ⟩ h h' ⟨ ⟨ h1 , h2 , q1h1 , q2h2 , h1_disj_h2 , h_h1_h2 ⟩ , ⟨ h1' , h2' , q1h1' , q2h2' , h1_disj_h2' , h_h1_h2' ⟩ ⟩;
    have q1_uniqueness := uniqueness (And.intro a1 b);
    have q2_uniqueness := uniqueness (And.intro a2 c);
    have h1_same := q1_uniqueness h1 h1' (And.intro q1h1 q1h1');
    have h2_same := q2_uniqueness h2 h2' (And.intro q2h2 q2h2');
    simp[h_h1_h2, h_h1_h2', h1_same, h2_same];
  }
  /-
  | sepimp q1 q2 => {
    simp;
    sorry;
  }-/
}

theorem check_of_superset : (check q s h).1 ∧ h ⊆ h_tilde → (check q s h) = (check q s h_tilde) := by {
  match q with
  | literal lit => simp[check];
  | emp => simp[check];
  | singleton v1 v2 => {
    simp[check, partial_of];
    intro ⟨ points, subset ⟩;
    have proof := subset (s v1);
    simp[points] at proof;
    simp[points, proof];
  }
  | sep q1 q2 => {
    simp[check];--, partial_of];
    intro ⟨ ⟨ a1 , a2 , a3 ⟩ , b ⟩;
    have c1 := check_of_superset (And.intro a1 b);
    have c2 := check_of_superset (And.intro a2 b);
    simp[c1, c2];
  }
--  | sepimp q1 q2 => sorry;
}

theorem no_false_neg : (asrt q s h) → (check q s h).1 := by {
    match q with
  | literal lit => simp[asrt, check]; intro; assumption;
  | emp => simp[asrt, check];
  | singleton v1 v2 => simp[asrt, check]; intro ⟨ a, b ⟩; exact a;
  | sep q1 q2 => {
    simp[asrt, check];
    intro ⟨ h1, h2 , q1h1 , q2h2 , disjoint_h1_h2 , h_h1_h2 ⟩;

    apply And.intro;
    case left  => {
      have q1h1_b := (no_false_neg q1h1)
      have q1h := check_of_superset (And.intro q1h1_b (partial_of_union disjoint_h1_h2 h_h1_h2).1);
      rw[← q1h];
      exact q1h1_b;
    }
    case right => {
      apply And.intro;
      case left  => {
        have q2h2_b := (no_false_neg q2h2)
        have q2h := check_of_superset (And.intro q2h2_b (partial_of_union disjoint_h1_h2 h_h1_h2).2);
        rw[← q2h];
        exact q2h2_b;
      }
      case right => {
        have c_q1h1_b := no_false_neg q1h1;
        have q1_equiv := check_of_superset (And.intro c_q1h1_b (partial_of_union disjoint_h1_h2 h_h1_h2).1);
        have subset_1 := partiality q1 s h1;
        rw[q1_equiv] at subset_1;

        have c_q2h2_b := no_false_neg q2h2;
        have q2_equiv := check_of_superset (And.intro c_q2h2_b (partial_of_union disjoint_h1_h2 h_h1_h2).2);
        have subset_2 := partiality q2 s h2;
        rw[q2_equiv] at subset_2;

        have temp := disjoint_partial disjoint_h1_h2 subset_1;
        rw[disjoint_symm] at temp;
        have temp2 := disjoint_partial temp subset_2;
        rw[disjoint_symm] at temp2;
        exact temp2;
      }
    }
  }
--  | sepimp q1 q2 => sorry;
}

theorem no_false_pos : let ⟨ b, m ⟩ := (check q s h_tilde); b → asrt q s m := by {
  match q with
  | literal lit =>   simp[check, asrt]; intro; assumption;
  | emp => simp[check, asrt, empty_partial];
  | singleton v1 v2 => {
    simp[check, asrt, singleton_partial_some, singleton_partial];
    intro points;
    rw[points];
    simp;
    intro x;
    apply Or.elim (Classical.em (x = s v1));
    case left  => {
      intro x_s_v1;
      simp[x_s_v1, Option.isSome];
    }
    case right => {
      intro not_x_s_v1;
      simp[not_x_s_v1];
    }
  }
  | sep q1 q2 => {
    simp[check, asrt];
    intro ⟨ b1 , b2 , disjoint_m1_m2 ⟩ ;
    apply Exists.intro (check q1 s h_tilde).2;
    apply Exists.intro (check q2 s h_tilde).2;
    apply And.intro (no_false_pos b1);
    apply And.intro (no_false_pos b2);
    apply And.intro (disjoint_m1_m2);
    simp;
  }
}

variable (q : Asrt)
variable (s : Store)
variable (h_tilde : Heap)
variable (b : (check q s h_tilde).1)

theorem tightness {q s h_tilde} : let ⟨ b , m ⟩ := (check q s h_tilde); (b ∧ ¬ tight q) → ∀ h : Heap , m ⊆ h ∧ h ⊆ h_tilde → asrt q s h := by {
  match q with
  | literal lit => simp[asrt, check]; intro ⟨ _ , _ ⟩ _ _; assumption;
  | emp => simp[asrt, check, tight];
  | singleton v1 v2 => simp[tight];
  | sep q1 q2 => {
    simp[check, tight];
    intro ⟨ ⟨ b1 , b2 , disjoint_m1_m2 ⟩ , not_both_tight ⟩ h;
    rw [de_morgan] at not_both_tight;
    intro ⟨ partial_m_h , partial_h_h_tilde ⟩;
    have check_q_s_h_tilde : (check (sep q1 q2) s h_tilde).1 := And.intro b1 (And.intro b2 disjoint_m1_m2);
    have check_q_s_m : (check (sep q1 q2) s (check (sep q1 q2) s h_tilde).2).1 := no_false_neg (no_false_pos check_q_s_h_tilde);
    have partial_m1_h := partial_of_transitive (partial_of_union disjoint_m1_m2 rfl).left  partial_m_h;
    have partial_m2_h := partial_of_transitive (partial_of_union disjoint_m1_m2 rfl).right partial_m_h;
    apply Or.elim not_both_tight;
    case left  => {
      intro not_tight_q1;
      apply Exists.intro (partial_difference h (check q2 s h_tilde).2);
      apply Exists.intro (check q2 s h_tilde).2;
      have partial_m1_diff := partial_of_disjoint_subtraction (And.intro partial_m1_h disjoint_m1_m2);
      have b1_m1_eq_check_q1_s_diff := check_of_superset (And.intro (no_false_neg (no_false_pos b1)) partial_m1_diff);
      apply And.intro (tightness (And.intro b1 not_tight_q1) (partial_difference h (check q2 s h_tilde).2) (And.intro partial_m1_diff (partial_of_transitive (partial_of_difference_self h (check q2 s h_tilde).2) partial_h_h_tilde)));
      apply And.intro (no_false_pos b2);
      apply And.intro (difference_disjoint h (check q2 s h_tilde).2);
      exact (difference_union_opposite partial_m2_h);
    }
    case right => {
      intro not_tight_q2;
      apply Exists.intro (check q1 s h_tilde).2;
      apply Exists.intro (partial_difference h (check q1 s h_tilde).2);
      have partial_m2_diff := partial_of_disjoint_subtraction (And.intro partial_m2_h (disjoint_symm.mp disjoint_m1_m2));
      have b2_m2_eq_check_q2_s_diff := check_of_superset (And.intro (no_false_neg (no_false_pos b2)) partial_m2_diff);
      apply And.intro (no_false_pos b1);
      apply And.intro (tightness (And.intro b2 not_tight_q2) (partial_difference h (check q1 s h_tilde).2) (And.intro partial_m2_diff (partial_of_transitive (partial_of_difference_self h (check q1 s h_tilde).2) partial_h_h_tilde)));
      apply And.intro (disjoint_symm.mp (difference_disjoint h (check q1 s h_tilde).2));
      exact (difference_union_opposite' partial_m1_h);
    }
  }
--  | sepimp q1 q2 => False;
}

theorem equivalence (s : Store) (h_tilde : Heap) : let ⟨ b , m ⟩ := (check q s h_tilde); asrt q s h_tilde ↔ b ∧ (tight q → h_tilde = m) := by {
  simp;
  apply Iff.intro;
  case mp  => {
    intro asrt_q_s_h_tilde;
    have b := no_false_neg asrt_q_s_h_tilde;
    apply And.intro b;
    intro tight_q;
    have uniqueness_of_heaps := uniqueness (And.intro b tight_q);
    have asrt_q_s_m := no_false_pos b;
    have h_tilde_equal_m := uniqueness_of_heaps h_tilde (check q s h_tilde).2 (And.intro asrt_q_s_h_tilde asrt_q_s_m);
    exact h_tilde_equal_m;
  }
  case mpr => {
    intro ⟨ b, tight_implies_h_tilde_equal_m ⟩;
    have asrt_q_s_m := no_false_pos b;
    apply Or.elim (Classical.em (tight q));
    case left  => {
      intro tight_q;
      have h_tilde_equal_m := tight_implies_h_tilde_equal_m tight_q;
      revert asrt_q_s_m;
      rw[← h_tilde_equal_m];
      intro; assumption;
    }
    case right => {
      intro not_tight_q;
      have partial_implies_asrt_q_s_h_tilde := (tightness (And.intro b not_tight_q)) h_tilde;
      have partial_m_h_tilde := And.intro (partiality q s h_tilde) (partial_of_self h_tilde);
      exact (partial_implies_asrt_q_s_h_tilde partial_m_h_tilde);
    }
  }
}


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

! This file was ported from Lean 3 source module linear_algebra.clifford_algebra.even_equiv
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.CliffordAlgebra.Conjugation
import Mathbin.LinearAlgebra.CliffordAlgebra.Even
import Mathbin.LinearAlgebra.QuadraticForm.Prod

/-!
# Isomorphisms with the even subalgebra of a Clifford algebra

This file provides some notable isomorphisms regarding the even subalgebra, `clifford_algebra.even`.

## Main definitions

* `clifford_algebra.equiv_even`: Every Clifford algebra is isomorphic as an algebra to the even
  subalgebra of a Clifford algebra with one more dimension.
  * `clifford_algebra.even_equiv.Q'`: The quadratic form used by this "one-up" algebra.
  * `clifford_algebra.to_even`: The simp-normal form of the forward direction of this isomorphism.
  * `clifford_algebra.of_even`: The simp-normal form of the reverse direction of this isomorphism.

* `clifford_algebra.even_equiv_even_neg`: Every even subalgebra is isomorphic to the even subalgebra
  of the Clifford algebra with negated quadratic form.
  * `clifford_algebra.even_to_neg`: The simp-normal form of each direction of this isomorphism.

## Main results

* `clifford_algebra.coe_to_even_reverse_involute`: the behavior of `clifford_algebra.to_even` on the
  "Clifford conjugate", that is `clifford_algebra.reverse` composed with
  `clifford_algebra.involute`.
-/

namespace CliffordAlgebra

variable {R M : Type _} [CommRing R] [AddCommGroup M] [Module R M]

variable (Q : QuadraticForm R M)

/-! ### Constructions needed for `clifford_algebra.equiv_even` -/

namespace EquivEven

/-- The quadratic form on the augmented vector space `M × R` sending `v + r•e0` to `Q v - r^2`. -/
@[reducible]
def q' : QuadraticForm R (M × R) :=
  Q.Prod <| -@QuadraticForm.sq R _
#align clifford_algebra.equiv_even.Q' CliffordAlgebra.EquivEven.q'

theorem q'_apply (m : M × R) : q' Q m = Q m.1 - m.2 * m.2 :=
  (sub_eq_add_neg _ _).symm
#align clifford_algebra.equiv_even.Q'_apply CliffordAlgebra.EquivEven.q'_apply

/-- The unit vector in the new dimension -/
def e0 : CliffordAlgebra (q' Q) :=
  ι (q' Q) (0, 1)
#align clifford_algebra.equiv_even.e0 CliffordAlgebra.EquivEven.e0

/-- The embedding from the existing vector space -/
def v : M →ₗ[R] CliffordAlgebra (q' Q) :=
  ι (q' Q) ∘ₗ LinearMap.inl _ _ _
#align clifford_algebra.equiv_even.v CliffordAlgebra.EquivEven.v

theorem ι_eq_v_add_smul_e0 (m : M) (r : R) : ι (q' Q) (m, r) = v Q m + r • e0 Q := by
  rw [e0, v, LinearMap.comp_apply, LinearMap.inl_apply, ← LinearMap.map_smul, Prod.smul_mk,
    smul_zero, smul_eq_mul, mul_one, ← LinearMap.map_add, Prod.mk_add_mk, zero_add, add_zero]
#align clifford_algebra.equiv_even.ι_eq_v_add_smul_e0 CliffordAlgebra.EquivEven.ι_eq_v_add_smul_e0

theorem e0_mul_e0 : e0 Q * e0 Q = -1 :=
  (ι_sq_scalar _ _).trans <| by simp
#align clifford_algebra.equiv_even.e0_mul_e0 CliffordAlgebra.EquivEven.e0_mul_e0

theorem v_sq_scalar (m : M) : v Q m * v Q m = algebraMap _ _ (Q m) :=
  (ι_sq_scalar _ _).trans <| by simp
#align clifford_algebra.equiv_even.v_sq_scalar CliffordAlgebra.EquivEven.v_sq_scalar

theorem neg_e0_mul_v (m : M) : -(e0 Q * v Q m) = v Q m * e0 Q :=
  by
  refine' neg_eq_of_add_eq_zero_right ((ι_mul_ι_add_swap _ _).trans _)
  dsimp [QuadraticForm.polar]
  simp only [add_zero, MulZeroClass.mul_zero, mul_one, zero_add, neg_zero, QuadraticForm.map_zero,
    add_sub_cancel, sub_self, map_zero, zero_sub]
#align clifford_algebra.equiv_even.neg_e0_mul_v CliffordAlgebra.EquivEven.neg_e0_mul_v

theorem neg_v_mul_e0 (m : M) : -(v Q m * e0 Q) = e0 Q * v Q m :=
  by
  rw [neg_eq_iff_eq_neg]
  exact (neg_e0_mul_v _ m).symm
#align clifford_algebra.equiv_even.neg_v_mul_e0 CliffordAlgebra.EquivEven.neg_v_mul_e0

@[simp]
theorem e0_mul_v_mul_e0 (m : M) : e0 Q * v Q m * e0 Q = v Q m := by
  rw [← neg_v_mul_e0, ← neg_mul, mul_assoc, e0_mul_e0, mul_neg_one, neg_neg]
#align clifford_algebra.equiv_even.e0_mul_v_mul_e0 CliffordAlgebra.EquivEven.e0_mul_v_mul_e0

@[simp]
theorem reverse_v (m : M) : reverse (v Q m) = v Q m :=
  reverse_ι _
#align clifford_algebra.equiv_even.reverse_v CliffordAlgebra.EquivEven.reverse_v

@[simp]
theorem involute_v (m : M) : involute (v Q m) = -v Q m :=
  involute_ι _
#align clifford_algebra.equiv_even.involute_v CliffordAlgebra.EquivEven.involute_v

@[simp]
theorem reverse_e0 : reverse (e0 Q) = e0 Q :=
  reverse_ι _
#align clifford_algebra.equiv_even.reverse_e0 CliffordAlgebra.EquivEven.reverse_e0

@[simp]
theorem involute_e0 : involute (e0 Q) = -e0 Q :=
  involute_ι _
#align clifford_algebra.equiv_even.involute_e0 CliffordAlgebra.EquivEven.involute_e0

end EquivEven

open EquivEven

/-- The embedding from the smaller algebra into the new larger one. -/
def toEven : CliffordAlgebra Q →ₐ[R] CliffordAlgebra.even (q' Q) :=
  by
  refine' CliffordAlgebra.lift Q ⟨_, fun m => _⟩
  · refine' LinearMap.codRestrict _ _ fun m => Submodule.mem_supᵢ_of_mem ⟨2, rfl⟩ _
    exact (LinearMap.mulLeft R <| e0 Q).comp (v Q)
    rw [Subtype.coe_mk, pow_two]
    exact Submodule.mul_mem_mul (LinearMap.mem_range_self _ _) (LinearMap.mem_range_self _ _)
  · ext1
    dsimp only [Subalgebra.coe_mul, LinearMap.codRestrict_apply, LinearMap.comp_apply,
      LinearMap.mulLeft_apply, LinearMap.inl_apply, Subalgebra.coe_algebraMap]
    rw [← mul_assoc, e0_mul_v_mul_e0, v_sq_scalar]
#align clifford_algebra.to_even CliffordAlgebra.toEven

@[simp]
theorem toEven_ι (m : M) : (toEven Q (ι Q m) : CliffordAlgebra (q' Q)) = e0 Q * v Q m :=
  by
  rw [to_even, CliffordAlgebra.lift_ι_apply, LinearMap.codRestrict_apply]
  rfl
#align clifford_algebra.to_even_ι CliffordAlgebra.toEven_ι

/-- The embedding from the even subalgebra with an extra dimension into the original algebra. -/
def ofEven : CliffordAlgebra.even (q' Q) →ₐ[R] CliffordAlgebra Q :=
  by
  /-
    Recall that we need:
     * `f ⟨0,1⟩ ⟨x,0⟩ = ι x`
     * `f ⟨x,0⟩ ⟨0,1⟩ = -ι x`
     * `f ⟨x,0⟩ ⟨y,0⟩ = ι x * ι y`
     * `f ⟨0,1⟩ ⟨0,1⟩ = -1`
    -/
  let f : M × R →ₗ[R] M × R →ₗ[R] CliffordAlgebra Q :=
    ((LinearMap.Algebra.lmul R (CliffordAlgebra Q)).toLinearMap.comp <|
          (ι Q).comp (LinearMap.fst _ _ _) +
            (Algebra.linearMap R _).comp (LinearMap.snd _ _ _)).compl₂
      ((ι Q).comp (LinearMap.fst _ _ _) - (Algebra.linearMap R _).comp (LinearMap.snd _ _ _))
  have f_apply : ∀ x y, f x y = (ι Q x.1 + algebraMap R _ x.2) * (ι Q y.1 - algebraMap R _ y.2) :=
    fun x y => rfl
  have hc : ∀ (r : R) (x : CliffordAlgebra Q), Commute (algebraMap _ _ r) x := Algebra.commutes
  have hm :
    ∀ m : M × R,
      ι Q m.1 * ι Q m.1 - algebraMap R _ m.2 * algebraMap R _ m.2 = algebraMap R _ (Q' Q m) :=
    by
    intro m
    rw [ι_sq_scalar, ← RingHom.map_mul, ← RingHom.map_sub, sub_eq_add_neg, Q'_apply, sub_eq_add_neg]
  refine' even.lift (Q' Q) ⟨f, _, _⟩ <;> simp_rw [f_apply]
  · intro m
    rw [← (hc _ _).symm.mul_self_sub_mul_self_eq, hm]
  · intro m₁ m₂ m₃
    rw [← mul_smul_comm, ← mul_assoc, mul_assoc (_ + _), ← (hc _ _).symm.mul_self_sub_mul_self_eq',
      Algebra.smul_def, ← mul_assoc, hm]
#align clifford_algebra.of_even CliffordAlgebra.ofEven

theorem ofEven_ι (x y : M × R) :
    ofEven Q ((even.ι _).bilin x y) =
      (ι Q x.1 + algebraMap R _ x.2) * (ι Q y.1 - algebraMap R _ y.2) :=
  even.lift_ι _ _ _ _
#align clifford_algebra.of_even_ι CliffordAlgebra.ofEven_ι

theorem toEven_comp_ofEven : (toEven Q).comp (ofEven Q) = AlgHom.id R _ :=
  even.algHom_ext (q' Q) <|
    EvenHom.ext _ _ <|
      LinearMap.ext fun m₁ =>
        LinearMap.ext fun m₂ =>
          Subtype.ext <|
            let ⟨m₁, r₁⟩ := m₁
            let ⟨m₂, r₂⟩ := m₂
            calc
              ↑(toEven Q (ofEven Q ((even.ι (q' Q)).bilin (m₁, r₁) (m₂, r₂)))) =
                  (e0 Q * v Q m₁ + algebraMap R _ r₁) * (e0 Q * v Q m₂ - algebraMap R _ r₂) :=
                by
                rw [of_even_ι, AlgHom.map_mul, AlgHom.map_add, AlgHom.map_sub, AlgHom.commutes,
                  AlgHom.commutes, Subalgebra.coe_mul, Subalgebra.coe_add, Subalgebra.coe_sub,
                  to_even_ι, to_even_ι, Subalgebra.coe_algebraMap, Subalgebra.coe_algebraMap]
              _ =
                  e0 Q * v Q m₁ * (e0 Q * v Q m₂) + r₁ • e0 Q * v Q m₂ - r₂ • e0 Q * v Q m₁ -
                    algebraMap R _ (r₁ * r₂) :=
                by
                rw [mul_sub, add_mul, add_mul, ← Algebra.commutes, ← Algebra.smul_def, ← map_mul, ←
                  Algebra.smul_def, sub_add_eq_sub_sub, smul_mul_assoc, smul_mul_assoc]
              _ =
                  v Q m₁ * v Q m₂ + r₁ • e0 Q * v Q m₂ + v Q m₁ * r₂ • e0 Q +
                    r₁ • e0 Q * r₂ • e0 Q :=
                by
                have h1 : e0 Q * v Q m₁ * (e0 Q * v Q m₂) = v Q m₁ * v Q m₂ := by
                  rw [← mul_assoc, e0_mul_v_mul_e0]
                have h2 : -(r₂ • e0 Q * v Q m₁) = v Q m₁ * r₂ • e0 Q := by
                  rw [mul_smul_comm, smul_mul_assoc, ← smul_neg, neg_e0_mul_v]
                have h3 : -algebraMap R _ (r₁ * r₂) = r₁ • e0 Q * r₂ • e0 Q := by
                  rw [Algebra.algebraMap_eq_smul_one, smul_mul_smul, e0_mul_e0, smul_neg]
                rw [sub_eq_add_neg, sub_eq_add_neg, h1, h2, h3]
              _ = ι _ (m₁, r₁) * ι _ (m₂, r₂) := by
                rw [ι_eq_v_add_smul_e0, ι_eq_v_add_smul_e0, mul_add, add_mul, add_mul, add_assoc]

#align clifford_algebra.to_even_comp_of_even CliffordAlgebra.toEven_comp_ofEven

theorem ofEven_comp_toEven : (ofEven Q).comp (toEven Q) = AlgHom.id R _ :=
  CliffordAlgebra.hom_ext <|
    LinearMap.ext fun m =>
      calc
        ofEven Q (toEven Q (ι Q m)) = ofEven Q ⟨_, (toEven Q (ι Q m)).Prop⟩ := by
          rw [Subtype.coe_eta]
        _ = (ι Q 0 + algebraMap R _ 1) * (ι Q m - algebraMap R _ 0) :=
          by
          simp_rw [to_even_ι]
          exact of_even_ι Q _ _
        _ = ι Q m := by rw [map_one, map_zero, map_zero, sub_zero, zero_add, one_mul]

#align clifford_algebra.of_even_comp_to_even CliffordAlgebra.ofEven_comp_toEven

/-- Any clifford algebra is isomorphic to the even subalgebra of a clifford algebra with an extra
dimension (that is, with vector space `M × R`), with a quadratic form evaluating to `-1` on that new
basis vector. -/
@[simps]
def equivEven : CliffordAlgebra Q ≃ₐ[R] CliffordAlgebra.even (q' Q) :=
  AlgEquiv.ofAlgHom (toEven Q) (ofEven Q) (toEven_comp_ofEven Q) (ofEven_comp_toEven Q)
#align clifford_algebra.equiv_even CliffordAlgebra.equivEven

/-- The representation of the clifford conjugate (i.e. the reverse of the involute) in the even
subalgebra is just the reverse of the representation. -/
theorem coe_toEven_reverse_involute (x : CliffordAlgebra Q) :
    ↑(toEven Q (reverse (involute x))) = reverse (toEven Q x : CliffordAlgebra (q' Q)) :=
  by
  induction x using CliffordAlgebra.induction
  case h_grade0 r => simp only [AlgHom.commutes, Subalgebra.coe_algebraMap, reverse.commutes]
  case h_grade1 m =>
    simp only [involute_ι, Subalgebra.coe_neg, to_even_ι, reverse.map_mul, reverse_v, reverse_e0,
      reverse_ι, neg_e0_mul_v, map_neg]
  case h_mul x y hx hy => simp only [map_mul, Subalgebra.coe_mul, reverse.map_mul, hx, hy]
  case h_add x y hx hy => simp only [map_add, Subalgebra.coe_add, hx, hy]
#align clifford_algebra.coe_to_even_reverse_involute CliffordAlgebra.coe_toEven_reverse_involute

/-! ### Constructions needed for `clifford_algebra.even_equiv_even_neg` -/

/-- One direction of `clifford_algebra.even_equiv_even_neg` -/
def evenToNeg (Q' : QuadraticForm R M) (h : Q' = -Q) :
    CliffordAlgebra.even Q →ₐ[R] CliffordAlgebra.even Q' :=
  even.lift Q
    { bilin := -(even.ι Q' : _).bilin
      contract := fun m => by
        simp_rw [LinearMap.neg_apply, even_hom.contract, h, QuadraticForm.neg_apply, map_neg,
          neg_neg]
      contract_mid := fun m₁ m₂ m₃ => by
        simp_rw [LinearMap.neg_apply, neg_mul_neg, even_hom.contract_mid, h,
          QuadraticForm.neg_apply, smul_neg, neg_smul] }
#align clifford_algebra.even_to_neg CliffordAlgebra.evenToNeg

@[simp]
theorem evenToNeg_ι (Q' : QuadraticForm R M) (h : Q' = -Q) (m₁ m₂ : M) :
    evenToNeg Q Q' h ((even.ι Q).bilin m₁ m₂) = -(even.ι Q').bilin m₁ m₂ :=
  even.lift_ι _ _ m₁ m₂
#align clifford_algebra.even_to_neg_ι CliffordAlgebra.evenToNeg_ι

theorem evenToNeg_comp_evenToNeg (Q' : QuadraticForm R M) (h : Q' = -Q) (h' : Q = -Q') :
    (evenToNeg Q' Q h').comp (evenToNeg Q Q' h) = AlgHom.id R _ :=
  by
  ext (m₁ m₂) : 4
  dsimp only [even_hom.compr₂_bilin, LinearMap.compr₂_apply, AlgHom.toLinearMap_apply,
    AlgHom.comp_apply, AlgHom.id_apply]
  rw [even_to_neg_ι, map_neg, even_to_neg_ι, neg_neg]
#align clifford_algebra.even_to_neg_comp_even_to_neg CliffordAlgebra.evenToNeg_comp_evenToNeg

/-- The even subalgebras of the algebras with quadratic form `Q` and `-Q` are isomorphic.

Stated another way, `𝒞ℓ⁺(p,q,r)` and `𝒞ℓ⁺(q,p,r)` are isomorphic. -/
@[simps]
def evenEquivEvenNeg : CliffordAlgebra.even Q ≃ₐ[R] CliffordAlgebra.even (-Q) :=
  AlgEquiv.ofAlgHom (evenToNeg Q _ rfl) (evenToNeg (-Q) _ (neg_neg _).symm)
    (evenToNeg_comp_evenToNeg _ _ _ _) (evenToNeg_comp_evenToNeg _ _ _ _)
#align clifford_algebra.even_equiv_even_neg CliffordAlgebra.evenEquivEvenNeg

end CliffordAlgebra


import Lib.Tactic

namespace Decidable

variable {P Q} [Hdec : Decidable P]
variable (h : P ↔ Q)

def congr : Decidable Q :=
match Hdec with
| isTrue hp => isTrue <| h.mp hp
| isFalse hnp => isFalse <| mt h.mpr hnp

end Decidable

namespace Classical

theorem iff_iff_and_or_and {p q} :
  (p ↔ q) ↔ (p ∧ q) ∨ (¬ p ∧ ¬ q) := by
constructor <;> intros h
. simp [h, and_self, Classical.em]
. cases h <;> auto

@[simp]
theorem not_exists (p : α → Prop) :
  ¬ (∃ x, p x) ↔ ∀ x, ¬ p x := by
constructor <;> intros h
next =>
  intros x Hp
  apply h; clear h
  exists x
next =>
  intros h'
  cases h' with | intro y h' =>
  apply (h _ h')

@[simp low]
theorem not_forall (p : α → Prop) :
  ¬ (∀ x, p x) ↔ ∃ x, ¬ p x := by
constructor <;> intros h
next =>
  apply byContradiction; intros h₀
  apply h; clear h; intro x
  apply byContradiction; intros h₁
  apply h₀; clear h₀
  exists x
next =>
  intros h₀
  cases h with | intro x h =>
  apply h; clear h
  apply h₀

@[simp mid]
theorem not_implies {p q : Prop} :
  ¬ (p → q) ↔ p ∧ ¬ q := by
rw [not_forall]
constructor <;> intros h <;> cases h
<;> constructor <;> assumption

@[simp]
theorem not_not (p : Prop) : ¬ ¬ p ↔ p := by
constructor <;> intros h
next =>
  apply byContradiction; intro h'
  apply (h h')
next =>
  intros h'
  apply h' h

@[simp]
theorem not_iff_not (p q : Prop) :
  (¬ p ↔ ¬ q) ↔ (p ↔ q) := by
constructor <;> intros h
focus
  rw [← not_not p, h, not_not]
  apply Iff.refl
focus
  rw [h]
  apply Iff.refl

@[simp]
theorem not_or (p q : Prop) : ¬ (p ∨ q) ↔ ¬ p ∧ ¬ q := by
constructor
focus
  intros h₀; constructor <;>
    intros h₁ <;>
    apply h₀
  { left; assumption }
  { right; assumption }
focus
  intros h hpq; cases h with | intro hp hq =>
  cases hpq <;> contradiction

@[simp]
theorem not_and (p q : Prop) : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q := by
rw [← not_iff_not, not_or]
repeat rw [not_not]
apply Iff.refl

theorem not_and_iff_implies (p q : Prop) : ¬ (p ∧ q) ↔ p → ¬ q := by
rw [not_and]
by_cases h : p <;>
simp only [h, false_or, true_or, true_implies, false_implies, iff_self]

theorem not_implies_self_implies :
  (¬ p → p) → p := by
by_cases h : p <;> auto

macro "negate_goal " h:ident : tactic =>
  `(apply not_implies_self_implies; intro $h)

end Classical


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.functor

/-!
# Isomorphisms

This file defines isomorphisms between objects of a category.

## Main definitions

- `structure iso` : a bundled isomorphism between two objects of a category;
- `class is_iso` : an unbundled version of `iso`;
  note that `is_iso f` is a `Prop`, and only asserts the existence of an inverse.
  Of course, this inverse is unique, so it doesn't cost us much to use choice to retrieve it.
- `inv f`, for the inverse of a morphism with `[is_iso f]`
- `as_iso` : convert from `is_iso` to `iso` (noncomputable);
- `of_iso` : convert from `iso` to `is_iso`;
- standard operations on isomorphisms (composition, inverse etc)

## Notations

- `X ≅ Y` : same as `iso X Y`;
- `α ≪≫ β` : composition of two isomorphisms; it is called `iso.trans`

## Tags

category, category theory, isomorphism
-/

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

namespace category_theory
open category

/--
An isomorphism (a.k.a. an invertible morphism) between two objects of a category.
The inverse morphism is bundled.

See also `category_theory.core` for the category with the same objects and isomorphisms playing
the role of morphisms.

See https://stacks.math.columbia.edu/tag/0017.
-/
structure iso {C : Type u} [category.{v} C] (X Y : C) :=
(hom : X ⟶ Y)
(inv : Y ⟶ X)
(hom_inv_id' : hom ≫ inv = 𝟙 X . obviously)
(inv_hom_id' : inv ≫ hom = 𝟙 Y . obviously)

restate_axiom iso.hom_inv_id'
restate_axiom iso.inv_hom_id'
attribute [simp, reassoc] iso.hom_inv_id iso.inv_hom_id

infixr ` ≅ `:10  := iso             -- type as \cong or \iso

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

namespace iso

@[ext] lemma ext ⦃α β : X ≅ Y⦄ (w : α.hom = β.hom) : α = β :=
suffices α.inv = β.inv, by cases α; cases β; cc,
calc α.inv
    = α.inv ≫ (β.hom ≫ β.inv) : by rw [iso.hom_inv_id, category.comp_id]
... = (α.inv ≫ α.hom) ≫ β.inv : by rw [category.assoc, ←w]
... = β.inv                   : by rw [iso.inv_hom_id, category.id_comp]

/-- Inverse isomorphism. -/
@[symm] def symm (I : X ≅ Y) : Y ≅ X :=
{ hom := I.inv,
  inv := I.hom,
  hom_inv_id' := I.inv_hom_id',
  inv_hom_id' := I.hom_inv_id' }

@[simp] lemma symm_hom (α : X ≅ Y) : α.symm.hom = α.inv := rfl
@[simp] lemma symm_inv (α : X ≅ Y) : α.symm.inv = α.hom := rfl

@[simp] lemma symm_mk {X Y : C} (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id) :
  iso.symm {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id} =
    {hom := inv, inv := hom, hom_inv_id' := inv_hom_id, inv_hom_id' := hom_inv_id} := rfl

@[simp] lemma symm_symm_eq {X Y : C} (α : X ≅ Y) : α.symm.symm = α :=
by cases α; refl

@[simp] lemma symm_eq_iff {X Y : C} {α β : X ≅ Y} : α.symm = β.symm ↔ α = β :=
⟨λ h, symm_symm_eq α ▸ symm_symm_eq β ▸ congr_arg symm h, congr_arg symm⟩

/-- Identity isomorphism. -/
@[refl, simps] def refl (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X }

instance : inhabited (X ≅ X) := ⟨iso.refl X⟩

@[simp] lemma refl_symm (X : C) : (iso.refl X).symm = iso.refl X := rfl

/-- Composition of two isomorphisms -/
@[trans, simps] def trans (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
{ hom := α.hom ≫ β.hom,
  inv := β.inv ≫ α.inv }

infixr ` ≪≫ `:80 := iso.trans -- type as `\ll \gg`.

@[simp] lemma trans_mk {X Y Z : C}
  (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id)
  (hom' : Y ⟶ Z) (inv' : Z ⟶ Y) (hom_inv_id') (inv_hom_id') (hom_inv_id'') (inv_hom_id'') :
  iso.trans
    {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id}
    {hom := hom', inv := inv', hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id'} =
  { hom := hom ≫ hom', inv := inv' ≫ inv, hom_inv_id' := hom_inv_id'',
    inv_hom_id' := inv_hom_id''} :=
rfl

@[simp] lemma trans_symm (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).symm = β.symm ≪≫ α.symm := rfl
@[simp] lemma trans_assoc {Z' : C} (α : X ≅ Y) (β : Y ≅ Z) (γ : Z ≅ Z') :
  (α ≪≫ β) ≪≫ γ = α ≪≫ β ≪≫ γ :=
by ext; simp only [trans_hom, category.assoc]

@[simp] lemma refl_trans (α : X ≅ Y) : (iso.refl X) ≪≫ α = α := by ext; apply category.id_comp
@[simp] lemma trans_refl (α : X ≅ Y) : α ≪≫ (iso.refl Y) = α := by ext; apply category.comp_id

@[simp] lemma symm_self_id (α : X ≅ Y) : α.symm ≪≫ α = iso.refl Y := ext α.inv_hom_id
@[simp] lemma self_symm_id (α : X ≅ Y) : α ≪≫ α.symm = iso.refl X := ext α.hom_inv_id

@[simp] lemma symm_self_id_assoc (α : X ≅ Y) (β : Y ≅ Z) : α.symm ≪≫ α ≪≫ β = β :=
by rw [← trans_assoc, symm_self_id, refl_trans]

@[simp] lemma self_symm_id_assoc (α : X ≅ Y) (β : X ≅ Z) : α ≪≫ α.symm ≪≫ β = β :=
by rw [← trans_assoc, self_symm_id, refl_trans]

lemma inv_comp_eq (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : α.inv ≫ f = g ↔ f = α.hom ≫ g :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_inv_comp (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : g = α.inv ≫ f ↔ α.hom ≫ g = f :=
(inv_comp_eq α.symm).symm

lemma comp_inv_eq (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ α.inv = g ↔ f = g ≫ α.hom :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_comp_inv (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ α.inv ↔ g ≫ α.hom = f :=
(comp_inv_eq α.symm).symm

lemma inv_eq_inv (f g : X ≅ Y) : f.inv = g.inv ↔ f.hom = g.hom :=
have ∀{X Y : C} (f g : X ≅ Y), f.hom = g.hom → f.inv = g.inv, from λ X Y f g h, by rw [ext h],
⟨this f.symm g.symm, this f g⟩

lemma hom_comp_eq_id (α : X ≅ Y) {f : Y ⟶ X} : α.hom ≫ f = 𝟙 X ↔ f = α.inv :=
by rw [←eq_inv_comp, comp_id]

lemma comp_hom_eq_id (α : X ≅ Y) {f : Y ⟶ X} : f ≫ α.hom = 𝟙 Y ↔ f = α.inv :=
by rw [←eq_comp_inv, id_comp]

lemma hom_eq_inv (α : X ≅ Y) (β : Y ≅ X) : α.hom = β.inv ↔ β.hom = α.inv :=
by { erw [inv_eq_inv α.symm β, eq_comm], refl }

end iso

/-- `is_iso` typeclass expressing that a morphism is invertible. -/
class is_iso (f : X ⟶ Y) : Prop :=
(out : ∃ inv : Y ⟶ X, f ≫ inv = 𝟙 X ∧ inv ≫ f = 𝟙 Y)

/--
The inverse of a morphism `f` when we have `[is_iso f]`.
-/
noncomputable def inv (f : X ⟶ Y) [I : is_iso f] := classical.some I.1

namespace is_iso

@[simp, reassoc] lemma hom_inv_id (f : X ⟶ Y) [I : is_iso f] : f ≫ inv f = 𝟙 X :=
(classical.some_spec I.1).left
@[simp, reassoc] lemma inv_hom_id (f : X ⟶ Y) [I : is_iso f] : inv f ≫ f = 𝟙 Y :=
(classical.some_spec I.1).right

end is_iso

open is_iso

/-- Reinterpret a morphism `f` with an `is_iso f` instance as an `iso`. -/
noncomputable
def as_iso (f : X ⟶ Y) [h : is_iso f] : X ≅ Y := ⟨f, inv f, hom_inv_id f, inv_hom_id f⟩

@[simp] lemma as_iso_hom (f : X ⟶ Y) [is_iso f] : (as_iso f).hom = f := rfl
@[simp] lemma as_iso_inv (f : X ⟶ Y) [is_iso f] : (as_iso f).inv = inv f := rfl

namespace is_iso

@[priority 100] -- see Note [lower instance priority]
instance epi_of_iso (f : X ⟶ Y) [is_iso f] : epi f  :=
{ left_cancellation := λ Z g h w,
  -- This is an interesting test case for better rewrite automation.
  by rw [← is_iso.inv_hom_id_assoc f g, w, is_iso.inv_hom_id_assoc f h] }
@[priority 100] -- see Note [lower instance priority]
instance mono_of_iso (f : X ⟶ Y) [is_iso f] : mono f :=
{ right_cancellation := λ Z g h w,
  by rw [← category.comp_id g, ← category.comp_id h, ← is_iso.hom_inv_id f, ← category.assoc, w,
    ← category.assoc] }

@[ext] lemma inv_eq_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : inv f = g :=
begin
  apply (cancel_epi f).mp,
  simp [hom_inv_id],
end

lemma inv_eq_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : inv f = g :=
begin
  apply (cancel_mono f).mp,
  simp [inv_hom_id],
end

@[ext] lemma eq_inv_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : g = inv f :=
(inv_eq_of_hom_inv_id hom_inv_id).symm

lemma eq_inv_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : g = inv f :=
(inv_eq_of_inv_hom_id inv_hom_id).symm

instance id (X : C) : is_iso (𝟙 X) :=
⟨⟨𝟙 X, by simp⟩⟩

instance of_iso (f : X ≅ Y) : is_iso f.hom :=
⟨⟨f.inv, by simp⟩⟩

instance of_iso_inv (f : X ≅ Y) : is_iso f.inv :=
is_iso.of_iso f.symm

variables {f g : X ⟶ Y} {h : Y ⟶ Z}

instance inv_is_iso [is_iso f] : is_iso (inv f) :=
is_iso.of_iso_inv (as_iso f)

instance comp_is_iso [is_iso f] [is_iso h] : is_iso (f ≫ h) :=
is_iso.of_iso $ (as_iso f) ≪≫ (as_iso h)

@[simp] lemma inv_id : inv (𝟙 X) = 𝟙 X := by { ext, simp, }
@[simp] lemma inv_comp [is_iso f] [is_iso h] : inv (f ≫ h) = inv h ≫ inv f := by { ext, simp, }
@[simp] lemma inv_inv [is_iso f] : inv (inv f) = f := by { ext, simp, }
@[simp] lemma iso.inv_inv (f : X ≅ Y) : inv (f.inv) = f.hom := by { ext, simp, }
@[simp] lemma iso.inv_hom (f : X ≅ Y) : inv (f.hom) = f.inv := by { ext, simp, }

@[simp]
lemma inv_comp_eq (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : inv α ≫ f = g ↔ f = α ≫ g :=
(as_iso α).inv_comp_eq

@[simp]
lemma eq_inv_comp (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : g = inv α ≫ f ↔ α ≫ g = f :=
(as_iso α).eq_inv_comp

@[simp]
lemma comp_inv_eq (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ inv α = g ↔ f = g ≫ α :=
(as_iso α).comp_inv_eq

@[simp]
lemma eq_comp_inv (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ inv α ↔ g ≫ α = f :=
(as_iso α).eq_comp_inv

end is_iso

open is_iso

lemma eq_of_inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] (p : inv f = inv g) : f = g :=
begin
  apply (cancel_epi (inv f)).1,
  erw [inv_hom_id, p, inv_hom_id],
end

lemma is_iso.inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] : inv f = inv g ↔ f = g :=
iso.inv_eq_inv (as_iso f) (as_iso g)

lemma hom_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : g ≫ f = 𝟙 X ↔ f = inv g :=
(as_iso g).hom_comp_eq_id

lemma comp_hom_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : f ≫ g = 𝟙 Y ↔ f = inv g :=
(as_iso g).comp_hom_eq_id

namespace iso

@[ext] lemma inv_ext {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : f.inv = g :=
begin
  apply (cancel_epi f.hom).mp,
  simp [hom_inv_id],
end

@[ext] lemma inv_ext' {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : g = f.inv :=
by { symmetry, ext, assumption, }

/-!
All these cancellation lemmas can be solved by `simp [cancel_mono]` (or `simp [cancel_epi]`),
but with the current design `cancel_mono` is not a good `simp` lemma,
because it generates a typeclass search.

When we can see syntactically that a morphism is a `mono` or an `epi`
because it came from an isomorphism, it's fine to do the cancellation via `simp`.

In the longer term, it might be worth exploring making `mono` and `epi` structures,
rather than typeclasses, with coercions back to `X ⟶ Y`.
Presumably we could write `X ↪ Y` and `X ↠ Y`.
-/

@[simp] lemma cancel_iso_hom_left {X Y Z : C} (f : X ≅ Y) (g g' : Y ⟶ Z) :
  f.hom ≫ g = f.hom ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_inv_left {X Y Z : C} (f : Y ≅ X) (g g' : Y ⟶ Z) :
  f.inv ≫ g = f.inv ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_hom_right {X Y Z : C} (f f' : X ⟶ Y) (g : Y ≅ Z) :
  f ≫ g.hom = f' ≫ g.hom ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_iso_inv_right {X Y Z : C} (f f' : X ⟶ Y) (g : Z ≅ Y) :
  f ≫ g.inv = f' ≫ g.inv ↔ f = f' :=
by simp only [cancel_mono]

/-
Unfortunately cancelling an isomorphism from the right of a chain of compositions is awkward.
We would need separate lemmas for each chain length (worse: for each pair of chain lengths).

We provide two more lemmas, for case of three morphisms, because this actually comes up in practice,
but then stop.
-/

@[simp] lemma cancel_iso_hom_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Y ≅ Z) :
  f ≫ g ≫ h.hom = f' ≫ g' ≫ h.hom ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_iso_inv_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Z ≅ Y) :
  f ≫ g ≫ h.inv = f' ≫ g' ≫ h.inv ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

end iso

namespace functor

universes u₁ v₁ u₂ v₂
variables {D : Type u₂}

variables [category.{v₂} D]

/-- A functor `F : C ⥤ D` sends isomorphisms `i : X ≅ Y` to isomorphisms `F.obj X ≅ F.obj Y` -/
@[simps]
def map_iso (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : F.obj X ≅ F.obj Y :=
{ hom := F.map i.hom,
  inv := F.map i.inv,
  hom_inv_id' := by rw [←map_comp, iso.hom_inv_id, ←map_id],
  inv_hom_id' := by rw [←map_comp, iso.inv_hom_id, ←map_id] }

@[simp] lemma map_iso_symm (F : C ⥤ D) {X Y : C} (i : X ≅ Y) :
  F.map_iso i.symm = (F.map_iso i).symm :=
rfl

@[simp] lemma map_iso_trans (F : C ⥤ D) {X Y Z : C} (i : X ≅ Y) (j : Y ≅ Z) :
  F.map_iso (i ≪≫ j) = (F.map_iso i) ≪≫ (F.map_iso j) :=
by ext; apply functor.map_comp

@[simp] lemma map_iso_refl (F : C ⥤ D) (X : C) : F.map_iso (iso.refl X) = iso.refl (F.obj X) :=
iso.ext $ F.map_id X

instance map_is_iso (F : C ⥤ D) (f : X ⟶ Y) [is_iso f] : is_iso (F.map f) :=
is_iso.of_iso $ F.map_iso (as_iso f)

@[simp]

lemma map_hom_inv (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map f ≫ F.map (inv f) = 𝟙 (F.obj X) :=
by simp

lemma map_inv_hom (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map (inv f) ≫ F.map f = 𝟙 (F.obj Y) :=
by simp

end functor

section partial_order
variables {α β : Type*} [partial_order α] [partial_order β]

lemma iso.to_eq {X Y : α} (f : X ≅ Y) : X = Y :=
le_antisymm (le_of_hom f.hom) (le_of_hom f.inv)

end partial_order

end category_theory


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default

universes u

namespace Mathlib

namespace rbnode

inductive is_node_of {α : Type u} : rbnode α → rbnode α → α → rbnode α → Prop
where
| of_red : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (red_node l v r) l v r
| of_black : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (black_node l v r) l v r

def lift {α : Type u} (lt : α → α → Prop) : Option α → Option α → Prop :=
  sorry

inductive is_searchable {α : Type u} (lt : α → α → Prop) : rbnode α → Option α → Option α → Prop
where
| leaf_s : ∀ {lo hi : Option α}, lift lt lo hi → is_searchable lt leaf lo hi
| red_s : ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
  is_searchable lt l lo (some v) → is_searchable lt r (some v) hi → is_searchable lt (red_node l v r) lo hi
| black_s : ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
  is_searchable lt l lo (some v) → is_searchable lt r (some v) hi → is_searchable lt (black_node l v r) lo hi

theorem lo_lt_hi {α : Type u} {t : rbnode α} {lt : α → α → Prop} [is_trans α lt] {lo : Option α} {hi : Option α} : is_searchable lt t lo hi → lift lt lo hi := sorry

theorem is_searchable_of_is_searchable_of_incomp {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {lo : Option α} {hi : α} {hi' : α} (hc : ¬lt hi' hi ∧ ¬lt hi hi') (hs : is_searchable lt t lo (some hi)) : is_searchable lt t lo (some hi') := sorry

theorem is_searchable_of_incomp_of_is_searchable {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {lo : α} {lo' : α} {hi : Option α} (hc : ¬lt lo' lo ∧ ¬lt lo lo') (hs : is_searchable lt t (some lo) hi) : is_searchable lt t (some lo') hi := sorry

theorem is_searchable_some_low_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop} [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : α} {hi : Option α} {lo' : α} (hlt : lt lo' lo) (hs : is_searchable lt t (some lo) hi) : is_searchable lt t (some lo') hi := sorry

theorem is_searchable_none_low_of_is_searchable_some_low {α : Type u} {lt : α → α → Prop} [DecidableRel lt] {t : rbnode α} {y : α} {hi : Option α} (hlt : is_searchable lt t (some y) hi) : is_searchable lt t none hi := sorry

theorem is_searchable_some_high_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop} [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : Option α} {hi : α} {hi' : α} (hlt : lt hi hi') (hs : is_searchable lt t lo (some hi)) : is_searchable lt t lo (some hi') := sorry

theorem is_searchable_none_high_of_is_searchable_some_high {α : Type u} {lt : α → α → Prop} [DecidableRel lt] {t : rbnode α} {lo : Option α} {y : α} (hlt : is_searchable lt t lo (some y)) : is_searchable lt t lo none := sorry

theorem range {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {x : α} {lo : Option α} {hi : Option α} : is_searchable lt t lo hi → mem lt x t → lift lt lo (some x) ∧ lift lt (some x) hi := sorry

theorem lt_of_mem_left {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo hi → is_node_of t l y r → ∀ {x : α}, mem lt x l → lt x y := sorry

theorem lt_of_mem_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo hi → is_node_of t l y r → ∀ {z : α}, mem lt z r → lt y z := sorry

theorem lt_of_mem_left_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo hi → is_node_of t l y r → ∀ {x z : α}, mem lt x l → mem lt z r → lt x z := sorry

inductive is_red_black {α : Type u} : rbnode α → color → ℕ → Prop
where
| leaf_rb : is_red_black leaf color.black 0
| red_rb : ∀ {v : α} {l r : rbnode α} {n : ℕ},
  is_red_black l color.black n → is_red_black r color.black n → is_red_black (red_node l v r) color.red n
| black_rb : ∀ {v : α} {l r : rbnode α} {n : ℕ} {c₁ c₂ : color},
  is_red_black l c₁ n → is_red_black r c₂ n → is_red_black (black_node l v r) color.black (Nat.succ n)

theorem depth_min {α : Type u} {c : color} {n : ℕ} {t : rbnode α} : is_red_black t c n → depth min t ≥ n := sorry

theorem depth_max' {α : Type u} {c : color} {n : ℕ} {t : rbnode α} : is_red_black t c n → depth max t ≤ upper c n := sorry

theorem depth_max {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) : depth max t ≤ bit0 1 * n + 1 :=
  le_trans (depth_max' h) (upper_le c n)

theorem balanced {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) : bit0 1 * depth min t + 1 ≥ depth max t :=
  le_trans (depth_max h) (nat.succ_le_succ (nat.mul_le_mul_left (bit0 1) (depth_min h)))


/-
Copyright (c) 2021 Alena Gusakov, Bhavik Mehta, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alena Gusakov, Bhavik Mehta, Kyle Miller
-/
import data.fintype.basic
import data.set.finite

/-!
# Hall's Marriage Theorem for finite index types

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This module proves the basic form of Hall's theorem.
In constrast to the theorem described in `combinatorics.hall.basic`, this
version requires that the indexed family `t : ι → finset α` have `ι` be finite.
The `combinatorics.hall.basic` module applies a compactness argument to this version
to remove the `finite` constraint on `ι`.

The modules are split like this since the generalized statement
depends on the topology and category theory libraries, but the finite
case in this module has few dependencies.

A description of this formalization is in [Gusakov2021].

## Main statements

* `finset.all_card_le_bUnion_card_iff_exists_injective'` is Hall's theorem with
  a finite index set.  This is elsewhere generalized to
  `finset.all_card_le_bUnion_card_iff_exists_injective`.

## Tags

Hall's Marriage Theorem, indexed families
-/

open finset

universes u v

namespace hall_marriage_theorem

variables {ι : Type u} {α : Type v} [decidable_eq α] {t : ι → finset α}

section fintype
variables [fintype ι]

lemma hall_cond_of_erase {x : ι} (a : α)
  (ha : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card)
  (s' : finset {x' : ι | x' ≠ x}) :
  s'.card ≤ (s'.bUnion (λ x', (t x').erase a)).card :=
begin
  haveI := classical.dec_eq ι,
  specialize ha (s'.image coe),
  rw [nonempty.image_iff, finset.card_image_of_injective s' subtype.coe_injective] at ha,
  by_cases he : s'.nonempty,
  { have ha' : s'.card < (s'.bUnion (λ x, t x)).card,
    { convert ha he (λ h, by simpa [←h] using mem_univ x) using 2,
      ext x,
      simp only [mem_image, mem_bUnion, exists_prop, set_coe.exists,
                 exists_and_distrib_right, exists_eq_right, subtype.coe_mk], },
    rw ←erase_bUnion,
    by_cases hb : a ∈ s'.bUnion (λ x, t x),
    { rw card_erase_of_mem hb,
      exact nat.le_pred_of_lt ha' },
    { rw erase_eq_of_not_mem hb,
      exact nat.le_of_lt ha' }, },
  { rw [nonempty_iff_ne_empty, not_not] at he,
    subst s',
    simp },
end

/--
First case of the inductive step: assuming that
`∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card`
and that the statement of **Hall's Marriage Theorem** is true for all
`ι'` of cardinality ≤ `n`, then it is true for `ι` of cardinality `n + 1`.
-/
lemma hall_hard_inductive_step_A {n : ℕ} (hn : fintype.card ι = n + 1)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (ih : ∀ {ι' : Type u} [fintype ι'] (t' : ι' → finset α),
        by exactI fintype.card ι' ≤ n →
                  (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                  ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x)
  (ha : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  haveI : nonempty ι := fintype.card_pos_iff.mp (hn.symm ▸ nat.succ_pos _),
  haveI := classical.dec_eq ι,
  /- Choose an arbitrary element `x : ι` and `y : t x`. -/
  let x := classical.arbitrary ι,
  have tx_ne : (t x).nonempty,
  { rw ←finset.card_pos,
    calc 0 < 1 : nat.one_pos
       ... ≤ (finset.bUnion {x} t).card : ht {x}
       ... = (t x).card : by rw finset.singleton_bUnion, },
  choose y hy using tx_ne,
  /- Restrict to everything except `x` and `y`. -/
  let ι' := {x' : ι | x' ≠ x},
  let t' : ι' → finset α := λ x', (t x').erase y,
  have card_ι' : fintype.card ι' = n :=
    calc fintype.card ι' = fintype.card ι - 1 : set.card_ne_eq _
                     ... = n : by { rw [hn, nat.add_succ_sub_one, add_zero], },
  rcases ih t' card_ι'.le (hall_cond_of_erase y ha) with ⟨f', hfinj, hfr⟩,
  /- Extend the resulting function. -/
  refine ⟨λ z, if h : z = x then y else f' ⟨z, h⟩, _, _⟩,
  { rintro z₁ z₂,
    have key : ∀ {x}, y ≠ f' x,
    { intros x h,
      simpa [←h] using hfr x, },
    by_cases h₁ : z₁ = x; by_cases h₂ : z₂ = x; simp [h₁, h₂, hfinj.eq_iff, key, key.symm], },
  { intro z,
    split_ifs with hz,
    { rwa hz },
    { specialize hfr ⟨z, hz⟩,
      rw mem_erase at hfr,
      exact hfr.2, }, },
end

lemma hall_cond_of_restrict {ι : Type u} {t : ι → finset α} {s : finset ι}
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (s' : finset (s : set ι)) :
  s'.card ≤ (s'.bUnion (λ a', t a')).card :=
begin
  classical,
  rw ← card_image_of_injective s' subtype.coe_injective,
  convert ht (s'.image coe) using 1,
  apply congr_arg,
  ext y,
  simp,
end

lemma hall_cond_of_compl {ι : Type u} {t : ι → finset α} {s : finset ι}
  (hus : s.card = (s.bUnion t).card)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (s' : finset (sᶜ : set ι)) :
  s'.card ≤ (s'.bUnion (λ x', t x' \ s.bUnion t)).card :=
begin
  haveI := classical.dec_eq ι,
  have disj : disjoint s (s'.image coe),
  { simp only [disjoint_left, not_exists, mem_image, exists_prop, set_coe.exists,
               exists_and_distrib_right, exists_eq_right, subtype.coe_mk],
    intros x hx hc h,
    exact absurd hx hc, },
  have : s'.card = (s ∪ s'.image coe).card - s.card,
  { simp [disj, card_image_of_injective _ subtype.coe_injective], },
  rw [this, hus],
  refine (tsub_le_tsub_right (ht _) _).trans _,
  rw ← card_sdiff,
  { refine (card_le_of_subset _).trans le_rfl,
    intros t,
    simp only [mem_bUnion, mem_sdiff, not_exists, mem_image, and_imp, mem_union,
               exists_and_distrib_right, exists_imp_distrib],
    rintro x (hx | ⟨x', hx', rfl⟩) rat hs,
    { exact (hs x hx rat).elim },
    { exact ⟨⟨x', hx', rat⟩, hs⟩, } },
  { apply bUnion_subset_bUnion_of_subset_left,
    apply subset_union_left }
end

/--
Second case of the inductive step: assuming that
`∃ (s : finset ι), s ≠ univ → s.card = (s.bUnion t).card`
and that the statement of **Hall's Marriage Theorem** is true for all
`ι'` of cardinality ≤ `n`, then it is true for `ι` of cardinality `n + 1`.
-/
lemma hall_hard_inductive_step_B {n : ℕ} (hn : fintype.card ι = n + 1)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (ih : ∀ {ι' : Type u} [fintype ι'] (t' : ι' → finset α),
        by exactI fintype.card ι' ≤ n →
                  (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                  ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x)
  (s : finset ι)
  (hs : s.nonempty)
  (hns : s ≠ univ)
  (hus : s.card = (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  haveI := classical.dec_eq ι,
  /- Restrict to `s` -/
  let t' : s → finset α := λ x', t x',
  rw nat.add_one at hn,
  have card_ι'_le : fintype.card s ≤ n,
  { apply nat.le_of_lt_succ,
    calc fintype.card s = s.card : fintype.card_coe _
                    ... < fintype.card ι : (card_lt_iff_ne_univ _).mpr hns
                    ... = n.succ : hn },
  rcases ih t' card_ι'_le (hall_cond_of_restrict ht) with ⟨f', hf', hsf'⟩,
  /- Restrict to `sᶜ` in the domain and `(s.bUnion t)ᶜ` in the codomain. -/
  set ι'' := (s : set ι)ᶜ with ι''_def,
  let t'' : ι'' → finset α := λ a'', t a'' \ s.bUnion t,
  have card_ι''_le : fintype.card ι'' ≤ n,
  { simp_rw [← nat.lt_succ_iff, ← hn, ι'', ← finset.coe_compl, coe_sort_coe],
    rwa [fintype.card_coe, card_compl_lt_iff_nonempty] },
  rcases ih t'' card_ι''_le (hall_cond_of_compl hus ht) with ⟨f'', hf'', hsf''⟩,
  /- Put them together -/
  have f'_mem_bUnion : ∀ {x'} (hx' : x' ∈ s), f' ⟨x', hx'⟩ ∈ s.bUnion t,
  { intros x' hx',
    rw mem_bUnion,
    exact ⟨x', hx', hsf' _⟩, },
  have f''_not_mem_bUnion : ∀ {x''} (hx'' : ¬ x'' ∈ s), ¬ f'' ⟨x'', hx''⟩ ∈ s.bUnion t,
  { intros x'' hx'',
    have h := hsf'' ⟨x'', hx''⟩,
    rw mem_sdiff at h,
    exact h.2, },
  have im_disj : ∀ (x' x'' : ι) (hx' : x' ∈ s) (hx'' : ¬x'' ∈ s), f' ⟨x', hx'⟩ ≠ f'' ⟨x'', hx''⟩,
  { intros _ _ hx' hx'' h,
    apply f''_not_mem_bUnion hx'',
    rw ←h,
    apply f'_mem_bUnion, },
  refine ⟨λ x, if h : x ∈ s then f' ⟨x, h⟩ else f'' ⟨x, h⟩, _, _⟩,
  { exact hf'.dite _ hf'' im_disj },
  { intro x,
    split_ifs with h,
    { exact hsf' ⟨x, h⟩ },
    { exact sdiff_subset _ _ (hsf'' ⟨x, h⟩) } }
end

end fintype

variables [finite ι]

/--
Here we combine the two inductive steps into a full strong induction proof,
completing the proof the harder direction of **Hall's Marriage Theorem**.
-/
theorem hall_hard_inductive
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  casesI nonempty_fintype ι,
  unfreezingI
  { induction hn : fintype.card ι using nat.strong_induction_on with n ih generalizing ι },
  rcases n with _|_,
  { rw fintype.card_eq_zero_iff at hn,
    exactI ⟨is_empty_elim, is_empty_elim, is_empty_elim⟩, },
  { have ih' : ∀ (ι' : Type u) [fintype ι'] (t' : ι' → finset α),
                 by exactI fintype.card ι' ≤ n →
                    (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                    ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x,
    { introsI ι' _ _ hι' ht',
      exact ih _ (nat.lt_succ_of_le hι') ht' _ rfl },
    by_cases h : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card,
    { exact hall_hard_inductive_step_A hn ht ih' h, },
    { push_neg at h,
      rcases h with ⟨s, sne, snu, sle⟩,
      exact hall_hard_inductive_step_B hn ht ih' s sne snu (nat.le_antisymm (ht _) sle), } },
end

end hall_marriage_theorem

/--
This is the version of **Hall's Marriage Theorem** in terms of indexed
families of finite sets `t : ι → finset α` with `ι` finite.
It states that there is a set of distinct representatives if and only
if every union of `k` of the sets has at least `k` elements.

See `finset.all_card_le_bUnion_card_iff_exists_injective` for a version
where the `finite ι` constraint is removed.
-/
theorem finset.all_card_le_bUnion_card_iff_exists_injective'
  {ι α : Type*} [finite ι] [decidable_eq α] (t : ι → finset α) :
  (∀ (s : finset ι), s.card ≤ (s.bUnion t).card) ↔
    (∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x) :=
begin
  split,
  { exact hall_marriage_theorem.hall_hard_inductive },
  { rintro ⟨f, hf₁, hf₂⟩ s,
    rw ←card_image_of_injective s hf₁,
    apply card_le_of_subset,
    intro _,
    rw [mem_image, mem_bUnion],
    rintros ⟨x, hx, rfl⟩,
    exact ⟨x, hx, hf₂ x⟩, },
end


/-
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.fin_category
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.pullbacks
import data.fintype.basic

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

universes v' u' v u

noncomputable theory

open category_theory

namespace category_theory.limits

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

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J` instance
has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_limits : Prop :=
(out (J : Type v) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_limits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_limits
  (J : Type v) [small_category J] [fin_category J] [has_finite_limits C] :
  has_limits_of_shape J C := has_finite_limits.out J

@[priority 100]
instance has_finite_limits_of_has_limits_of_size [has_limits_of_size.{v' u'} C] :
  has_finite_limits C :=
⟨λ J hJ hJ', by { haveI := has_limits_of_size_shrink.{0 0} C,
  exact has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all limits, it has finite limits. -/
@[priority 100]
instance has_finite_limits_of_has_limits [has_limits C] : has_finite_limits C := infer_instance

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J` instance
has a colimit.

This is often called 'finitely cocomplete'.
-/
class has_finite_colimits : Prop :=
(out (J : Type v) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_colimits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_colimits
  (J : Type v) [small_category J] [fin_category J] [has_finite_colimits C] :
  has_colimits_of_shape J C := has_finite_colimits.out J

@[priority 100]
instance has_finite_colimits_of_has_colimits_of_size [has_colimits_of_size.{v' u'} C] :
  has_finite_colimits C :=
⟨λ J hJ hJ', by { haveI := has_colimits_of_size_shrink.{0 0} C,
  exact has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all colimits, it has finite colimits. -/
@[priority 100]
instance has_finite_colimits_of_has_colimits [has_colimits C] : has_finite_colimits C :=
infer_instance

section

open walking_parallel_pair walking_parallel_pair_hom

instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
{ elems := [walking_parallel_pair.zero, walking_parallel_pair.one].to_finset,
  complete := λ x, by { cases x; simp } }

local attribute [tidy] tactic.case_bash

instance (j j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
{ elems := walking_parallel_pair.rec_on j
    (walking_parallel_pair.rec_on j' [walking_parallel_pair_hom.id zero].to_finset
      [left, right].to_finset)
    (walking_parallel_pair.rec_on j' ∅ [walking_parallel_pair_hom.id one].to_finset),
  complete := by tidy }

end

instance : fin_category walking_parallel_pair := { }

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
example [has_finite_limits C] : has_equalizers C := by apply_instance

/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
example [has_finite_colimits C] : has_coequalizers C := by apply_instance

variables {J : Type v}

local attribute [tidy] tactic.case_bash

namespace wide_pullback_shape

instance fintype_obj [fintype J] : fintype (wide_pullback_shape J) :=
by { rw wide_pullback_shape, apply_instance }

instance fintype_hom (j j' : wide_pullback_shape J) :
  fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j',
    { cases j,
      { exact {hom.id none} },
      { exact {hom.term j} } },
    { by_cases some j' = j,
      { rw h,
        exact {hom.id j} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pullback_shape

namespace wide_pushout_shape

instance fintype_obj [fintype J] : fintype (wide_pushout_shape J) :=
by { rw wide_pushout_shape, apply_instance }

instance fintype_hom (j j' : wide_pushout_shape J) :
  fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j,
    { cases j',
      { exact {hom.id none} },
      { exact {hom.init j'} } },
    { by_cases some j = j',
      { rw h,
        exact {hom.id j'} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pushout_shape

instance fin_category_wide_pullback [fintype J] :
  fin_category (wide_pullback_shape J) :=
{ fintype_hom := wide_pullback_shape.fintype_hom }

instance fin_category_wide_pushout [fintype J] :
  fin_category (wide_pushout_shape J) :=
{ fintype_hom := wide_pushout_shape.fintype_hom }

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_wide_pullbacks : Prop :=
(out (J : Type v) [fintype J] : has_limits_of_shape (wide_pullback_shape J) C)

instance has_limits_of_shape_wide_pullback_shape
  (J : Type v) [fintype J] [has_finite_wide_pullbacks C] :
  has_limits_of_shape (wide_pullback_shape J) C :=
by { haveI := @has_finite_wide_pullbacks.out C _ _ J, apply_instance }

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
class has_finite_wide_pushouts : Prop :=
(out (J : Type v) [fintype J] : has_colimits_of_shape (wide_pushout_shape J) C)

instance has_colimits_of_shape_wide_pushout_shape
  (J : Type v) [fintype J] [has_finite_wide_pushouts C] :
  has_colimits_of_shape (wide_pushout_shape J) C :=
by { haveI := @has_finite_wide_pushouts.out C _ _ J, apply_instance }

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
lemma has_finite_wide_pushouts_of_has_finite_limits [has_finite_colimits C] :
  has_finite_wide_pushouts C :=
⟨λ J _, by exactI has_finite_colimits.out _⟩

instance fintype_walking_pair : fintype walking_pair :=
{ elems := {walking_pair.left, walking_pair.right},
  complete := λ x, by { cases x; simp } }

/-- Pullbacks are finite limits, so if `C` has all finite limits, it also has all pullbacks -/
example [has_finite_wide_pullbacks C] : has_pullbacks C := by apply_instance

/-- Pushouts are finite colimits, so if `C` has all finite colimits, it also has all pushouts -/
example [has_finite_wide_pushouts C] : has_pushouts C := by apply_instance

end category_theory.limits