/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.type_tags
import Mathlib.algebra.group.units_hom
import Mathlib.algebra.ring.basic
import Mathlib.data.equiv.mul_add
import Mathlib.PostPort

universes u_1 u_2 l u v

namespace Mathlib

/-!
# Unbundled monoid and group homomorphisms (deprecated)

This file defines typeclasses for unbundled monoid and group homomorphisms. Though these classes are
deprecated, they are still widely used in mathlib, and probably will not go away before Lean 4
because Lean 3 often fails to coerce a bundled homomorphism to a function.

## main definitions

is_monoid_hom (deprecated), is_group_hom (deprecated)

## implementation notes

There's a coercion from bundled homs to fun, and the canonical
notation is to use the bundled hom as a function via this coercion.

There is no `group_hom` -- the idea is that `monoid_hom` is used.
The constructor for `monoid_hom` needs a proof of `map_one` as well
as `map_mul`; a separate constructor `monoid_hom.mk'` will construct
group homs (i.e. monoid homs between groups) given only a proof
that multiplication is preserved,

## Tags

is_group_hom, is_monoid_hom, monoid_hom

-/

/--
We have lemmas stating that the composition of two morphisms is again a morphism.
Since composition is reducible, type class inference will always succeed in applying these instances.
For example when the goal is just `⊢ is_mul_hom f` the instance `is_mul_hom.comp`
will still succeed, unifying `f` with `f ∘ (λ x, x)`.  This causes type class inference to loop.
To avoid this, we do not make these lemmas instances.
-/
/-- Predicate for maps which preserve an addition. -/
class is_add_hom {α : Type u_1} {β : Type u_2} [Add α] [Add β] (f : α → β) where
  map_add : ∀ (x y : α), f (x + y) = f x + f y

/-- Predicate for maps which preserve a multiplication. -/
class is_mul_hom {α : Type u_1} {β : Type u_2} [Mul α] [Mul β] (f : α → β) where
  map_mul : ∀ (x y : α), f (x * y) = f x * f y

namespace is_mul_hom

/-- The identity map preserves multiplication. -/
protected instance Mathlib.is_add_hom.id {α : Type u} [Add α] : is_add_hom id :=
  is_add_hom.mk fun (_x _x_1 : α) => rfl

/-- The composition of maps which preserve multiplication, also preserves multiplication. -/
-- see Note [no instance on morphisms]

theorem comp {α : Type u} {β : Type v} [Mul α] [Mul β] {γ : Type u_1} [Mul γ] (f : α → β)
    (g : β → γ) [is_mul_hom f] [hg : is_mul_hom g] : is_mul_hom (g ∘ f) :=
  sorry

/-- A product of maps which preserve multiplication,
preserves multiplication when the target is commutative. -/
instance mul {α : Type u_1} {β : Type u_2} [semigroup α] [comm_semigroup β] (f : α → β) (g : α → β)
    [is_mul_hom f] [is_mul_hom g] : is_mul_hom fun (a : α) => f a * g a :=
  sorry

/-- The inverse of a map which preserves multiplication,
preserves multiplication when the target is commutative. -/
instance inv {α : Type u_1} {β : Type u_2} [Mul α] [comm_group β] (f : α → β) [is_mul_hom f] :
    is_mul_hom fun (a : α) => f a⁻¹ :=
  mk fun (a b : α) => Eq.symm (map_mul f a b) ▸ mul_inv (f a) (f b)

end is_mul_hom

/-- Predicate for add_monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
class is_add_monoid_hom {α : Type u} {β : Type v} [add_monoid α] [add_monoid β] (f : α → β)
    extends is_add_hom f where
  map_zero : f 0 = 0

/-- Predicate for monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
class is_monoid_hom {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α → β) extends is_mul_hom f
    where
  map_one : f 1 = 1

namespace monoid_hom

/-!
Throughout this section, some `monoid` arguments are specified with `{}` instead of `[]`.
See note [implicit instance arguments].
-/

/-- Interpret a map `f : M → N` as a homomorphism `M →* N`. -/
def Mathlib.add_monoid_hom.of {M : Type u_1} {N : Type u_2} [mM : add_monoid M] [mN : add_monoid N]
    (f : M → N) [h : is_add_monoid_hom f] : M →+ N :=
  add_monoid_hom.mk f (is_add_monoid_hom.map_zero f) sorry

@[simp] theorem Mathlib.add_monoid_hom.coe_of {M : Type u_1} {N : Type u_2} {mM : add_monoid M}
    {mN : add_monoid N} (f : M → N) [is_add_monoid_hom f] : ⇑(add_monoid_hom.of f) = f :=
  rfl

protected instance is_monoid_hom {M : Type u_1} {N : Type u_2} {mM : monoid M} {mN : monoid N}
    (f : M →* N) : is_monoid_hom ⇑f :=
  is_monoid_hom.mk (map_one f)

end monoid_hom

namespace mul_equiv

/-- A multiplicative isomorphism preserves multiplication (deprecated). -/
protected instance Mathlib.add_equiv.is_add_hom {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (h : M ≃+ N) : is_add_hom ⇑h :=
  is_add_hom.mk (add_equiv.map_add h)

/-- A multiplicative bijection between two monoids is a monoid hom
  (deprecated -- use to_monoid_hom). -/
protected instance Mathlib.add_equiv.is_add_monoid_hom {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (h : M ≃+ N) : is_add_monoid_hom ⇑h :=
  is_add_monoid_hom.mk (add_equiv.map_zero h)

end mul_equiv

namespace is_monoid_hom

/-- A monoid homomorphism preserves multiplication. -/
theorem Mathlib.is_add_monoid_hom.map_add {α : Type u} {β : Type v} [add_monoid α] [add_monoid β]
    (f : α → β) [is_add_monoid_hom f] (x : α) (y : α) : f (x + y) = f x + f y :=
  is_add_hom.map_add f x y

end is_monoid_hom

/-- A map to a group preserving multiplication is a monoid homomorphism. -/
theorem is_monoid_hom.of_mul {α : Type u} {β : Type v} [monoid α] [group β] (f : α → β)
    [is_mul_hom f] : is_monoid_hom f :=
  sorry

namespace is_monoid_hom

/-- The identity map is a monoid homomorphism. -/
protected instance Mathlib.is_add_monoid_hom.id {α : Type u} [add_monoid α] :
    is_add_monoid_hom id :=
  is_add_monoid_hom.mk rfl

/-- The composite of two monoid homomorphisms is a monoid homomorphism. -/
theorem Mathlib.is_add_monoid_hom.comp {α : Type u} {β : Type v} [add_monoid α] [add_monoid β]
    (f : α → β) [is_add_monoid_hom f] {γ : Type u_1} [add_monoid γ] (g : β → γ)
    [is_add_monoid_hom g] : is_add_monoid_hom (g ∘ f) :=
  sorry

end is_monoid_hom

namespace is_add_monoid_hom

/-- Left multiplication in a ring is an additive monoid morphism. -/
protected instance is_add_monoid_hom_mul_left {γ : Type u_1} [semiring γ] (x : γ) :
    is_add_monoid_hom fun (y : γ) => x * y :=
  mk (mul_zero x)

/-- Right multiplication in a ring is an additive monoid morphism. -/
protected instance is_add_monoid_hom_mul_right {γ : Type u_1} [semiring γ] (x : γ) :
    is_add_monoid_hom fun (y : γ) => y * x :=
  mk (zero_mul x)

end is_add_monoid_hom

/-- Predicate for additive group homomorphism (deprecated -- use bundled `monoid_hom`). -/
class is_add_group_hom {α : Type u} {β : Type v} [add_group α] [add_group β] (f : α → β)
    extends is_add_hom f where

/-- Predicate for group homomorphisms (deprecated -- use bundled `monoid_hom`). -/
class is_group_hom {α : Type u} {β : Type v} [group α] [group β] (f : α → β) extends is_mul_hom f
    where

protected instance monoid_hom.is_group_hom {G : Type u_1} {H : Type u_2} {_x : group G} :
    ∀ {_x_1 : group H} (f : G →* H), is_group_hom ⇑f :=
  fun (f : G →* H) => is_group_hom.mk

protected instance mul_equiv.is_group_hom {G : Type u_1} {H : Type u_2} {_x : group G} :
    ∀ {_x_1 : group H} (h : G ≃* H), is_group_hom ⇑h :=
  fun (h : G ≃* H) => is_group_hom.mk

/-- Construct `is_group_hom` from its only hypothesis. The default constructor tries to get
`is_mul_hom` from class instances, and this makes some proofs fail. -/
theorem is_group_hom.mk' {α : Type u} {β : Type v} [group α] [group β] {f : α → β}
    (hf : ∀ (x y : α), f (x * y) = f x * f y) : is_group_hom f :=
  is_group_hom.mk

namespace is_group_hom

/-- A group homomorphism is a monoid homomorphism. -/
protected instance Mathlib.is_add_group_hom.to_is_add_monoid_hom {α : Type u} {β : Type v}
    [add_group α] [add_group β] (f : α → β) [is_add_group_hom f] : is_add_monoid_hom f :=
  is_add_monoid_hom.of_add f

/-- A group homomorphism sends 1 to 1. -/
theorem map_one {α : Type u} {β : Type v} [group α] [group β] (f : α → β) [is_group_hom f] :
    f 1 = 1 :=
  is_monoid_hom.map_one f

/-- A group homomorphism sends inverses to inverses. -/
theorem Mathlib.is_add_group_hom.map_neg {α : Type u} {β : Type v} [add_group α] [add_group β]
    (f : α → β) [is_add_group_hom f] (a : α) : f (-a) = -f a :=
  sorry

/-- The identity is a group homomorphism. -/
protected instance id {α : Type u} [group α] : is_group_hom id := mk

/-- The composition of two group homomorphisms is a group homomorphism. -/
theorem comp {α : Type u} {β : Type v} [group α] [group β] (f : α → β) [is_group_hom f]
    {γ : Type u_1} [group γ] (g : β → γ) [is_group_hom g] : is_group_hom (g ∘ f) :=
  mk

/-- A group homomorphism is injective iff its kernel is trivial. -/
theorem Mathlib.is_add_group_hom.injective_iff {α : Type u} {β : Type v} [add_group α] [add_group β]
    (f : α → β) [is_add_group_hom f] : function.injective f ↔ ∀ (a : α), f a = 0 → a = 0 :=
  sorry

/-- The product of group homomorphisms is a group homomorphism if the target is commutative. -/
instance Mathlib.is_add_group_hom.add {α : Type u_1} {β : Type u_2} [add_group α] [add_comm_group β]
    (f : α → β) (g : α → β) [is_add_group_hom f] [is_add_group_hom g] :
    is_add_group_hom fun (a : α) => f a + g a :=
  is_add_group_hom.mk

/-- The inverse of a group homomorphism is a group homomorphism if the target is commutative. -/
instance Mathlib.is_add_group_hom.neg {α : Type u_1} {β : Type u_2} [add_group α] [add_comm_group β]
    (f : α → β) [is_add_group_hom f] : is_add_group_hom fun (a : α) => -f a :=
  is_add_group_hom.mk

end is_group_hom

namespace ring_hom

/-!
These instances look redundant, because `deprecated.ring` provides `is_ring_hom` for a `→+*`.
Nevertheless these are harmless, and helpful for stripping out dependencies on `deprecated.ring`.
-/

protected instance is_monoid_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S]
    (f : R →+* S) : is_monoid_hom ⇑f :=
  is_monoid_hom.mk (map_one f)

protected instance is_add_monoid_hom {R : Type u_1} {S : Type u_2} [semiring R] [semiring S]
    (f : R →+* S) : is_add_monoid_hom ⇑f :=
  is_add_monoid_hom.mk (map_zero f)

protected instance is_add_group_hom {R : Type u_1} {S : Type u_2} [ring R] [ring S] (f : R →+* S) :
    is_add_group_hom ⇑f :=
  is_add_group_hom.mk

end ring_hom

/-- Inversion is a group homomorphism if the group is commutative. -/
instance inv.is_group_hom {α : Type u} [comm_group α] : is_group_hom has_inv.inv := is_group_hom.mk

namespace is_add_group_hom

/-- Additive group homomorphisms commute with subtraction. -/
theorem map_sub {α : Type u} {β : Type v} [add_group α] [add_group β] (f : α → β)
    [is_add_group_hom f] (a : α) (b : α) : f (a - b) = f a - f b :=
  sorry

end is_add_group_hom

/-- The difference of two additive group homomorphisms is an additive group
homomorphism if the target is commutative. -/
instance is_add_group_hom.sub {α : Type u_1} {β : Type u_2} [add_group α] [add_comm_group β]
    (f : α → β) (g : α → β) [is_add_group_hom f] [is_add_group_hom g] :
    is_add_group_hom fun (a : α) => f a - g a :=
  sorry

namespace units

/-- The group homomorphism on units induced by a multiplicative morphism. -/
def map' {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M → N) [is_monoid_hom f] :
    units M →* units N :=
  map (monoid_hom.of f)

@[simp] theorem coe_map' {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M → N)
    [is_monoid_hom f] (x : units M) : ↑(coe_fn (map' f) x) = f ↑x :=
  rfl

protected instance coe_is_monoid_hom {M : Type u_1} [monoid M] : is_monoid_hom coe :=
  monoid_hom.is_monoid_hom (coe_hom M)

end units

namespace is_unit

theorem map' {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M → N) {x : M} (h : is_unit x)
    [is_monoid_hom f] : is_unit (f x) :=
  map (monoid_hom.of f) h

end is_unit

theorem additive.is_add_hom {α : Type u} {β : Type v} [Mul α] [Mul β] (f : α → β) [is_mul_hom f] :
    is_add_hom f :=
  is_add_hom.mk (is_mul_hom.map_mul f)

theorem multiplicative.is_mul_hom {α : Type u} {β : Type v} [Add α] [Add β] (f : α → β)
    [is_add_hom f] : is_mul_hom f :=
  is_mul_hom.mk (is_add_hom.map_add f)

theorem additive.is_add_monoid_hom {α : Type u} {β : Type v} [monoid α] [monoid β] (f : α → β)
    [is_monoid_hom f] : is_add_monoid_hom f :=
  is_add_monoid_hom.mk (is_monoid_hom.map_one f)

theorem multiplicative.is_monoid_hom {α : Type u} {β : Type v} [add_monoid α] [add_monoid β]
    (f : α → β) [is_add_monoid_hom f] : is_monoid_hom f :=
  is_monoid_hom.mk (is_add_monoid_hom.map_zero f)

theorem additive.is_add_group_hom {α : Type u} {β : Type v} [group α] [group β] (f : α → β)
    [is_group_hom f] : is_add_group_hom f :=
  is_add_group_hom.mk

theorem multiplicative.is_group_hom {α : Type u} {β : Type v} [add_group α] [add_group β]
    (f : α → β) [is_add_group_hom f] : is_group_hom f :=
  is_group_hom.mk

end Mathlib


import ring_theory.algebra_operations
import ring_theory.localization

import for_mathlib.rings

local attribute [instance] set.pointwise_mul_semiring

namespace localization
variables {R : Type*} [comm_ring R] (s : set R) [is_submonoid s]

instance : algebra R (localization R s) :=
algebra.of_ring_hom of (by apply_instance)

end localization
namespace algebra

section
variables {R : Type*} [comm_ring R]
variables {A : Type*} [ring A] [algebra R A]
variables {B : Type*} [ring B] [algebra R B]
variables (f : A →ₐ[R] B)

lemma map_lmul_left (a : A) :
  f ∘ (lmul_left R A a) = (lmul_left R B (f a)) ∘ f :=
funext $ λ b, f.map_mul a b

lemma lmul_left_mul (a b : A) :
  lmul_left R A (a * b) = (lmul_left R A a).comp (lmul_left R A b) :=
linear_map.ext $ λ _, mul_assoc _ _ _

instance : is_monoid_hom (lmul_left R A) :=
{ map_one := linear_map.ext $ λ _, one_mul _,
  map_mul := lmul_left_mul }

end

end algebra

namespace submodule
open algebra

variables {R : Type*} [comm_ring R]

section
variables {A : Type*} [ring A] [algebra R A]
variables {B : Type*} [ring B] [algebra R B]
variables (f : A →ₐ[R] B)
variables (M N : submodule R A)

lemma map_mul : (M * N).map f.to_linear_map = M.map f.to_linear_map * N.map f.to_linear_map :=
begin
  apply le_antisymm,
  { rw [map_le_iff_le_comap, mul_le],
    intros,
    erw [mem_comap, f.map_mul],
    apply mul_mem_mul; refine ⟨_, ‹_›, rfl⟩ },
  { rw mul_le,
    rintros _ ⟨m, hm, rfl⟩ _ ⟨n, hn, rfl⟩,
    use [m * n, mul_mem_mul hm hn],
    apply f.map_mul }
end

end

/-

lemma map_eq_comap_symm {M : Type*} {N : Type*}
  [add_comm_group M] [add_comm_group N] [module R M] [module R N]
  (f : M ≃ₗ[R] N) :
  map (↑f : M →ₗ[R] N) = comap ↑f.symm :=
funext $ λ P, ext $ λ x,
begin
  rw [mem_map, mem_comap],
  split; intro h,
  { rcases h with ⟨p, h₁, h₂⟩,
    erw ← f.to_equiv.eq_symm_apply at h₂,
    rwa h₂ at h₁ },
  { exact ⟨_, h, f.apply_symm_apply x⟩ }
end

end
-/
end submodule


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.pullbacks

/-!
# Disjoint coproducts

Defines disjoint coproducts: coproducts where the intersection is initial and the coprojections
are monic.
Shows that a category with disjoint coproducts is `initial_mono_class`.

## TODO

* Adapt this to the infinitary (small) version: This is one of the conditions in Giraud's theorem
  characterising sheaf topoi.
* Construct examples (and counterexamples?), eg Type, Vec.
* Define extensive categories, and show every extensive category has disjoint coproducts.
* Define coherent categories and use this to define positive coherent categories.
-/

universes v u u₂

namespace category_theory
namespace limits

open category

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

/--
Given any pullback diagram of the form

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct diagram, then `Z` is initial, and both `X₁ ⟶ X` and `X₂ ⟶ X`
are mono.
-/
class coproduct_disjoint (X₁ X₂ : C) :=
(is_initial_of_is_pullback_of_is_coproduct :
  ∀ {X Z} {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} {f : Z ⟶ X₁} {g : Z ⟶ X₂}
    (cX : is_colimit (binary_cofan.mk pX₁ pX₂)) {comm : f ≫ pX₁ = g ≫ pX₂},
    is_limit (pullback_cone.mk _ _ comm) → is_initial Z)
(mono_inl : ∀ X (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : is_colimit (binary_cofan.mk X₁ X₂)), mono X₁)
(mono_inr : ∀ X (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : is_colimit (binary_cofan.mk X₁ X₂)), mono X₂)

/--
If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct, then `Z` is initial.
-/
def is_initial_of_is_pullback_of_is_coproduct {Z X₁ X₂ X : C} [coproduct_disjoint X₁ X₂]
  {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} (cX : is_colimit (binary_cofan.mk pX₁ pX₂))
  {f : Z ⟶ X₁} {g : Z ⟶ X₂} {comm : f ≫ pX₁ = g ≫ pX₂}
  (cZ : is_limit (pullback_cone.mk _ _ comm)) :
  is_initial Z :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct cX cZ

/--
If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓       ↓
X₂ ⟶  X₁ ⨿ X₂

`Z` is initial.
-/
noncomputable def is_initial_of_is_pullback_of_coproduct {Z X₁ X₂ : C}
  [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂]
  {f : Z ⟶ X₁} {g : Z ⟶ X₂} {comm : f ≫ (coprod.inl : X₁ ⟶ _ ⨿ X₂) = g ≫ coprod.inr}
  (cZ : is_limit (pullback_cone.mk _ _ comm)) :
  is_initial Z :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct (coprod_is_coprod _ _) cZ

/--
If the coproduct of `X₁` and `X₂` is disjoint, then provided `X₁ ⟶ X ← X₂` is a coproduct the
pullback is an initial object:

        X₁
        ↓
X₂ ⟶  X
-/
noncomputable def is_initial_of_pullback_of_is_coproduct {X X₁ X₂ : C} [coproduct_disjoint X₁ X₂]
  {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} [has_pullback pX₁ pX₂]
  (cX : is_colimit (binary_cofan.mk pX₁ pX₂)) :
  is_initial (pullback pX₁ pX₂) :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct cX (pullback_is_pullback _ _)

/--
If the coproduct of `X₁` and `X₂` is disjoint, the pullback of `X₁ ⟶ X₁ ⨿ X₂` and `X₂ ⟶ X₁ ⨿ X₂`
is initial.
-/
noncomputable def is_initial_of_pullback_of_coproduct {X₁ X₂ : C}
  [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂]
    [has_pullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr] :
  is_initial (pullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr) :=
is_initial_of_is_pullback_of_coproduct (pullback_is_pullback _ _)

instance {X₁ X₂ : C} [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂] :
  mono (coprod.inl : X₁ ⟶ X₁ ⨿ X₂) :=
coproduct_disjoint.mono_inl _ _ _ (coprod_is_coprod _ _)
instance {X₁ X₂ : C} [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂] :
  mono (coprod.inr : X₂ ⟶ X₁ ⨿ X₂) :=
coproduct_disjoint.mono_inr _ _ _ (coprod_is_coprod _ _)

/-- `C` has disjoint coproducts if every coproduct is disjoint. -/
class coproducts_disjoint (C : Type u) [category.{v} C] :=
(coproduct_disjoint : ∀ (X Y : C), coproduct_disjoint X Y)

attribute [instance, priority 999] coproducts_disjoint.coproduct_disjoint

/-- If `C` has disjoint coproducts, any morphism out of initial is mono. Note it isn't true in
general that `C` has strict initial objects, for instance consider the category of types and
partial functions. -/
lemma initial_mono_class_of_disjoint_coproducts [coproducts_disjoint C] : initial_mono_class C :=
{ is_initial_mono_from := λ I X hI,
    coproduct_disjoint.mono_inl _ _ (𝟙 X)
      { desc := λ (s : binary_cofan _ _), s.inr,
        fac' := λ s j, walking_pair.cases_on j (hI.hom_ext _ _) (id_comp _),
        uniq' := λ (s : binary_cofan _ _) m w, (id_comp _).symm.trans (w walking_pair.right) } }

end limits
end category_theory


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jeremy Avigad, Simon Hudon
-/
import data.part
import data.rel

/-!
# Partial functions

This file defines partial functions. Partial functions are like functions, except they can also be
"undefined" on some inputs. We define them as functions `α → part β`.

## Definitions

* `pfun α β`: Type of partial functions from `α` to `β`. Defined as `α → part β` and denoted
  `α →. β`.
* `pfun.dom`: Domain of a partial function. Set of values on which it is defined. Not to be confused
  with the domain of a function `α → β`, which is a type (`α` presently).
* `pfun.fn`: Evaluation of a partial function. Takes in an element and a proof it belongs to the
  partial function's `dom`.
* `pfun.as_subtype`: Returns a partial function as a function from its `dom`.
* `pfun.to_subtype`: Restricts the codomain of a function to a subtype.
* `pfun.eval_opt`: Returns a partial function with a decidable `dom` as a function `a → option β`.
* `pfun.lift`: Turns a function into a partial function.
* `pfun.id`: The identity as a partial function.
* `pfun.comp`: Composition of partial functions.
* `pfun.restrict`: Restriction of a partial function to a smaller `dom`.
* `pfun.res`: Turns a function into a partial function with a prescribed domain.
* `pfun.fix` : First return map of a partial function `f : α →. β ⊕ α`.
* `pfun.fix_induction`: A recursion principle for `pfun.fix`.

### Partial functions as relations

Partial functions can be considered as relations, so we specialize some `rel` definitions to `pfun`:
* `pfun.image`: Image of a set under a partial function.
* `pfun.ran`: Range of a partial function.
* `pfun.preimage`: Preimage of a set under a partial function.
* `pfun.core`: Core of a set under a partial function.
* `pfun.graph`: Graph of a partial function `a →. β`as a `set (α × β)`.
* `pfun.graph'`: Graph of a partial function `a →. β`as a `rel α β`.

### `pfun α` as a monad

Monad operations:
* `pfun.pure`: The monad `pure` function, the constant `x` function.
* `pfun.bind`: The monad `bind` function, pointwise `part.bind`
* `pfun.map`: The monad `map` function, pointwise `part.map`.
-/

open function

/-- `pfun α β`, or `α →. β`, is the type of partial functions from
  `α` to `β`. It is defined as `α → part β`. -/
def pfun (α β : Type*) := α → part β

infixr ` →. `:25 := pfun

namespace pfun
variables {α β γ δ : Type*}

instance : inhabited (α →. β) := ⟨λ a, part.none⟩

/-- The domain of a partial function -/
def dom (f : α →. β) : set α := {a | (f a).dom}

@[simp] lemma mem_dom (f : α →. β) (x : α) : x ∈ dom f ↔ ∃ y, y ∈ f x :=
by simp [dom, part.dom_iff_mem]

theorem dom_eq (f : α →. β) : dom f = {x | ∃ y, y ∈ f x} :=
set.ext (mem_dom f)

/-- Evaluate a partial function -/
def fn (f : α →. β) (a : α) : dom f a → β := (f a).get

@[simp] lemma fn_apply (f : α →. β) (a : α) : f.fn a = (f a).get := rfl

/-- Evaluate a partial function to return an `option` -/
def eval_opt (f : α →. β) [D : decidable_pred (∈ dom f)] (x : α) : option β :=
@part.to_option _ _ (D x)

/-- Partial function extensionality -/
theorem ext' {f g : α →. β}
  (H1 : ∀ a, a ∈ dom f ↔ a ∈ dom g)
  (H2 : ∀ a p q, f.fn a p = g.fn a q) : f = g :=
funext $ λ a, part.ext' (H1 a) (H2 a)

theorem ext {f g : α →. β} (H : ∀ a b, b ∈ f a ↔ b ∈ g a) : f = g :=
funext $ λ a, part.ext (H a)

/-- Turns a partial function into a function out of its domain. -/
def as_subtype (f : α →. β) (s : f.dom) : β := f.fn s s.2

/-- The type of partial functions `α →. β` is equivalent to
the type of pairs `(p : α → Prop, f : subtype p → β)`. -/
def equiv_subtype : (α →. β) ≃ (Σ p : α → Prop, subtype p → β) :=
⟨λ f, ⟨λ a, (f a).dom, as_subtype f⟩,
 λ f x, ⟨f.1 x, λ h, f.2 ⟨x, h⟩⟩,
 λ f, funext $ λ a, part.eta _,
 λ ⟨p, f⟩, by dsimp; congr; funext a; cases a; refl⟩

theorem as_subtype_eq_of_mem {f : α →. β} {x : α} {y : β} (fxy : y ∈ f x) (domx : x ∈ f.dom) :
  f.as_subtype ⟨x, domx⟩ = y :=
part.mem_unique (part.get_mem _) fxy

/-- Turn a total function into a partial function. -/
protected def lift (f : α → β) : α →. β := λ a, part.some (f a)

instance : has_coe (α → β) (α →. β) := ⟨pfun.lift⟩

@[simp] theorem lift_eq_coe (f : α → β) : pfun.lift f = f := rfl

@[simp] theorem coe_val (f : α → β) (a : α) :
  (f : α →. β) a = part.some (f a) := rfl

@[simp] lemma dom_coe (f : α → β) : (f : α →. β).dom = set.univ := rfl

lemma coe_injective : injective (coe : (α → β) → α →. β) :=
λ f g h, funext $ λ a, part.some_injective $ congr_fun h a

/-- Graph of a partial function `f` as the set of pairs `(x, f x)` where `x` is in the domain of
`f`. -/
def graph (f : α →. β) : set (α × β) := {p | p.2 ∈ f p.1}

/-- Graph of a partial function as a relation. `x` and `y` are related iff `f x` is defined and
"equals" `y`. -/
def graph' (f : α →. β) : rel α β := λ x y, y ∈ f x

/-- The range of a partial function is the set of values
  `f x` where `x` is in the domain of `f`. -/
def ran (f : α →. β) : set β := {b | ∃ a, b ∈ f a}

/-- Restrict a partial function to a smaller domain. -/
def restrict (f : α →. β) {p : set α} (H : p ⊆ f.dom) : α →. β :=
λ x, (f x).restrict (x ∈ p) (@H x)

@[simp]
theorem mem_restrict {f : α →. β} {s : set α} (h : s ⊆ f.dom) (a : α) (b : β) :
  b ∈ f.restrict h a ↔ a ∈ s ∧ b ∈ f a :=
by simp [restrict]

/-- Turns a function into a partial function with a prescribed domain. -/
def res (f : α → β) (s : set α) : α →. β :=
(pfun.lift f).restrict s.subset_univ

theorem mem_res (f : α → β) (s : set α) (a : α) (b : β) :
  b ∈ res f s a ↔ (a ∈ s ∧ f a = b) :=
by simp [res, @eq_comm _ b]

theorem res_univ (f : α → β) : pfun.res f set.univ = f :=
rfl

theorem dom_iff_graph (f : α →. β) (x : α) : x ∈ f.dom ↔ ∃ y, (x, y) ∈ f.graph :=
part.dom_iff_mem

theorem lift_graph {f : α → β} {a b} : (a, b) ∈ (f : α →. β).graph ↔ f a = b :=
show (∃ (h : true), f a = b) ↔ f a = b, by simp

/-- The monad `pure` function, the total constant `x` function -/
protected def pure (x : β) : α →. β := λ _, part.some x

/-- The monad `bind` function, pointwise `part.bind` -/
def bind (f : α →. β) (g : β → α →. γ) : α →. γ :=
λ a, (f a).bind (λ b, g b a)

@[simp] lemma bind_apply (f : α →. β) (g : β → α →. γ) (a : α) :
  f.bind g a = (f a).bind (λ b, g b a) := rfl

/-- The monad `map` function, pointwise `part.map` -/
def map (f : β → γ) (g : α →. β) : α →. γ :=
λ a, (g a).map f

instance : monad (pfun α) :=
{ pure := @pfun.pure _,
  bind := @pfun.bind _,
  map := @pfun.map _ }

instance : is_lawful_monad (pfun α) :=
{ bind_pure_comp_eq_map := λ β γ f x, funext $ λ a, part.bind_some_eq_map _ _,
  id_map := λ β f, by funext a; dsimp [functor.map, pfun.map]; cases f a; refl,
  pure_bind := λ β γ x f, funext $ λ a, part.bind_some.{u_1 u_2} _ (f x),
  bind_assoc := λ β γ δ f g k,
    funext $ λ a, (f a).bind_assoc (λ b, g b a) (λ b, k b a) }

theorem pure_defined (p : set α) (x : β) : p ⊆ (@pfun.pure α _ x).dom := p.subset_univ

theorem bind_defined {α β γ} (p : set α) {f : α →. β} {g : β → α →. γ}
  (H1 : p ⊆ f.dom) (H2 : ∀ x, p ⊆ (g x).dom) : p ⊆ (f >>= g).dom :=
λ a ha, (⟨H1 ha, H2 _ ha⟩ : (f >>= g).dom a)

/-- First return map. Transforms a partial function `f : α →. β ⊕ α` into the partial function
`α →. β` which sends `a : α` to the first value in `β` it hits by iterating `f`, if such a value
exists. By abusing notation to illustrate, either `f a` is in the `β` part of `β ⊕ α` (in which
case `f.fix a` returns `f a`), or it is undefined (in which case `f.fix a` is undefined as well), or
it is in the `α` part of `β ⊕ α` (in which case we repeat the procedure, so `f.fix a` will return
`f.fix (f a)`). -/
def fix (f : α →. β ⊕ α) : α →. β := λ a,
part.assert (acc (λ x y, sum.inr x ∈ f y) a) $ λ h,
@well_founded.fix_F _ (λ x y, sum.inr x ∈ f y) _
  (λ a IH, part.assert (f a).dom $ λ hf,
    by cases e : (f a).get hf with b a';
      [exact part.some b, exact IH _ ⟨hf, e⟩])
  a h

theorem dom_of_mem_fix {f : α →. β ⊕ α} {a : α} {b : β}
  (h : b ∈ f.fix a) : (f a).dom :=
let ⟨h₁, h₂⟩ := part.mem_assert_iff.1 h in
by rw well_founded.fix_F_eq at h₂; exact h₂.fst.fst

theorem mem_fix_iff {f : α →. β ⊕ α} {a : α} {b : β} :
  b ∈ f.fix a ↔ sum.inl b ∈ f a ∨ ∃ a', sum.inr a' ∈ f a ∧ b ∈ f.fix a' :=
⟨λ h, let ⟨h₁, h₂⟩ := part.mem_assert_iff.1 h in
  begin
    rw well_founded.fix_F_eq at h₂,
    simp at h₂,
    cases h₂ with h₂ h₃,
    cases e : (f a).get h₂ with b' a'; simp [e] at h₃,
    { subst b', refine or.inl ⟨h₂, e⟩ },
    { exact or.inr ⟨a', ⟨_, e⟩, part.mem_assert _ h₃⟩ }
  end,
λ h, begin
  simp [fix],
  rcases h with ⟨h₁, h₂⟩ | ⟨a', h, h₃⟩,
  { refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection part.mem_unique ⟨h₁, h₂⟩ h' },
    { rw well_founded.fix_F_eq, simp [h₁, h₂] } },
  { simp [fix] at h₃, cases h₃ with h₃ h₄,
    refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection part.mem_unique h h' with e,
      exact e ▸ h₃ },
    { cases h with h₁ h₂,
      rw well_founded.fix_F_eq, simp [h₁, h₂, h₄] } }
end⟩

/-- If advancing one step from `a` leads to `b : β`, then `f.fix a = b` -/
theorem fix_stop {f : α →. β ⊕ α} (a : α) {b : β} (hb : sum.inl b ∈ f a) : b ∈ f.fix a :=
by { rw [pfun.mem_fix_iff], exact or.inl hb, }

/-- If advancing one step from `a` on `f` leads to `a' : α`, then `f.fix a = f.fix a'` -/
theorem fix_fwd {f : α →. β ⊕ α} (a a' : α) (ha' : sum.inr a' ∈ f a) :
  f.fix a = f.fix a' :=
begin
  ext b, split,
  { intro h, obtain h' | ⟨a, h', e'⟩ := mem_fix_iff.1 h; cases part.mem_unique ha' h', exact e', },
  { intro h, rw pfun.mem_fix_iff, right, use a', exact ⟨ha', h⟩, }
end

/-- A recursion principle for `pfun.fix`. -/
@[elab_as_eliminator] def fix_induction
  {f : α →. β ⊕ α} {b : β} {C : α → Sort*} {a : α} (h : b ∈ f.fix a)
  (H : ∀ a', b ∈ f.fix a' →
    (∀ a'', sum.inr a'' ∈ f a' → C a'') → C a') : C a :=
begin
  replace h := part.mem_assert_iff.1 h,
  have := h.snd, revert this,
  induction h.fst with a ha IH, intro h₂,
  have fb : b ∈ f.fix a := (part.mem_assert_iff.2 ⟨⟨_, ha⟩, h₂⟩),
  refine H a fb (λ a'' fa'', _),
  have ha'' : b ∈ f.fix a'' := by rwa fix_fwd _ _ fa'' at fb,
  have := (part.mem_assert_iff.1 ha'').snd,
  exact IH _ fa'' ⟨ha _ fa'', this⟩ this,
end

/--
Another induction lemma for `b ∈ f.fix a` which allows one to prove a predicate `P` holds for
`a` given that `f a` inherits `P` from `a` and `P` holds for preimages of `b`.
-/
@[elab_as_eliminator]
def fix_induction'
  (f : α →. β ⊕ α) (b : β) {C : α → Sort*} {a : α} (h : b ∈ f.fix a)
  (hbase : ∀ a_final : α, sum.inl b ∈ f a_final → C a_final)
  (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) : C a :=
begin
  refine fix_induction h (λ a' h ih, _),
  cases e : (f a').get (dom_of_mem_fix h) with b' a''; replace e : _ ∈ f a' := ⟨_, e⟩,
  { apply hbase, convert e, exact part.mem_unique h (fix_stop _ e), },
  { refine hind _ _ _ e (ih _ e), rwa fix_fwd _ _ e at h, },
end

variables (f : α →. β)

/-- Image of a set under a partial function. -/
def image (s : set α) : set β := f.graph'.image s

lemma image_def (s : set α) : f.image s = {y | ∃ x ∈ s, y ∈ f x} := rfl

lemma mem_image (y : β) (s : set α) : y ∈ f.image s ↔ ∃ x ∈ s, y ∈ f x :=
iff.rfl

lemma image_mono {s t : set α} (h : s ⊆ t) : f.image s ⊆ f.image t :=
rel.image_mono _ h

lemma image_inter (s t : set α) : f.image (s ∩ t) ⊆ f.image s ∩ f.image t :=
rel.image_inter _ s t

lemma image_union (s t : set α) : f.image (s ∪ t) = f.image s ∪ f.image t :=
rel.image_union _ s t

/-- Preimage of a set under a partial function. -/
def preimage (s : set β) : set α := rel.image (λ x y, x ∈ f y) s

lemma preimage_def (s : set β) : f.preimage s = {x | ∃ y ∈ s, y ∈ f x} := rfl

@[simp] lemma mem_preimage (s : set β) (x : α) : x ∈ f.preimage s ↔ ∃ y ∈ s, y ∈ f x := iff.rfl

lemma preimage_subset_dom (s : set β) : f.preimage s ⊆ f.dom :=
λ x ⟨y, ys, fxy⟩, part.dom_iff_mem.mpr ⟨y, fxy⟩

lemma preimage_mono {s t : set β} (h : s ⊆ t) : f.preimage s ⊆ f.preimage t :=
rel.preimage_mono _ h

lemma preimage_inter (s t : set β) : f.preimage (s ∩ t) ⊆ f.preimage s ∩ f.preimage t :=
rel.preimage_inter _ s t

lemma preimage_union (s t : set β) : f.preimage (s ∪ t) = f.preimage s ∪ f.preimage t :=
rel.preimage_union _ s t

lemma preimage_univ : f.preimage set.univ = f.dom :=
by ext; simp [mem_preimage, mem_dom]

/-- Core of a set `s : set β` with respect to a partial function `f : α →. β`. Set of all `a : α`
such that `f a ∈ s`, if `f a` is defined. -/
def core (s : set β) : set α := f.graph'.core s

lemma core_def (s : set β) : f.core s = {x | ∀ y, y ∈ f x → y ∈ s} := rfl

@[simp] lemma mem_core (x : α) (s : set β) : x ∈ f.core s ↔ ∀ y, y ∈ f x → y ∈ s := iff.rfl

lemma compl_dom_subset_core (s : set β) : f.domᶜ ⊆ f.core s :=
λ x hx y fxy,
absurd ((mem_dom f x).mpr ⟨y, fxy⟩) hx

lemma core_mono {s t : set β} (h : s ⊆ t) : f.core s ⊆ f.core t :=
rel.core_mono _ h

lemma core_inter (s t : set β) : f.core (s ∩ t) = f.core s ∩ f.core t :=
rel.core_inter _ s t

lemma mem_core_res (f : α → β) (s : set α) (t : set β) (x : α) :
  x ∈ (res f s).core t ↔ x ∈ s → f x ∈ t :=
by simp [mem_core, mem_res]

section
open_locale classical

lemma core_res (f : α → β) (s : set α) (t : set β) : (res f s).core t = sᶜ ∪ f ⁻¹' t :=
by { ext, rw mem_core_res, by_cases h : x ∈ s; simp [h] }

end

lemma core_restrict (f : α → β) (s : set β) : (f : α →. β).core s = s.preimage f :=
by ext x; simp [core_def]

lemma preimage_subset_core (f : α →. β) (s : set β) : f.preimage s ⊆ f.core s :=
λ x ⟨y, ys, fxy⟩ y' fxy',
have y = y', from part.mem_unique fxy fxy',
this ▸ ys

lemma preimage_eq (f : α →. β) (s : set β) : f.preimage s = f.core s ∩ f.dom :=
set.eq_of_subset_of_subset
  (set.subset_inter (f.preimage_subset_core s) (f.preimage_subset_dom s))
  (λ x ⟨xcore, xdom⟩,
    let y := (f x).get xdom in
    have ys : y ∈ s, from xcore _ (part.get_mem _),
    show x ∈ f.preimage s, from  ⟨(f x).get xdom, ys, part.get_mem _⟩)

lemma core_eq (f : α →. β) (s : set β) : f.core s = f.preimage s ∪ f.domᶜ :=
by rw [preimage_eq, set.union_distrib_right, set.union_comm (dom f), set.compl_union_self,
        set.inter_univ, set.union_eq_self_of_subset_right (f.compl_dom_subset_core s)]

lemma preimage_as_subtype (f : α →. β) (s : set β) :
  f.as_subtype ⁻¹' s = subtype.val ⁻¹' f.preimage s :=
begin
  ext x,
  simp only [set.mem_preimage, set.mem_set_of_eq, pfun.as_subtype, pfun.mem_preimage],
  show f.fn (x.val) _ ∈ s ↔ ∃ y ∈ s, y ∈ f (x.val),
  exact iff.intro
    (λ h, ⟨_, h, part.get_mem _⟩)
    (λ ⟨y, ys, fxy⟩,
      have f.fn x.val x.property ∈ f x.val := part.get_mem _,
      part.mem_unique fxy this ▸ ys)
end

/-- Turns a function into a partial function to a subtype. -/
def to_subtype (p : β → Prop) (f : α → β) : α →. subtype p := λ a, ⟨p (f a), subtype.mk _⟩

@[simp] lemma dom_to_subtype (p : β → Prop) (f : α → β) : (to_subtype p f).dom = {a | p (f a)} :=
rfl

@[simp] lemma to_subtype_apply (p : β → Prop) (f : α → β) (a : α) :
  to_subtype p f a = ⟨p (f a), subtype.mk _⟩ := rfl

lemma dom_to_subtype_apply_iff {p : β → Prop} {f : α → β} {a : α} :
  (to_subtype p f a).dom ↔ p (f a) := iff.rfl

lemma mem_to_subtype_iff {p : β → Prop} {f : α → β} {a : α} {b : subtype p} :
  b ∈ to_subtype p f a ↔ ↑b = f a :=
by rw [to_subtype_apply, part.mem_mk_iff, exists_subtype_mk_eq_iff, eq_comm]

/-- The identity as a partial function -/
protected def id (α : Type*) : α →. α := part.some

@[simp] lemma coe_id (α : Type*) : ((id : α → α) : α →. α) = pfun.id α := rfl
@[simp] lemma id_apply (a : α) : pfun.id α a = part.some a := rfl

/-- Composition of partial functions as a partial function. -/
def comp (f : β →. γ) (g : α →. β) : α →. γ := λ a, (g a).bind f

@[simp]

@[simp] lemma dom_comp (f : β →. γ) (g : α →. β) : (f.comp g).dom = g.preimage f.dom :=
begin
  ext,
  simp_rw [mem_preimage, mem_dom, comp_apply, part.mem_bind_iff, exists_prop,
    ←exists_and_distrib_right],
  rw exists_comm,
  simp_rw and.comm,
end

@[simp] lemma preimage_comp (f : β →. γ) (g : α →. β) (s :set γ) :
  (f.comp g).preimage s = g.preimage (f.preimage s) :=
begin
  ext,
  simp_rw [mem_preimage, comp_apply, part.mem_bind_iff, exists_prop, ←exists_and_distrib_right,
    ←exists_and_distrib_left],
  rw exists_comm,
  simp_rw [and_assoc, and.comm],
end

@[simp] lemma _root_.part.bind_comp (f : β →. γ) (g : α →. β) (a : part α) :
  a.bind (f.comp g) = (a.bind g).bind f :=
begin
  ext c,
  simp_rw [part.mem_bind_iff, comp_apply, part.mem_bind_iff, exists_prop, ←exists_and_distrib_right,
    ←exists_and_distrib_left],
  rw exists_comm,
  simp_rw and_assoc,
end

@[simp] lemma comp_assoc (f : γ →. δ) (g : β →. γ) (h : α →. β) :
  (f.comp g).comp h = f.comp (g.comp h) :=
ext $ λ _ _, by simp only [comp_apply, part.bind_comp]

-- This can't be `simp`
lemma coe_comp (g : β → γ) (f : α → β) : ((g ∘ f : α → γ) : α →. γ) = (g : β →. γ).comp f :=
ext $ λ _ _, by simp only [coe_val, comp_apply, part.bind_some]

end pfun


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jeremy Avigad, Simon Hudon
-/
import data.equiv.basic
import data.set.basic

/-!
# Partial values of a type

This file defines `part α`, the partial values of a type.

`o : part α` carries a proposition `o.dom`, its domain, along with a function `get : o.dom → α`, its
value. The rule is then that every partial value has a value but, to access it, you need to provide
a proof of the domain.

`part α` behaves the same as `option α` except that `o : option α` is decidably `none` or `some a`
for some `a : α`, while the domain of `o : part α` doesn't have to be decidable. That means you can
translate back and forth between a partial value with a decidable domain and an option, and
`option α` and `part α` are classically equivalent. In general, `part α` is bigger than `option α`.

In current mathlib, `part ℕ`, aka `enat`, is used to move decidability of the order to decidability
of `enat.find` (which is the smallest natural satisfying a predicate, or `∞` if there's none).

## Main declarations

`option`-like declarations:
* `part.none`: The partial value whose domain is `false`.
* `part.some a`: The partial value whose domain is `true` and whose value is `a`.
* `part.of_option`: Converts an `option α` to a `part α` by sending `none` to `none` and `some a` to
  `some a`.
* `part.to_option`: Converts a `part α` with a decidable domain to an `option α`.
* `part.equiv_option`: Classical equivalence between `part α` and `option α`.

Monadic structure:
* `part.bind`: `o.bind f` has value `(f (o.get _)).get _` (`f o` morally) and is defined when `o`
  and `f (o.get _)` are defined.
* `part.map`: Maps the value and keeps the same domain.

Other:
* `part.restrict`: `part.restrict p o` replaces the domain of `o : part α` by `p : Prop` so long as
  `p → o.dom`.
* `part.assert`: `assert p f` appends `p` to the domains of the values of a partial function.
* `part.unwrap`: Gets the value of a partial value regardless of its domain. Unsound.

## Notation

For `a : α`, `o : part α`, `a ∈ o` means that `o` is defined and equal to `a`. Formally, it means
`o.dom` and `o.get _ = a`.
-/

/-- `part α` is the type of "partial values" of type `α`. It
  is similar to `option α` except the domain condition can be an
  arbitrary proposition, not necessarily decidable. -/
structure {u} part (α : Type u) : Type u :=
(dom : Prop)
(get : dom → α)

namespace part
variables {α : Type*} {β : Type*} {γ : Type*}

/-- Convert a `part α` with a decidable domain to an option -/
def to_option (o : part α) [decidable o.dom] : option α :=
if h : dom o then some (o.get h) else none

/-- `part` extensionality -/
theorem ext' : ∀ {o p : part α}
  (H1 : o.dom ↔ p.dom)
  (H2 : ∀h₁ h₂, o.get h₁ = p.get h₂), o = p
| ⟨od, o⟩ ⟨pd, p⟩ H1 H2 := have t : od = pd, from propext H1,
  by cases t; rw [show o = p, from funext $ λp, H2 p p]

/-- `part` eta expansion -/
@[simp] theorem eta : Π (o : part α), (⟨o.dom, λ h, o.get h⟩ : part α) = o
| ⟨h, f⟩ := rfl

/-- `a ∈ o` means that `o` is defined and equal to `a` -/
protected def mem (a : α) (o : part α) : Prop := ∃ h, o.get h = a

instance : has_mem α (part α) := ⟨part.mem⟩

theorem mem_eq (a : α) (o : part α) : (a ∈ o) = (∃ h, o.get h = a) :=
rfl

theorem dom_iff_mem : ∀ {o : part α}, o.dom ↔ ∃ y, y ∈ o
| ⟨p, f⟩ := ⟨λh, ⟨f h, h, rfl⟩, λ⟨_, h, rfl⟩, h⟩

theorem get_mem {o : part α} (h) : get o h ∈ o := ⟨_, rfl⟩

/-- `part` extensionality -/
@[ext]
theorem ext {o p : part α} (H : ∀ a, a ∈ o ↔ a ∈ p) : o = p :=
ext' ⟨λ h, ((H _).1 ⟨h, rfl⟩).fst,
     λ h, ((H _).2 ⟨h, rfl⟩).fst⟩ $
λ a b, ((H _).2 ⟨_, rfl⟩).snd

/-- The `none` value in `part` has a `false` domain and an empty function. -/
def none : part α := ⟨false, false.rec _⟩

instance : inhabited (part α) := ⟨none⟩

@[simp] theorem not_mem_none (a : α) : a ∉ @none α := λ h, h.fst

/-- The `some a` value in `part` has a `true` domain and the
  function returns `a`. -/
def some (a : α) : part α := ⟨true, λ_, a⟩

theorem mem_unique : ∀ {a b : α} {o : part α}, a ∈ o → b ∈ o → a = b
| _ _ ⟨p, f⟩ ⟨h₁, rfl⟩ ⟨h₂, rfl⟩ := rfl

theorem mem.left_unique : relator.left_unique ((∈) : α → part α → Prop) :=
λ a o b, mem_unique

theorem get_eq_of_mem {o : part α} {a} (h : a ∈ o) (h') : get o h' = a :=
mem_unique ⟨_, rfl⟩ h

protected theorem subsingleton (o : part α) : set.subsingleton {a | a ∈ o} :=
λ a ha b hb, mem_unique ha hb

@[simp] theorem get_some {a : α} (ha : (some a).dom) : get (some a) ha = a := rfl

theorem mem_some (a : α) : a ∈ some a := ⟨trivial, rfl⟩

@[simp] theorem mem_some_iff {a b} : b ∈ (some a : part α) ↔ b = a :=
⟨λ⟨h, e⟩, e.symm, λ e, ⟨trivial, e.symm⟩⟩

theorem eq_some_iff {a : α} {o : part α} : o = some a ↔ a ∈ o :=
⟨λ e, e.symm ▸ mem_some _,
 λ ⟨h, e⟩, e ▸ ext' (iff_true_intro h) (λ _ _, rfl)⟩

theorem eq_none_iff {o : part α} : o = none ↔ ∀ a, a ∉ o :=
⟨λ e, e.symm ▸ not_mem_none, λ h, ext (by simpa)⟩

theorem eq_none_iff' {o : part α} : o = none ↔ ¬ o.dom :=
⟨λ e, e.symm ▸ id, λ h, eq_none_iff.2 (λ a h', h h'.fst)⟩

@[simp] lemma some_ne_none (x : α) : some x ≠ none :=
by { intro h, change none.dom, rw [← h], trivial }

@[simp] lemma none_ne_some (x : α) : none ≠ some x :=
(some_ne_none x).symm

lemma ne_none_iff {o : part α} : o ≠ none ↔ ∃ x, o = some x :=
begin
  split,
  { rw [ne, eq_none_iff', not_not], exact λ h, ⟨o.get h, eq_some_iff.2 (get_mem h)⟩ },
  { rintro ⟨x, rfl⟩, apply some_ne_none }
end

lemma eq_none_or_eq_some (o : part α) : o = none ∨ ∃ x, o = some x :=
or_iff_not_imp_left.2 ne_none_iff.1

@[simp] lemma some_inj {a b : α} : part.some a = some b ↔ a = b :=
function.injective.eq_iff (λ a b h, congr_fun (eq_of_heq (part.mk.inj h).2) trivial)

@[simp] lemma some_get {a : part α} (ha : a.dom) :
  part.some (part.get a ha) = a :=
eq.symm (eq_some_iff.2 ⟨ha, rfl⟩)

lemma get_eq_iff_eq_some {a : part α} {ha : a.dom} {b : α} :
  a.get ha = b ↔ a = some b :=
⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

lemma get_eq_get_of_eq (a : part α) (ha : a.dom) {b : part α} (h : a = b) :
  a.get ha = b.get (h ▸ ha) :=
by { congr, exact h }

lemma get_eq_iff_mem {o : part α} {a : α} (h : o.dom) : o.get h = a ↔ a ∈ o :=
⟨λ H, ⟨h, H⟩, λ ⟨h', H⟩, H⟩

lemma eq_get_iff_mem {o : part α} {a : α} (h : o.dom) : a = o.get h ↔ a ∈ o :=
eq_comm.trans (get_eq_iff_mem h)

@[simp] lemma none_to_option [decidable (@none α).dom] : (none : part α).to_option = option.none :=
dif_neg id

@[simp] lemma some_to_option (a : α) [decidable (some a).dom] :
  (some a).to_option = option.some a :=
dif_pos trivial

instance none_decidable : decidable (@none α).dom := decidable.false
instance some_decidable (a : α) : decidable (some a).dom := decidable.true

/-- Retrieves the value of `a : part α` if it exists, and return the provided default value
otherwise. -/
def get_or_else (a : part α) [decidable a.dom] (d : α) :=
if ha : a.dom then a.get ha else d

@[simp] lemma get_or_else_none (d : α) [decidable (none : part α).dom] : get_or_else none d = d :=
dif_neg id

@[simp] lemma get_or_else_some (a : α) (d : α) [decidable (some a).dom] :
  get_or_else (some a) d = a :=
dif_pos trivial

@[simp] theorem mem_to_option {o : part α} [decidable o.dom] {a : α} :
  a ∈ to_option o ↔ a ∈ o :=
begin
  unfold to_option,
  by_cases h : o.dom; simp [h],
  { exact ⟨λ h, ⟨_, h⟩, λ ⟨_, h⟩, h⟩ },
  { exact mt Exists.fst h }
end

/-- Converts an `option α` into a `part α`. -/
def of_option : option α → part α
| option.none     := none
| (option.some a) := some a

@[simp] theorem mem_of_option {a : α} : ∀ {o : option α}, a ∈ of_option o ↔ a ∈ o
| option.none     := ⟨λ h, h.fst.elim, λ h, option.no_confusion h⟩
| (option.some b) := ⟨λ h, congr_arg option.some h.snd,
  λ h, ⟨trivial, option.some.inj h⟩⟩

@[simp] theorem of_option_dom {α} : ∀ (o : option α), (of_option o).dom ↔ o.is_some
| option.none     := by simp [of_option, none]
| (option.some a) := by simp [of_option]

theorem of_option_eq_get {α} (o : option α) : of_option o = ⟨_, @option.get _ o⟩ :=
part.ext' (of_option_dom o) $ λ h₁ h₂, by cases o; [cases h₁, refl]

instance : has_coe (option α) (part α) := ⟨of_option⟩

@[simp] theorem mem_coe {a : α} {o : option α} :
  a ∈ (o : part α) ↔ a ∈ o := mem_of_option

@[simp] theorem coe_none : (@option.none α : part α) = none := rfl
@[simp] theorem coe_some (a : α) : (option.some a : part α) = some a := rfl

@[elab_as_eliminator] protected lemma induction_on {P : part α → Prop}
  (a : part α) (hnone : P none) (hsome : ∀ a : α, P (some a)) : P a :=
(classical.em a.dom).elim
  (λ h, part.some_get h ▸ hsome _)
  (λ h, (eq_none_iff'.2 h).symm ▸ hnone)

instance of_option_decidable : ∀ o : option α, decidable (of_option o).dom
| option.none     := part.none_decidable
| (option.some a) := part.some_decidable a

@[simp] theorem to_of_option (o : option α) : to_option (of_option o) = o :=
by cases o; refl

@[simp] theorem of_to_option (o : part α) [decidable o.dom] : of_option (to_option o) = o :=
ext $ λ a, mem_of_option.trans mem_to_option

/-- `part α` is (classically) equivalent to `option α`. -/
noncomputable def equiv_option : part α ≃ option α :=
by haveI := classical.dec; exact
⟨λ o, to_option o, of_option, λ o, of_to_option o,
 λ o, eq.trans (by dsimp; congr) (to_of_option o)⟩

/-- We give `part α` the order where everything is greater than `none`. -/
instance : partial_order (part α) :=
{ le := λ x y, ∀ i, i ∈ x → i ∈ y,
  le_refl := λ x y, id,
  le_trans := λ x y z f g i, g _ ∘ f _,
  le_antisymm := λ x y f g, part.ext $ λ z, ⟨f _, g _⟩ }

instance : order_bot (part α) :=
{ bot := none,
  bot_le := by { introv x, rintro ⟨⟨_⟩,_⟩, } }

lemma le_total_of_le_of_le {x y : part α} (z : part α) (hx : x ≤ z) (hy : y ≤ z) :
  x ≤ y ∨ y ≤ x :=
begin
  rcases part.eq_none_or_eq_some x with h | ⟨b, h₀⟩,
  { rw h, left, apply order_bot.bot_le _ },
  right, intros b' h₁,
  rw part.eq_some_iff at h₀,
  replace hx := hx _ h₀, replace hy := hy _ h₁,
  replace hx := part.mem_unique hx hy, subst hx,
  exact h₀
end

/-- `assert p f` is a bind-like operation which appends an additional condition
  `p` to the domain and uses `f` to produce the value. -/
def assert (p : Prop) (f : p → part α) : part α :=
⟨∃ h : p, (f h).dom, λha, (f ha.fst).get ha.snd⟩

/-- The bind operation has value `g (f.get)`, and is defined when all the
  parts are defined. -/
protected def bind (f : part α) (g : α → part β) : part β :=
assert (dom f) (λb, g (f.get b))

/-- The map operation for `part` just maps the value and maintains the same domain. -/
@[simps] def map (f : α → β) (o : part α) : part β :=
⟨o.dom, f ∘ o.get⟩

theorem mem_map (f : α → β) {o : part α} :
  ∀ {a}, a ∈ o → f a ∈ map f o
| _ ⟨h, rfl⟩ := ⟨_, rfl⟩

@[simp] theorem mem_map_iff (f : α → β) {o : part α} {b} :
  b ∈ map f o ↔ ∃ a ∈ o, f a = b :=
⟨match b with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩, rfl⟩ end,
 λ ⟨a, h₁, h₂⟩, h₂ ▸ mem_map f h₁⟩

@[simp] theorem map_none (f : α → β) :
  map f none = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem map_some (f : α → β) (a : α) : map f (some a) = some (f a) :=
eq_some_iff.2 $ mem_map f $ mem_some _

theorem mem_assert {p : Prop} {f : p → part α}
  : ∀ {a} (h : p), a ∈ f h → a ∈ assert p f
| _ x ⟨h, rfl⟩ := ⟨⟨x, h⟩, rfl⟩

@[simp] theorem mem_assert_iff {p : Prop} {f : p → part α} {a} :
  a ∈ assert p f ↔ ∃ h : p, a ∈ f h :=
⟨match a with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h⟩, mem_assert _ h⟩

lemma assert_pos {p : Prop} {f : p → part α} (h : p) :
  assert p f = f h :=
begin
  dsimp [assert],
  cases h' : f h,
  simp only [h', h, true_and, iff_self, exists_prop_of_true, eq_iff_iff],
  apply function.hfunext,
  { simp only [h,h',exists_prop_of_true] },
  { cc }
end

lemma assert_neg {p : Prop} {f : p → part α} (h : ¬ p) :
  assert p f = none :=
begin
  dsimp [assert,none], congr,
  { simp only [h, not_false_iff, exists_prop_of_false] },
  { apply function.hfunext,
    { simp only [h, not_false_iff, exists_prop_of_false] },
    cc },
end

theorem mem_bind {f : part α} {g : α → part β} :
  ∀ {a b}, a ∈ f → b ∈ g a → b ∈ f.bind g
| _ _ ⟨h, rfl⟩ ⟨h₂, rfl⟩ := ⟨⟨h, h₂⟩, rfl⟩

@[simp] theorem mem_bind_iff {f : part α} {g : α → part β} {b} :
  b ∈ f.bind g ↔ ∃ a ∈ f, b ∈ g a :=
⟨match b with _, ⟨⟨h₁, h₂⟩, rfl⟩ := ⟨_, ⟨_, rfl⟩, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h₁, h₂⟩, mem_bind h₁ h₂⟩

@[simp] theorem bind_none (f : α → part β) :
  none.bind f = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem bind_some (a : α) (f : α → part β) :
  (some a).bind f = f a := ext $ by simp

theorem bind_of_mem {o : part α} {a : α} (h : a ∈ o) (f : α → part β) :
  o.bind f = f a :=
by rw [eq_some_iff.2 h, bind_some]

theorem bind_some_eq_map (f : α → β) (x : part α) :
  x.bind (some ∘ f) = map f x :=
ext $ by simp [eq_comm]

theorem bind_assoc {γ} (f : part α) (g : α → part β) (k : β → part γ) :
  (f.bind g).bind k = f.bind (λ x, (g x).bind k) :=
ext $ λ a, by simp; exact
 ⟨λ ⟨_, ⟨_, h₁, h₂⟩, h₃⟩, ⟨_, h₁, _, h₂, h₃⟩,
  λ ⟨_, h₁, _, h₂, h₃⟩, ⟨_, ⟨_, h₁, h₂⟩, h₃⟩⟩

@[simp] theorem bind_map {γ} (f : α → β) (x) (g : β → part γ) :
  (map f x).bind g = x.bind (λ y, g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp

@[simp] theorem map_bind {γ} (f : α → part β) (x : part α) (g : β → γ) :
  map g (x.bind f) = x.bind (λ y, map g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp [bind_some_eq_map]

theorem map_map (g : β → γ) (f : α → β) (o : part α) :
  map g (map f o) = map (g ∘ f) o :=
by rw [← bind_some_eq_map, bind_map, bind_some_eq_map]

instance : monad part :=
{ pure := @some,
  map := @map,
  bind := @part.bind }

instance : is_lawful_monad part :=
{ bind_pure_comp_eq_map := @bind_some_eq_map,
  id_map := λ β f, by cases f; refl,
  pure_bind := @bind_some,
  bind_assoc := @bind_assoc }

theorem map_id' {f : α → α} (H : ∀ (x : α), f x = x) (o) : map f o = o :=
by rw [show f = id, from funext H]; exact id_map o

@[simp] theorem bind_some_right (x : part α) : x.bind some = x :=
by rw [bind_some_eq_map]; simp [map_id']

@[simp] theorem pure_eq_some (a : α) : pure a = some a := rfl
@[simp] theorem ret_eq_some (a : α) : return a = some a := rfl

@[simp] theorem map_eq_map {α β} (f : α → β) (o : part α) :
  f <$> o = map f o := rfl

@[simp] theorem bind_eq_bind {α β} (f : part α) (g : α → part β) :
  f >>= g = f.bind g := rfl

lemma bind_le {α} (x : part α) (f : α → part β) (y : part β) :
  x >>= f ≤ y ↔ (∀ a, a ∈ x → f a ≤ y) :=
begin
  split; intro h,
  { intros a h' b, replace h := h b,
    simp only [and_imp, exists_prop, bind_eq_bind, mem_bind_iff, exists_imp_distrib] at h,
    apply h _ h' },
  { intros b h',
    simp only [exists_prop, bind_eq_bind, mem_bind_iff] at h',
    rcases h' with ⟨a,h₀,h₁⟩, apply h _ h₀ _ h₁ },
end

instance : monad_fail part :=
{ fail := λ_ _, none, ..part.monad }

/-- `restrict p o h` replaces the domain of `o` with `p`, and is well defined when
  `p` implies `o` is defined. -/
def restrict (p : Prop) (o : part α) (H : p → o.dom) : part α :=
⟨p, λh, o.get (H h)⟩

@[simp]
theorem mem_restrict (p : Prop) (o : part α) (h : p → o.dom) (a : α) :
  a ∈ restrict p o h ↔ p ∧ a ∈ o :=
begin
  dsimp [restrict, mem_eq], split,
  { rintro ⟨h₀, h₁⟩, exact ⟨h₀, ⟨_, h₁⟩⟩ },
  rintro ⟨h₀, h₁, h₂⟩, exact ⟨h₀, h₂⟩
end

/-- `unwrap o` gets the value at `o`, ignoring the condition. This function is unsound. -/
meta def unwrap (o : part α) : α := o.get undefined

theorem assert_defined {p : Prop} {f : p → part α} :
  ∀ (h : p), (f h).dom → (assert p f).dom := exists.intro

theorem bind_defined {f : part α} {g : α → part β} :
  ∀ (h : f.dom), (g (f.get h)).dom → (f.bind g).dom := assert_defined

@[simp] theorem bind_dom {f : part α} {g : α → part β} :
  (f.bind g).dom ↔ ∃ h : f.dom, (g (f.get h)).dom := iff.rfl

end part


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Free groups as a quotient over the reduction relation `a * x * x⁻¹ * b = a * b`.

First we introduce the one step reduction relation
  `free_group.red.step`:  w * x * x⁻¹ * v   ~>   w * v
its reflexive transitive closure:
  `free_group.red.trans`
and proof that its join is an equivalence relation.

Then we introduce `free_group α` as a quotient over `free_group.red.step`.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.group_theory.subgroup
import Mathlib.PostPort

universes u v u_1 w u_2

namespace Mathlib

namespace free_group

/-- Reduction step: `w * x * x⁻¹ * v ~> w * v` -/
inductive red.step {α : Type u} : List (α × Bool) → List (α × Bool) → Prop
where
| bnot : ∀ {L₁ L₂ : List (α × Bool)} {x : α} {b : Bool}, red.step (L₁ ++ (x, b) :: (x, !b) :: L₂) (L₁ ++ L₂)

/-- Reflexive-transitive closure of red.step -/
def red {α : Type u} : List (α × Bool) → List (α × Bool) → Prop :=
  relation.refl_trans_gen sorry

theorem red.refl {α : Type u} {L : List (α × Bool)} : red L L :=
  relation.refl_trans_gen.refl

theorem red.trans {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} : red L₁ L₂ → red L₂ L₃ → red L₁ L₃ :=
  relation.refl_trans_gen.trans

namespace red

/-- Predicate asserting that word `w₁` can be reduced to `w₂` in one step, i.e. there are words
`w₃ w₄` and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
theorem step.length {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : step L₁ L₂ → list.length L₂ + bit0 1 = list.length L₁ := sorry

@[simp] theorem step.bnot_rev {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {x : α} {b : Bool} : step (L₁ ++ (x, !b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
  bool.cases_on b step.bnot step.bnot

@[simp] theorem step.cons_bnot {α : Type u} {L : List (α × Bool)} {x : α} {b : Bool} : step ((x, b) :: (x, !b) :: L) L :=
  step.bnot

@[simp] theorem step.cons_bnot_rev {α : Type u} {L : List (α × Bool)} {x : α} {b : Bool} : step ((x, !b) :: (x, b) :: L) L :=
  step.bnot_rev

theorem step.append_left {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} : step L₂ L₃ → step (L₁ ++ L₂) (L₁ ++ L₃) := sorry

theorem step.cons {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {x : α × Bool} (H : step L₁ L₂) : step (x :: L₁) (x :: L₂) :=
  step.append_left H

theorem step.append_right {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} : step L₁ L₂ → step (L₁ ++ L₃) (L₂ ++ L₃) := sorry

theorem not_step_nil {α : Type u} {L : List (α × Bool)} : ¬step [] L := sorry

theorem step.cons_left_iff {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {a : α} {b : Bool} : step ((a, b) :: L₁) L₂ ↔ (∃ (L : List (α × Bool)), step L₁ L ∧ L₂ = (a, b) :: L) ∨ L₁ = (a, !b) :: L₂ := sorry

theorem not_step_singleton {α : Type u} {L : List (α × Bool)} {p : α × Bool} : ¬step [p] L := sorry

theorem step.cons_cons_iff {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {p : α × Bool} : step (p :: L₁) (p :: L₂) ↔ step L₁ L₂ := sorry

theorem step.append_left_iff {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (L : List (α × Bool)) : step (L ++ L₁) (L ++ L₂) ↔ step L₁ L₂ := sorry

theorem step.diamond {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} {L₄ : List (α × Bool)} : step L₁ L₃ → step L₂ L₄ → L₁ = L₂ → L₃ = L₄ ∨ ∃ (L₅ : List (α × Bool)), step L₃ L₅ ∧ step L₄ L₅ := sorry

theorem step.to_red {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : step L₁ L₂ → red L₁ L₂ :=
  relation.refl_trans_gen.single

/-- Church-Rosser theorem for word reduction: If `w1 w2 w3` are words such that `w1` reduces to `w2`
and `w3` respectively, then there is a word `w4` such that `w2` and `w3` reduce to `w4` respectively. -/
theorem church_rosser {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} : red L₁ L₂ → red L₁ L₃ → relation.join red L₂ L₃ := sorry

theorem cons_cons {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {p : α × Bool} : red L₁ L₂ → red (p :: L₁) (p :: L₂) :=
  relation.refl_trans_gen_lift (List.cons p) fun (a b : List (α × Bool)) => step.cons

theorem cons_cons_iff {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (p : α × Bool) : red (p :: L₁) (p :: L₂) ↔ red L₁ L₂ := sorry

theorem append_append_left_iff {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (L : List (α × Bool)) : red (L ++ L₁) (L ++ L₂) ↔ red L₁ L₂ := sorry

theorem append_append {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} {L₄ : List (α × Bool)} (h₁ : red L₁ L₃) (h₂ : red L₂ L₄) : red (L₁ ++ L₂) (L₃ ++ L₄) := sorry

theorem to_append_iff {α : Type u} {L : List (α × Bool)} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : red L (L₁ ++ L₂) ↔ ∃ (L₃ : List (α × Bool)), ∃ (L₄ : List (α × Bool)), L = L₃ ++ L₄ ∧ red L₃ L₁ ∧ red L₄ L₂ := sorry

/-- The empty word `[]` only reduces to itself. -/
theorem nil_iff {α : Type u} {L : List (α × Bool)} : red [] L ↔ L = [] :=
  relation.refl_trans_gen_iff_eq fun (l : List (α × Bool)) => not_step_nil

/-- A letter only reduces to itself. -/
theorem singleton_iff {α : Type u} {L₁ : List (α × Bool)} {x : α × Bool} : red [x] L₁ ↔ L₁ = [x] :=
  relation.refl_trans_gen_iff_eq fun (l : List (α × Bool)) => not_step_singleton

/-- If `x` is a letter and `w` is a word such that `xw` reduces to the empty word, then `w` reduces
to `x⁻¹` -/
theorem cons_nil_iff_singleton {α : Type u} {L : List (α × Bool)} {x : α} {b : Bool} : red ((x, b) :: L) [] ↔ red L [(x, !b)] := sorry

theorem red_iff_irreducible {α : Type u} {L : List (α × Bool)} {x1 : α} {b1 : Bool} {x2 : α} {b2 : Bool} (h : (x1, b1) ≠ (x2, b2)) : red [(x1, !b1), (x2, b2)] L ↔ L = [(x1, !b1), (x2, b2)] := sorry

/-- If `x` and `y` are distinct letters and `w₁ w₂` are words such that `xw₁` reduces to `yw₂`, then
`w₁` reduces to `x⁻¹yw₂`. -/
theorem inv_of_red_of_ne {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {x1 : α} {b1 : Bool} {x2 : α} {b2 : Bool} (H1 : (x1, b1) ≠ (x2, b2)) (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) : red L₁ ((x1, !b1) :: (x2, b2) :: L₂) := sorry

theorem step.sublist {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (H : step L₁ L₂) : L₂ <+ L₁ := sorry

/-- If `w₁ w₂` are words such that `w₁` reduces to `w₂`, then `w₂` is a sublist of `w₁`. -/
theorem sublist {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : red L₁ L₂ → L₂ <+ L₁ :=
  relation.refl_trans_gen_of_transitive_reflexive (fun (l : List (α × Bool)) => list.sublist.refl l)
    (fun (a b c : List (α × Bool)) (hab : b <+ a) (hbc : c <+ b) => list.sublist.trans hbc hab)
    fun (a b : List (α × Bool)) => step.sublist

theorem sizeof_of_step {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : step L₁ L₂ → list.sizeof L₂ < list.sizeof L₁ := sorry

theorem length {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (h : red L₁ L₂) : ∃ (n : ℕ), list.length L₁ = list.length L₂ + bit0 1 * n := sorry

theorem antisymm {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (h₁₂ : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ := sorry

end red

theorem equivalence_join_red {α : Type u} : equivalence (relation.join red) := sorry

theorem join_red_of_step {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} (h : red.step L₁ L₂) : relation.join red L₁ L₂ :=
  relation.join_of_single relation.reflexive_refl_trans_gen (red.step.to_red h)

theorem eqv_gen_step_iff_join_red {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : eqv_gen red.step L₁ L₂ ↔ relation.join red L₁ L₂ := sorry

end free_group

/-- The free group over a type, i.e. the words formed by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group (α : Type u) :=
  Quot sorry

namespace free_group

/-- The canonical map from `list (α × bool)` to the free group on `α`. -/
def mk {α : Type u} (L : List (α × Bool)) : free_group α :=
  Quot.mk red.step L

@[simp] theorem quot_mk_eq_mk {α : Type u} {L : List (α × Bool)} : Quot.mk red.step L = mk L :=
  rfl

@[simp] theorem quot_lift_mk {α : Type u} {L : List (α × Bool)} (β : Type v) (f : List (α × Bool) → β) (H : ∀ (L₁ L₂ : List (α × Bool)), red.step L₁ L₂ → f L₁ = f L₂) : Quot.lift f H (mk L) = f L :=
  rfl

@[simp] theorem quot_lift_on_mk {α : Type u} {L : List (α × Bool)} (β : Type v) (f : List (α × Bool) → β) (H : ∀ (L₁ L₂ : List (α × Bool)), red.step L₁ L₂ → f L₁ = f L₂) : quot.lift_on (mk L) f H = f L :=
  rfl

protected instance has_one {α : Type u} : HasOne (free_group α) :=
  { one := mk [] }

theorem one_eq_mk {α : Type u} : 1 = mk [] :=
  rfl

protected instance inhabited {α : Type u} : Inhabited (free_group α) :=
  { default := 1 }

protected instance has_mul {α : Type u} : Mul (free_group α) :=
  { mul :=
      fun (x y : free_group α) =>
        quot.lift_on x (fun (L₁ : List (α × Bool)) => quot.lift_on y (fun (L₂ : List (α × Bool)) => mk (L₁ ++ L₂)) sorry)
          sorry }

@[simp] theorem mul_mk {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : mk L₁ * mk L₂ = mk (L₁ ++ L₂) :=
  rfl

protected instance has_inv {α : Type u} : has_inv (free_group α) :=
  has_inv.mk
    fun (x : free_group α) =>
      quot.lift_on x
        (fun (L : List (α × Bool)) => mk (list.reverse (list.map (fun (x : α × Bool) => (prod.fst x, !prod.snd x)) L)))
        sorry

@[simp] theorem inv_mk {α : Type u} {L : List (α × Bool)} : mk L⁻¹ = mk (list.reverse (list.map (fun (x : α × Bool) => (prod.fst x, !prod.snd x)) L)) :=
  rfl

protected instance group {α : Type u} : group (free_group α) :=
  group.mk Mul.mul sorry 1 sorry sorry has_inv.inv (div_inv_monoid.div._default Mul.mul sorry 1 sorry sorry has_inv.inv)
    sorry

/-- `of x` is the canonical injection from the type to the free group over that type by sending each
element to the equivalence class of the letter that is the element. -/
def of {α : Type u} (x : α) : free_group α :=
  mk [(x, tt)]

theorem red.exact {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} : mk L₁ = mk L₂ ↔ relation.join red L₁ L₂ :=
  iff.trans { mp := quot.exact red.step, mpr := quot.eqv_gen_sound } eqv_gen_step_iff_join_red

/-- The canonical injection from the type to the free group is an injection. -/
theorem of_injective {α : Type u} : function.injective of := sorry

/-- Given `f : α → β` with `β` a group, the canonical map `list (α × bool) → β` -/
def to_group.aux {α : Type u} {β : Type v} [group β] (f : α → β) : List (α × Bool) → β :=
  fun (L : List (α × Bool)) =>
    list.prod (list.map (fun (x : α × Bool) => cond (prod.snd x) (f (prod.fst x)) (f (prod.fst x)⁻¹)) L)

theorem red.step.to_group {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {β : Type v} [group β] {f : α → β} (H : red.step L₁ L₂) : to_group.aux f L₁ = to_group.aux f L₂ := sorry

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β`. Note that this is the bare function; the
group homomorphism is `to_group`. -/
def to_group.to_fun {α : Type u} {β : Type v} [group β] (f : α → β) : free_group α → β :=
  Quot.lift (to_group.aux f) sorry

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
def to_group {α : Type u} {β : Type v} [group β] (f : α → β) : free_group α →* β :=
  monoid_hom.mk' sorry sorry

@[simp] theorem to_group.mk {α : Type u} {L : List (α × Bool)} {β : Type v} [group β] {f : α → β} : coe_fn (to_group f) (mk L) =
  list.prod (list.map (fun (x : α × Bool) => cond (prod.snd x) (f (prod.fst x)) (f (prod.fst x)⁻¹)) L) :=
  rfl

@[simp] theorem to_group.of {α : Type u} {β : Type v} [group β] {f : α → β} {x : α} : coe_fn (to_group f) (of x) = f x :=
  one_mul ((fun (x : α × Bool) => cond (prod.snd x) (f (prod.fst x)) (f (prod.fst x)⁻¹)) (x, tt))

protected instance to_group.is_group_hom {α : Type u} {β : Type v} [group β] {f : α → β} : is_group_hom ⇑(to_group f) :=
  is_group_hom.mk

@[simp] theorem to_group.mul {α : Type u} {β : Type v} [group β] {f : α → β} {x : free_group α} {y : free_group α} : coe_fn (to_group f) (x * y) = coe_fn (to_group f) x * coe_fn (to_group f) y :=
  is_mul_hom.map_mul (⇑(to_group f)) x y

@[simp] theorem to_group.one {α : Type u} {β : Type v} [group β] {f : α → β} : coe_fn (to_group f) 1 = 1 :=
  is_group_hom.map_one ⇑(to_group f)

@[simp] theorem to_group.inv {α : Type u} {β : Type v} [group β] {f : α → β} {x : free_group α} : coe_fn (to_group f) (x⁻¹) = (coe_fn (to_group f) x⁻¹) :=
  is_group_hom.map_inv (⇑(to_group f)) x

theorem to_group.unique {α : Type u} {β : Type v} [group β] {f : α → β} (g : free_group α →* β) (hg : ∀ (x : α), coe_fn g (of x) = f x) {x : free_group α} : coe_fn g x = coe_fn (to_group f) x := sorry

/-- Two homomorphisms out of a free group are equal if they are equal on generators.

See note [partially-applied ext lemmas]. -/
theorem ext_hom {α : Type u} {G : Type u_1} [group G] (f : free_group α →* G) (g : free_group α →* G) (h : ∀ (a : α), coe_fn f (of a) = coe_fn g (of a)) : f = g := sorry

theorem to_group.of_eq {α : Type u} (x : free_group α) : coe_fn (to_group of) x = x :=
  Eq.symm (to_group.unique (monoid_hom.id (free_group α)) fun (x : α) => rfl)

theorem to_group.range_subset {α : Type u} {β : Type v} [group β] {f : α → β} {s : subgroup β} (H : set.range f ⊆ ↑s) : set.range ⇑(to_group f) ⊆ ↑s := sorry

theorem closure_subset {G : Type u_1} [group G] {s : set G} {t : subgroup G} (h : s ⊆ ↑t) : subgroup.closure s ≤ t :=
  eq.mpr (id (Eq.trans (propext (subgroup.closure_le t)) (propext (iff_true_intro h)))) trivial

theorem to_group.range_eq_closure {α : Type u} {β : Type v} [group β] {f : α → β} : set.range ⇑(to_group f) = ↑(subgroup.closure (set.range f)) := sorry

/-- Given `f : α → β`, the canonical map `list (α × bool) → list (β × bool)`. -/
def map.aux {α : Type u} {β : Type v} (f : α → β) (L : List (α × Bool)) : List (β × Bool) :=
  list.map (fun (x : α × Bool) => (f (prod.fst x), prod.snd x)) L

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
over `α` to the free group over `β`. Note that this is the bare function;
for the group homomorphism use `map`. -/
def map.to_fun {α : Type u} {β : Type v} (f : α → β) (x : free_group α) : free_group β :=
  quot.lift_on x (fun (L : List (α × Bool)) => mk (map.aux f L)) sorry

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map {α : Type u} {β : Type v} (f : α → β) : free_group α →* free_group β :=
  monoid_hom.mk' sorry sorry

--by rintros ⟨L₁⟩ ⟨L₂⟩; simp [map, map.aux]

@[simp] theorem map.mk {α : Type u} {L : List (α × Bool)} {β : Type v} {f : α → β} : coe_fn (map f) (mk L) = mk (list.map (fun (x : α × Bool) => (f (prod.fst x), prod.snd x)) L) :=
  rfl

@[simp] theorem map.id {α : Type u} {x : free_group α} : coe_fn (map id) x = x := sorry

@[simp] theorem map.id' {α : Type u} {x : free_group α} : coe_fn (map fun (z : α) => z) x = x :=
  map.id

theorem map.comp {α : Type u} {β : Type v} {γ : Type w} {f : α → β} {g : β → γ} {x : free_group α} : coe_fn (map g) (coe_fn (map f) x) = coe_fn (map (g ∘ f)) x := sorry

@[simp] theorem map.of {α : Type u} {β : Type v} {f : α → β} {x : α} : coe_fn (map f) (of x) = of (f x) :=
  rfl

@[simp] theorem map.mul {α : Type u} {β : Type v} {f : α → β} {x : free_group α} {y : free_group α} : coe_fn (map f) (x * y) = coe_fn (map f) x * coe_fn (map f) y :=
  is_mul_hom.map_mul (⇑(map f)) x y

@[simp] theorem map.one {α : Type u} {β : Type v} {f : α → β} : coe_fn (map f) 1 = 1 :=
  is_group_hom.map_one ⇑(map f)

@[simp] theorem map.inv {α : Type u} {β : Type v} {f : α → β} {x : free_group α} : coe_fn (map f) (x⁻¹) = (coe_fn (map f) x⁻¹) :=
  is_group_hom.map_inv (⇑(map f)) x

theorem map.unique {α : Type u} {β : Type v} {f : α → β} (g : free_group α → free_group β) [is_group_hom g] (hg : ∀ (x : α), g (of x) = of (f x)) {x : free_group α} : g x = coe_fn (map f) x := sorry

/-- Equivalent types give rise to equivalent free groups. -/
def free_group_congr {α : Type u_1} {β : Type u_2} (e : α ≃ β) : free_group α ≃ free_group β :=
  equiv.mk ⇑(map ⇑e) ⇑(map ⇑(equiv.symm e)) sorry sorry

theorem map_eq_to_group {α : Type u} {β : Type v} {f : α → β} {x : free_group α} : coe_fn (map f) x = coe_fn (to_group (of ∘ f)) x := sorry

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod {α : Type u} [group α] : free_group α →* α :=
  to_group id

@[simp] theorem prod_mk {α : Type u} {L : List (α × Bool)} [group α] : coe_fn prod (mk L) = list.prod (list.map (fun (x : α × Bool) => cond (prod.snd x) (prod.fst x) (prod.fst x⁻¹)) L) :=
  rfl

@[simp] theorem prod.of {α : Type u} [group α] {x : α} : coe_fn prod (of x) = x :=
  to_group.of

@[simp] theorem prod.mul {α : Type u} [group α] {x : free_group α} {y : free_group α} : coe_fn prod (x * y) = coe_fn prod x * coe_fn prod y :=
  to_group.mul

@[simp] theorem prod.one {α : Type u} [group α] : coe_fn prod 1 = 1 :=
  to_group.one

@[simp] theorem prod.inv {α : Type u} [group α] {x : free_group α} : coe_fn prod (x⁻¹) = (coe_fn prod x⁻¹) :=
  to_group.inv

theorem prod.unique {α : Type u} [group α] (g : free_group α →* α) (hg : ∀ (x : α), coe_fn g (of x) = x) {x : free_group α} : coe_fn g x = coe_fn prod x :=
  to_group.unique g hg

theorem to_group_eq_prod_map {α : Type u} {β : Type v} [group β] {f : α → β} {x : free_group α} : coe_fn (to_group f) x = coe_fn prod (coe_fn (map f) x) := sorry

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum {α : Type u} [add_group α] (x : free_group α) : α :=
  coe_fn prod x

@[simp] theorem sum_mk {α : Type u} {L : List (α × Bool)} [add_group α] : sum (mk L) = list.sum (list.map (fun (x : α × Bool) => cond (prod.snd x) (prod.fst x) (-prod.fst x)) L) :=
  rfl

@[simp] theorem sum.of {α : Type u} [add_group α] {x : α} : sum (of x) = x :=
  prod.of

protected instance sum.is_group_hom {α : Type u} [add_group α] : is_group_hom sum :=
  monoid_hom.is_group_hom prod

@[simp] theorem sum.mul {α : Type u} [add_group α] {x : free_group α} {y : free_group α} : sum (x * y) = sum x + sum y :=
  prod.mul

@[simp] theorem sum.one {α : Type u} [add_group α] : sum 1 = 0 :=
  prod.one

@[simp] theorem sum.inv {α : Type u} [add_group α] {x : free_group α} : sum (x⁻¹) = -sum x :=
  prod.inv

/-- The bijection between the free group on the empty type, and a type with one element. -/
def free_group_empty_equiv_unit : free_group empty ≃ Unit :=
  equiv.mk (fun (_x : free_group empty) => Unit.unit) (fun (_x : Unit) => 1) sorry sorry

/-- The bijection between the free group on a singleton, and the integers. -/
def free_group_unit_equiv_int : free_group Unit ≃ ℤ :=
  equiv.mk (fun (x : free_group Unit) => sum (monoid_hom.to_fun (map fun (_x : Unit) => 1) x))
    (fun (x : ℤ) => of Unit.unit ^ x) sorry sorry

protected instance monad : Monad free_group := sorry

protected theorem induction_on {α : Type u} {C : free_group α → Prop} (z : free_group α) (C1 : C 1) (Cp : ∀ (x : α), C (pure x)) (Ci : ∀ (x : α), C (pure x) → C (pure x⁻¹)) (Cm : ∀ (x y : free_group α), C x → C y → C (x * y)) : C z := sorry

@[simp] theorem map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) : f <$> pure x = pure (f x) :=
  map.of

@[simp] theorem map_one {α : Type u} {β : Type u} (f : α → β) : f <$> 1 = 1 :=
  map.one

@[simp] theorem map_mul {α : Type u} {β : Type u} (f : α → β) (x : free_group α) (y : free_group α) : f <$> (x * y) = f <$> x * f <$> y :=
  map.mul

@[simp] theorem map_inv {α : Type u} {β : Type u} (f : α → β) (x : free_group α) : f <$> (x⁻¹) = (f <$> x⁻¹) :=
  map.inv

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_group β) (x : α) : pure x >>= f = f x :=
  to_group.of

@[simp] theorem one_bind {α : Type u} {β : Type u} (f : α → free_group β) : 1 >>= f = 1 :=
  to_group.one

@[simp] theorem mul_bind {α : Type u} {β : Type u} (f : α → free_group β) (x : free_group α) (y : free_group α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  to_group.mul

@[simp] theorem inv_bind {α : Type u} {β : Type u} (f : α → free_group β) (x : free_group α) : x⁻¹ >>= f = (x >>= f⁻¹) :=
  to_group.inv

protected instance is_lawful_monad : is_lawful_monad free_group := sorry

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce {α : Type u} [DecidableEq α] (L : List (α × Bool)) : List (α × Bool) :=
  list.rec_on L []
    fun (hd1 : α × Bool) (tl1 ih : List (α × Bool)) =>
      list.cases_on ih [hd1]
        fun (hd2 : α × Bool) (tl2 : List (α × Bool)) =>
          ite (prod.fst hd1 = prod.fst hd2 ∧ prod.snd hd1 = !prod.snd hd2) tl2 (hd1 :: hd2 :: tl2)

@[simp] theorem reduce.cons {α : Type u} {L : List (α × Bool)} [DecidableEq α] (x : α × Bool) : reduce (x :: L) =
  list.cases_on (reduce L) [x]
    fun (hd : α × Bool) (tl : List (α × Bool)) =>
      ite (prod.fst x = prod.fst hd ∧ prod.snd x = !prod.snd hd) tl (x :: hd :: tl) :=
  rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red {α : Type u} {L : List (α × Bool)} [DecidableEq α] : red L (reduce L) := sorry

theorem reduce.not {α : Type u} [DecidableEq α] {p : Prop} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} {x : α} {b : Bool} : reduce L₁ = L₂ ++ (x, b) :: (x, !b) :: L₃ → p := sorry

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : red (reduce L₁) L₂) : reduce L₁ = L₂ := sorry

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem {α : Type u} {L : List (α × Bool)} [DecidableEq α] : reduce (reduce L) = reduce L :=
  Eq.symm (reduce.min reduce.red)

theorem reduce.step.eq {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ := sorry

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : red L₁ L₂) : reduce L₁ = reduce L₂ := sorry

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ := sorry

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
  iff.mpr red.exact (Exists.intro (reduce L₂) { left := H ▸ reduce.red, right := reduce.red })

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self {α : Type u} {L : List (α × Bool)} [DecidableEq α] : mk (reduce L) = mk L :=
  reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : red L₁ L₂) : red L₂ (reduce L₁) :=
  Eq.symm (reduce.eq_of_red H) ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word {α : Type u} [DecidableEq α] : free_group α → List (α × Bool) :=
  Quot.lift reduce sorry

theorem to_word.mk {α : Type u} [DecidableEq α] {x : free_group α} : mk (to_word x) = x :=
  quot.induction_on x fun (L : List (α × Bool)) => reduce.self

theorem to_word.inj {α : Type u} [DecidableEq α] (x : free_group α) (y : free_group α) : to_word x = to_word y → x = y :=
  quot.induction_on x fun (L₁ : List (α × Bool)) => quot.induction_on y fun (L₂ : List (α × Bool)) => reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} {L₃ : List (α × Bool)} [DecidableEq α] (H12 : red L₁ L₂) (H13 : red L₁ L₃) : Subtype fun (L₄ : List (α × Bool)) => red L₂ L₄ ∧ red L₃ L₄ :=
  { val := reduce L₁, property := sorry }

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (free_group α) :=
  function.injective.decidable_eq sorry

protected instance red.decidable_rel {α : Type u} [DecidableEq α] : DecidableRel red :=
  sorry

/-- A list containing every word that `w₁` reduces to. -/
def red.enum {α : Type u} [DecidableEq α] (L₁ : List (α × Bool)) : List (List (α × Bool)) :=
  list.filter (fun (L₂ : List (α × Bool)) => red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
  list.of_mem_filter H

theorem red.enum.complete {α : Type u} {L₁ : List (α × Bool)} {L₂ : List (α × Bool)} [DecidableEq α] (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
  list.mem_filter_of_mem (iff.mpr list.mem_sublists (red.sublist H)) H

protected instance subtype.fintype {α : Type u} {L₁ : List (α × Bool)} [DecidableEq α] : fintype (Subtype fun (L₂ : List (α × Bool)) => red L₁ L₂) :=
  fintype.subtype (list.to_finset (red.enum L₁)) sorry


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl
-/
import category_theory.epi_mono
import category_theory.functor.fully_faithful
import logic.equiv.basic

/-!
# The category `Type`.

In this section we set up the theory so that Lean's types and functions between them
can be viewed as a `large_category` in our framework.

Lean can not transparently view a function as a morphism in this category, and needs a hint in
order to be able to type check. We provide the abbreviation `as_hom f` to guide type checking,
as well as a corresponding notation `↾ f`. (Entered as `\upr `.) The notation is enabled using
`open_locale category_theory.Type`.

We provide various simplification lemmas for functors and natural transformations valued in `Type`.

We define `ulift_functor`, from `Type u` to `Type (max u v)`, and show that it is fully faithful
(but not, of course, essentially surjective).

We prove some basic facts about the category `Type`:
*  epimorphisms are surjections and monomorphisms are injections,
* `iso` is both `iso` and `equiv` to `equiv` (at least within a fixed universe),
* every type level `is_lawful_functor` gives a categorical functor `Type ⥤ Type`
  (the corresponding fact about monads is in `src/category_theory/monad/types.lean`).
-/

namespace category_theory

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

/- The `@[to_additive]` attribute is just a hint that expressions involving this instance can
  still be additivized. -/
@[to_additive category_theory.types]
instance types : large_category (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

lemma types_hom {α β : Type u} : (α ⟶ β) = (α → β) := rfl
lemma types_id (X : Type u) : 𝟙 X = id := rfl
lemma types_comp {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f := rfl

@[simp]
lemma types_id_apply (X : Type u) (x : X) : ((𝟙 X) : X → X) x = x := rfl
@[simp]
lemma types_comp_apply {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) := rfl

@[simp]
lemma hom_inv_id_apply {X Y : Type u} (f : X ≅ Y) (x : X) : f.inv (f.hom x) = x :=
congr_fun f.hom_inv_id x
@[simp]
lemma inv_hom_id_apply {X Y : Type u} (f : X ≅ Y) (y : Y) : f.hom (f.inv y) = y :=
congr_fun f.inv_hom_id y

/-- `as_hom f` helps Lean type check a function as a morphism in the category `Type`. -/
-- Unfortunately without this wrapper we can't use `category_theory` idioms, such as `is_iso f`.
abbreviation as_hom {α β : Type u} (f : α → β) : α ⟶ β := f
-- If you don't mind some notation you can use fewer keystrokes:
localized "notation  `↾` f : 200 := category_theory.as_hom f"
  in category_theory.Type -- type as \upr in VScode

section -- We verify the expected type checking behaviour of `as_hom`.
variables (α β γ : Type u) (f : α → β) (g : β → γ)

example : α → γ := ↾f ≫ ↾g
example [is_iso ↾f] : mono ↾f := by apply_instance
example [is_iso ↾f] : ↾f ≫ inv ↾f = 𝟙 α := by simp
end

namespace functor
variables {J : Type u} [category.{v} J]

/--
The sections of a functor `J ⥤ Type` are
the choices of a point `u j : F.obj j` for each `j`,
such that `F.map f (u j) = u j` for every morphism `f : j ⟶ j'`.

We later use these to define limits in `Type` and in many concrete categories.
-/
def sections (F : J ⥤ Type w) : set (Π j, F.obj j) :=
{ u | ∀ {j j'} (f : j ⟶ j'), F.map f (u j) = u j'}
end functor

namespace functor_to_types
variables {C : Type u} [category.{v} C] (F G H : C ⥤ Type w) {X Y Z : C}
variables (σ : F ⟶ G) (τ : G ⟶ H)

@[simp] lemma map_comp_apply (f : X ⟶ Y) (g : Y ⟶ Z) (a : F.obj X) :
  (F.map (f ≫ g)) a = (F.map g) ((F.map f) a) :=
by simp [types_comp]

@[simp] lemma map_id_apply (a : F.obj X) : (F.map (𝟙 X)) a = a :=
by simp [types_id]

lemma naturality (f : X ⟶ Y) (x : F.obj X) : σ.app Y ((F.map f) x) = (G.map f) (σ.app X x) :=
congr_fun (σ.naturality f) x

@[simp] lemma comp (x : F.obj X) : (σ ≫ τ).app X x = τ.app X (σ.app X x) := rfl

variables {D : Type u'} [𝒟 : category.{u'} D] (I J : D ⥤ C) (ρ : I ⟶ J) {W : D}

@[simp] lemma hcomp (x : (I ⋙ F).obj W) :
  (ρ ◫ σ).app W x = (G.map (ρ.app W)) (σ.app (I.obj W) x) :=
rfl

@[simp]

@[simp] lemma hom_inv_id_app_apply (α : F ≅ G) (X) (x) : α.inv.app X (α.hom.app X x) = x :=
congr_fun (α.hom_inv_id_app X) x
@[simp] lemma inv_hom_id_app_apply (α : F ≅ G) (X) (x) : α.hom.app X (α.inv.app X x) = x :=
congr_fun (α.inv_hom_id_app X) x

end functor_to_types

/--
The isomorphism between a `Type` which has been `ulift`ed to the same universe,
and the original type.
-/
def ulift_trivial (V : Type u) : ulift.{u} V ≅ V := by tidy

/--
The functor embedding `Type u` into `Type (max u v)`.
Write this as `ulift_functor.{5 2}` to get `Type 2 ⥤ Type 5`.
-/
def ulift_functor : Type u ⥤ Type (max u v) :=
{ obj := λ X, ulift.{v} X,
  map := λ X Y f, λ x : ulift.{v} X, ulift.up (f x.down) }

@[simp] lemma ulift_functor_map {X Y : Type u} (f : X ⟶ Y) (x : ulift.{v} X) :
  ulift_functor.map f x = ulift.up (f x.down) := rfl

instance ulift_functor_full : full.{u} ulift_functor :=
{ preimage := λ X Y f x, (f (ulift.up x)).down }
instance ulift_functor_faithful : faithful ulift_functor :=
{ map_injective' := λ X Y f g p, funext $ λ x,
    congr_arg ulift.down ((congr_fun p (ulift.up x)) : ((ulift.up (f x)) = (ulift.up (g x)))) }

/--
The functor embedding `Type u` into `Type u` via `ulift` is isomorphic to the identity functor.
 -/
def ulift_functor_trivial : ulift_functor.{u u} ≅ 𝟭 _ :=
nat_iso.of_components ulift_trivial (by tidy)

/-- Any term `x` of a type `X` corresponds to a morphism `punit ⟶ X`. -/
-- TODO We should connect this to a general story about concrete categories
-- whose forgetful functor is representable.
def hom_of_element {X : Type u} (x : X) : punit ⟶ X := λ _, x

lemma hom_of_element_eq_iff {X : Type u} (x y : X) :
  hom_of_element x = hom_of_element y ↔ x = y :=
⟨λ H, congr_fun H punit.star, by cc⟩

/--
A morphism in `Type` is a monomorphism if and only if it is injective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma mono_iff_injective {X Y : Type u} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { intros H x x' h,
    resetI,
    rw ←hom_of_element_eq_iff at ⊢ h,
    exact (cancel_mono f).mp h },
  { exact λ H, ⟨λ Z, H.comp_left⟩ }
end

lemma injective_of_mono {X Y : Type u} (f : X ⟶ Y) [hf : mono f] : function.injective f :=
(mono_iff_injective f).1 hf

/--
A morphism in `Type` is an epimorphism if and only if it is surjective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma epi_iff_surjective {X Y : Type u} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { rintros ⟨H⟩,
    refine function.surjective_of_right_cancellable_Prop (λ g₁ g₂ hg, _),
    rw [← equiv.ulift.symm.injective.comp_left.eq_iff],
    apply H,
    change ulift.up ∘ (g₁ ∘ f) = ulift.up ∘ (g₂ ∘ f),
    rw hg },
  { exact λ H, ⟨λ Z, H.injective_comp_right⟩ }
end

lemma surjective_of_epi {X Y : Type u} (f : X ⟶ Y) [hf : epi f] : function.surjective f :=
(epi_iff_surjective f).1 hf

section

/-- `of_type_functor m` converts from Lean's `Type`-based `category` to `category_theory`. This
allows us to use these functors in category theory. -/
def of_type_functor (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m] :
  Type u ⥤ Type v :=
{ obj       := m,
  map       := λα β, _root_.functor.map,
  map_id'   := assume α, _root_.functor.map_id,
  map_comp' := assume α β γ f g, funext $ assume a, is_lawful_functor.comp_map f g _ }

variables (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m]

@[simp]
lemma of_type_functor_obj : (of_type_functor m).obj = m := rfl

@[simp]
lemma of_type_functor_map {α β} (f : α → β) :
  (of_type_functor m).map f = (_root_.functor.map f : m α → m β) := rfl

end

end category_theory

-- Isomorphisms in Type and equivalences.

namespace equiv

universe u

variables {X Y : Type u}

/--
Any equivalence between types in the same universe gives
a categorical isomorphism between those types.
-/
def to_iso (e : X ≃ Y) : X ≅ Y :=
{ hom := e.to_fun,
  inv := e.inv_fun,
  hom_inv_id' := funext e.left_inv,
  inv_hom_id' := funext e.right_inv }

@[simp] lemma to_iso_hom {e : X ≃ Y} : e.to_iso.hom = e := rfl
@[simp] lemma to_iso_inv {e : X ≃ Y} : e.to_iso.inv = e.symm := rfl

end equiv

universe u

namespace category_theory.iso
open category_theory

variables {X Y : Type u}

/--
Any isomorphism between types gives an equivalence.
-/
def to_equiv (i : X ≅ Y) : X ≃ Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := λ x, congr_fun i.hom_inv_id x,
  right_inv := λ y, congr_fun i.inv_hom_id y }

@[simp] lemma to_equiv_fun (i : X ≅ Y) : (i.to_equiv : X → Y) = i.hom := rfl
@[simp] lemma to_equiv_symm_fun (i : X ≅ Y) : (i.to_equiv.symm : Y → X) = i.inv := rfl

@[simp] lemma to_equiv_id (X : Type u) : (iso.refl X).to_equiv = equiv.refl X := rfl
@[simp] lemma to_equiv_comp {X Y Z : Type u} (f : X ≅ Y) (g : Y ≅ Z) :
  (f ≪≫ g).to_equiv = f.to_equiv.trans (g.to_equiv) := rfl

end category_theory.iso

namespace category_theory

/-- A morphism in `Type u` is an isomorphism if and only if it is bijective. -/
lemma is_iso_iff_bijective {X Y : Type u} (f : X ⟶ Y) : is_iso f ↔ function.bijective f :=
iff.intro
  (λ i, (by exactI as_iso f : X ≅ Y).to_equiv.bijective)
  (λ b, is_iso.of_iso (equiv.of_bijective f b).to_iso)

noncomputable instance : split_epi_category (Type u) :=
{ split_epi_of_epi := λ X Y f hf,
  { section_ := function.surj_inv $ (epi_iff_surjective f).1 hf,
    id' := funext $ function.right_inverse_surj_inv $ (epi_iff_surjective f).1 hf } }

end category_theory

-- We prove `equiv_iso_iso` and then use that to sneakily construct `equiv_equiv_iso`.
-- (In this order the proofs are handled by `obviously`.)

/-- Equivalences (between types in the same universe) are the same as (isomorphic to) isomorphisms
of types. -/
@[simps] def equiv_iso_iso {X Y : Type u} : (X ≃ Y) ≅ (X ≅ Y) :=
{ hom := λ e, e.to_iso,
  inv := λ i, i.to_equiv, }

/-- Equivalences (between types in the same universe) are the same as (equivalent to) isomorphisms
of types. -/
def equiv_equiv_iso {X Y : Type u} : (X ≃ Y) ≃ (X ≅ Y) :=
(equiv_iso_iso).to_equiv

@[simp] lemma equiv_equiv_iso_hom {X Y : Type u} (e : X ≃ Y) :
  equiv_equiv_iso e = e.to_iso := rfl

@[simp] lemma equiv_equiv_iso_inv {X Y : Type u} (e : X ≅ Y) :
  equiv_equiv_iso.symm e = e.to_equiv := rfl