/-
Copyright (c) 2019 Patrick MAssot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import topology.uniform_space.absolute_value
import topology.instances.real
import topology.instances.rat
import topology.uniform_space.completion

/-!
# Comparison of Cauchy reals and Bourbaki reals

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

In `data.real.basic` real numbers are defined using the so called Cauchy construction (although
it is due to Georg Cantor). More precisely, this construction applies to commutative rings equipped
with an absolute value with values in a linear ordered field.

On the other hand, in the `uniform_space` folder, we construct completions of general uniform
spaces, which allows to construct the Bourbaki real numbers. In this file we build uniformly
continuous bijections from Cauchy reals to Bourbaki reals and back. This is a cross sanity check of
both constructions. Of course those two constructions are variations on the completion idea, simply
with different level of generality. Comparing with Dedekind cuts or quasi-morphisms would be of a
completely different nature.

Note that `metric_space/cau_seq_filter` also relates the notions of Cauchy sequences in metric
spaces and Cauchy filters in general uniform spaces, and `metric_space/completion` makes sure
the completion (as a uniform space) of a metric space is a metric space.

Historical note: mathlib used to define real numbers in an intermediate way, using completion
of uniform spaces but extending multiplication in an ad-hoc way.

TODO:
* Upgrade this isomorphism to a topological ring isomorphism.
* Do the same comparison for p-adic numbers

## Implementation notes

The heavy work is done in `topology/uniform_space/abstract_completion` which provides an abstract
caracterization of completions of uniform spaces, and isomorphisms between them. The only work left
here is to prove the uniform space structure coming from the absolute value on ℚ (with values in ℚ,
not referring to ℝ) coincides with the one coming from the metric space structure (which of course
does use ℝ).

## References

* [N. Bourbaki, *Topologie générale*][bourbaki1966]

## Tags

real numbers, completion, uniform spaces
-/

open set function filter cau_seq uniform_space

/-- The metric space uniform structure on ℚ (which presupposes the existence
of real numbers) agrees with the one coming directly from (abs : ℚ → ℚ). -/
lemma rat.uniform_space_eq :
  (absolute_value.abs : absolute_value ℚ ℚ).uniform_space = pseudo_metric_space.to_uniform_space :=
begin
  ext s,
  rw [(absolute_value.has_basis_uniformity _).mem_iff, metric.uniformity_basis_dist_rat.mem_iff],
  simp only [rat.dist_eq, absolute_value.abs_apply, ← rat.cast_sub, ← rat.cast_abs, rat.cast_lt,
    abs_sub_comm]
end

/-- Cauchy reals packaged as a completion of ℚ using the absolute value route. -/
def rational_cau_seq_pkg : @abstract_completion ℚ $ (@absolute_value.abs ℚ _).uniform_space :=
{ space := ℝ,
  coe := (coe : ℚ → ℝ),
  uniform_struct := by apply_instance,
  complete :=  by apply_instance,
  separation :=  by apply_instance,
  uniform_inducing := by { rw rat.uniform_space_eq,
                           exact rat.uniform_embedding_coe_real.to_uniform_inducing },
  dense := rat.dense_embedding_coe_real.dense }

namespace compare_reals
/-- Type wrapper around ℚ to make sure the absolute value uniform space instance is picked up
instead of the metric space one. We proved in rat.uniform_space_eq that they are equal,
but they are not definitionaly equal, so it would confuse the type class system (and probably
also human readers). -/
@[derive comm_ring, derive inhabited] def Q := ℚ

instance : uniform_space Q := (@absolute_value.abs ℚ _).uniform_space

/-- Real numbers constructed as in Bourbaki. -/
@[derive inhabited]
def Bourbakiℝ : Type := completion Q

instance bourbaki.uniform_space: uniform_space Bourbakiℝ := completion.uniform_space Q

/-- Bourbaki reals packaged as a completion of Q using the general theory. -/
def Bourbaki_pkg : abstract_completion Q := completion.cpkg

/-- The uniform bijection between Bourbaki and Cauchy reals. -/
noncomputable def compare_equiv : Bourbakiℝ ≃ᵤ ℝ :=
Bourbaki_pkg.compare_equiv rational_cau_seq_pkg

lemma compare_uc : uniform_continuous (compare_equiv) :=
Bourbaki_pkg.uniform_continuous_compare_equiv _

lemma compare_uc_symm : uniform_continuous (compare_equiv).symm :=
Bourbaki_pkg.uniform_continuous_compare_equiv_symm _
end compare_reals


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn

! This file was ported from Lean 3 source module logic.is_empty
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Function.Basic
import Mathbin.Tactic.Protected

/-!
# Types that are empty

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

In this file we define a typeclass `is_empty`, which expresses that a type has no elements.

## Main declaration

* `is_empty`: a typeclass that expresses that a type is empty.
-/

variable {α β γ : Sort _}

#print IsEmpty /-
/-- `is_empty α` expresses that `α` is empty. -/
@[protect_proj]
class IsEmpty (α : Sort _) : Prop where
  False : α → False
#align is_empty IsEmpty
-/

instance : IsEmpty Empty :=
  ⟨Empty.elim⟩

instance : IsEmpty PEmpty :=
  ⟨PEmpty.elim⟩

instance : IsEmpty False :=
  ⟨id⟩

instance : IsEmpty (Fin 0) :=
  ⟨fun n => Nat.not_lt_zero n.1 n.2⟩

#print Function.isEmpty /-
protected theorem Function.isEmpty [IsEmpty β] (f : α → β) : IsEmpty α :=
  ⟨fun x => IsEmpty.false (f x)⟩
#align function.is_empty Function.isEmpty
-/

instance {p : α → Sort _} [h : Nonempty α] [∀ x, IsEmpty (p x)] : IsEmpty (∀ x, p x) :=
  h.elim fun x => Function.isEmpty <| Function.eval x

#print PProd.isEmpty_left /-
instance PProd.isEmpty_left [IsEmpty α] : IsEmpty (PProd α β) :=
  Function.isEmpty PProd.fst
#align pprod.is_empty_left PProd.isEmpty_left
-/

#print PProd.isEmpty_right /-
instance PProd.isEmpty_right [IsEmpty β] : IsEmpty (PProd α β) :=
  Function.isEmpty PProd.snd
#align pprod.is_empty_right PProd.isEmpty_right
-/

#print Prod.isEmpty_left /-
instance Prod.isEmpty_left {α β} [IsEmpty α] : IsEmpty (α × β) :=
  Function.isEmpty Prod.fst
#align prod.is_empty_left Prod.isEmpty_left
-/

#print Prod.isEmpty_right /-
instance Prod.isEmpty_right {α β} [IsEmpty β] : IsEmpty (α × β) :=
  Function.isEmpty Prod.snd
#align prod.is_empty_right Prod.isEmpty_right
-/

instance [IsEmpty α] [IsEmpty β] : IsEmpty (PSum α β) :=
  ⟨fun x => PSum.rec IsEmpty.false IsEmpty.false x⟩

instance {α β} [IsEmpty α] [IsEmpty β] : IsEmpty (Sum α β) :=
  ⟨fun x => Sum.rec IsEmpty.false IsEmpty.false x⟩

/-- subtypes of an empty type are empty -/
instance [IsEmpty α] (p : α → Prop) : IsEmpty (Subtype p) :=
  ⟨fun x => IsEmpty.false x.1⟩

#print Subtype.isEmpty_of_false /-
/-- subtypes by an all-false predicate are false. -/
theorem Subtype.isEmpty_of_false {p : α → Prop} (hp : ∀ a, ¬p a) : IsEmpty (Subtype p) :=
  ⟨fun x => hp _ x.2⟩
#align subtype.is_empty_of_false Subtype.isEmpty_of_false
-/

#print Subtype.isEmpty_false /-
/-- subtypes by false are false. -/
instance Subtype.isEmpty_false : IsEmpty { a : α // False } :=
  Subtype.isEmpty_of_false fun a => id
#align subtype.is_empty_false Subtype.isEmpty_false
-/

#print Sigma.isEmpty_left /-
instance Sigma.isEmpty_left {α} [IsEmpty α] {E : α → Type _} : IsEmpty (Sigma E) :=
  Function.isEmpty Sigma.fst
#align sigma.is_empty_left Sigma.isEmpty_left
-/

-- Test that `pi.is_empty` finds this instance.
example [h : Nonempty α] [IsEmpty β] : IsEmpty (α → β) := by infer_instance

#print isEmptyElim /-
/-- Eliminate out of a type that `is_empty` (without using projection notation). -/
@[elab_as_elim]
def isEmptyElim [IsEmpty α] {p : α → Sort _} (a : α) : p a :=
  (IsEmpty.false a).elim
#align is_empty_elim isEmptyElim
-/

#print isEmpty_iff /-
theorem isEmpty_iff : IsEmpty α ↔ α → False :=
  ⟨@IsEmpty.false α, IsEmpty.mk⟩
#align is_empty_iff isEmpty_iff
-/

namespace IsEmpty

open Function

#print IsEmpty.elim /-
/-- Eliminate out of a type that `is_empty` (using projection notation). -/
protected def elim (h : IsEmpty α) {p : α → Sort _} (a : α) : p a :=
  isEmptyElim a
#align is_empty.elim IsEmpty.elim
-/

#print IsEmpty.elim' /-
/-- Non-dependent version of `is_empty.elim`. Helpful if the elaborator cannot elaborate `h.elim a`
  correctly. -/
protected def elim' {β : Sort _} (h : IsEmpty α) (a : α) : β :=
  h.elim a
#align is_empty.elim' IsEmpty.elim'
-/

#print IsEmpty.prop_iff /-
protected theorem prop_iff {p : Prop} : IsEmpty p ↔ ¬p :=
  isEmpty_iff
#align is_empty.prop_iff IsEmpty.prop_iff
-/

variable [IsEmpty α]

#print IsEmpty.forall_iff /-
@[simp]
theorem forall_iff {p : α → Prop} : (∀ a, p a) ↔ True :=
  iff_true_intro isEmptyElim
#align is_empty.forall_iff IsEmpty.forall_iff
-/

#print IsEmpty.exists_iff /-
@[simp]
theorem exists_iff {p : α → Prop} : (∃ a, p a) ↔ False :=
  iff_false_intro fun ⟨x, hx⟩ => IsEmpty.false x
#align is_empty.exists_iff IsEmpty.exists_iff
-/

-- see Note [lower instance priority]
instance (priority := 100) : Subsingleton α :=
  ⟨isEmptyElim⟩

end IsEmpty

#print not_nonempty_iff /-
@[simp]
theorem not_nonempty_iff : ¬Nonempty α ↔ IsEmpty α :=
  ⟨fun h => ⟨fun x => h ⟨x⟩⟩, fun h1 h2 => h2.elim h1.elim⟩
#align not_nonempty_iff not_nonempty_iff
-/

#print not_isEmpty_iff /-
@[simp]
theorem not_isEmpty_iff : ¬IsEmpty α ↔ Nonempty α :=
  not_iff_comm.mp not_nonempty_iff
#align not_is_empty_iff not_isEmpty_iff
-/

#print isEmpty_Prop /-
@[simp]
theorem isEmpty_Prop {p : Prop} : IsEmpty p ↔ ¬p := by simp only [← not_nonempty_iff, nonempty_Prop]
#align is_empty_Prop isEmpty_Prop
-/

#print isEmpty_pi /-
@[simp]
theorem isEmpty_pi {π : α → Sort _} : IsEmpty (∀ a, π a) ↔ ∃ a, IsEmpty (π a) := by
  simp only [← not_nonempty_iff, Classical.nonempty_pi, not_forall]
#align is_empty_pi isEmpty_pi
-/

/- warning: is_empty_sigma -> isEmpty_sigma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {E : α -> Type.{u2}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Sigma.{u1, u2} α E)) (forall (a : α), IsEmpty.{succ u2} (E a))
but is expected to have type
  forall {α : Type.{u2}} {E : α -> Type.{u1}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Sigma.{u2, u1} α E)) (forall (a : α), IsEmpty.{succ u1} (E a))
Case conversion may be inaccurate. Consider using '#align is_empty_sigma isEmpty_sigmaₓ'. -/
@[simp]
theorem isEmpty_sigma {α} {E : α → Type _} : IsEmpty (Sigma E) ↔ ∀ a, IsEmpty (E a) := by
  simp only [← not_nonempty_iff, nonempty_sigma, not_exists]
#align is_empty_sigma isEmpty_sigma

/- warning: is_empty_psigma -> isEmpty_psigma is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {E : α -> Sort.{u2}}, Iff (IsEmpty.{max 1 u1 u2} (PSigma.{u1, u2} α E)) (forall (a : α), IsEmpty.{u2} (E a))
but is expected to have type
  forall {α : Sort.{u2}} {E : α -> Sort.{u1}}, Iff (IsEmpty.{max (max 1 u1) u2} (PSigma.{u2, u1} α E)) (forall (a : α), IsEmpty.{u1} (E a))
Case conversion may be inaccurate. Consider using '#align is_empty_psigma isEmpty_psigmaₓ'. -/
@[simp]
theorem isEmpty_psigma {α} {E : α → Sort _} : IsEmpty (PSigma E) ↔ ∀ a, IsEmpty (E a) := by
  simp only [← not_nonempty_iff, nonempty_psigma, not_exists]
#align is_empty_psigma isEmpty_psigma

#print isEmpty_subtype /-
@[simp]
theorem isEmpty_subtype (p : α → Prop) : IsEmpty (Subtype p) ↔ ∀ x, ¬p x := by
  simp only [← not_nonempty_iff, nonempty_subtype, not_exists]
#align is_empty_subtype isEmpty_subtype
-/

/- warning: is_empty_prod -> isEmpty_prod is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Prod.{u1, u2} α β)) (Or (IsEmpty.{succ u1} α) (IsEmpty.{succ u2} β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Prod.{u2, u1} α β)) (Or (IsEmpty.{succ u2} α) (IsEmpty.{succ u1} β))
Case conversion may be inaccurate. Consider using '#align is_empty_prod isEmpty_prodₓ'. -/
@[simp]
theorem isEmpty_prod {α β : Type _} : IsEmpty (α × β) ↔ IsEmpty α ∨ IsEmpty β := by
  simp only [← not_nonempty_iff, nonempty_prod, not_and_or]
#align is_empty_prod isEmpty_prod

#print isEmpty_pprod /-
@[simp]
theorem isEmpty_pprod : IsEmpty (PProd α β) ↔ IsEmpty α ∨ IsEmpty β := by
  simp only [← not_nonempty_iff, nonempty_pprod, not_and_or]
#align is_empty_pprod isEmpty_pprod
-/

/- warning: is_empty_sum -> isEmpty_sum is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Sum.{u1, u2} α β)) (And (IsEmpty.{succ u1} α) (IsEmpty.{succ u2} β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}}, Iff (IsEmpty.{max (succ u1) (succ u2)} (Sum.{u2, u1} α β)) (And (IsEmpty.{succ u2} α) (IsEmpty.{succ u1} β))
Case conversion may be inaccurate. Consider using '#align is_empty_sum isEmpty_sumₓ'. -/
@[simp]
theorem isEmpty_sum {α β} : IsEmpty (Sum α β) ↔ IsEmpty α ∧ IsEmpty β := by
  simp only [← not_nonempty_iff, nonempty_sum, not_or]
#align is_empty_sum isEmpty_sum

/- warning: is_empty_psum -> isEmpty_psum is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}}, Iff (IsEmpty.{max 1 u1 u2} (PSum.{u1, u2} α β)) (And (IsEmpty.{u1} α) (IsEmpty.{u2} β))
but is expected to have type
  forall {α : Sort.{u2}} {β : Sort.{u1}}, Iff (IsEmpty.{max (max 1 u1) u2} (PSum.{u2, u1} α β)) (And (IsEmpty.{u2} α) (IsEmpty.{u1} β))
Case conversion may be inaccurate. Consider using '#align is_empty_psum isEmpty_psumₓ'. -/
@[simp]
theorem isEmpty_psum {α β} : IsEmpty (PSum α β) ↔ IsEmpty α ∧ IsEmpty β := by
  simp only [← not_nonempty_iff, nonempty_psum, not_or]
#align is_empty_psum isEmpty_psum

/- warning: is_empty_ulift -> isEmpty_ulift is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}}, Iff (IsEmpty.{succ (max u1 u2)} (ULift.{u2, u1} α)) (IsEmpty.{succ u1} α)
but is expected to have type
  forall {α : Type.{u2}}, Iff (IsEmpty.{max (succ u2) (succ u1)} (ULift.{u1, u2} α)) (IsEmpty.{succ u2} α)
Case conversion may be inaccurate. Consider using '#align is_empty_ulift isEmpty_uliftₓ'. -/
@[simp]
theorem isEmpty_ulift {α} : IsEmpty (ULift α) ↔ IsEmpty α := by
  simp only [← not_nonempty_iff, nonempty_ulift]
#align is_empty_ulift isEmpty_ulift

#print isEmpty_plift /-
@[simp]
theorem isEmpty_plift {α} : IsEmpty (PLift α) ↔ IsEmpty α := by
  simp only [← not_nonempty_iff, nonempty_plift]
#align is_empty_plift isEmpty_plift
-/

#print wellFounded_of_isEmpty /-
theorem wellFounded_of_isEmpty {α} [IsEmpty α] (r : α → α → Prop) : WellFounded r :=
  ⟨isEmptyElim⟩
#align well_founded_of_empty wellFounded_of_isEmpty
-/

variable (α)

#print isEmpty_or_nonempty /-
theorem isEmpty_or_nonempty : IsEmpty α ∨ Nonempty α :=
  (em <| IsEmpty α).elim Or.inl <| Or.inr ∘ not_isEmpty_iff.mp
#align is_empty_or_nonempty isEmpty_or_nonempty
-/

#print not_isEmpty_of_nonempty /-
@[simp]
theorem not_isEmpty_of_nonempty [h : Nonempty α] : ¬IsEmpty α :=
  not_isEmpty_iff.mpr h
#align not_is_empty_of_nonempty not_isEmpty_of_nonempty
-/

variable {α}

/- warning: function.extend_of_empty -> Function.extend_of_isEmpty is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {γ : Sort.{u3}} [_inst_1 : IsEmpty.{u1} α] (f : α -> β) (g : α -> γ) (h : β -> γ), Eq.{imax u2 u3} (β -> γ) (Function.extend.{u1, u2, u3} α β γ f g h) h
but is expected to have type
  forall {α : Sort.{u3}} {β : Sort.{u2}} {γ : Sort.{u1}} [_inst_1 : IsEmpty.{u3} α] (f : α -> β) (g : α -> γ) (h : β -> γ), Eq.{imax u2 u1} (β -> γ) (Function.extend.{u3, u2, u1} α β γ f g h) h
Case conversion may be inaccurate. Consider using '#align function.extend_of_empty Function.extend_of_isEmptyₓ'. -/
theorem Function.extend_of_isEmpty [IsEmpty α] (f : α → β) (g : α → γ) (h : β → γ) :
    Function.extend f g h = h :=
  funext fun x => Function.extend_apply' _ _ _ fun ⟨a, h⟩ => isEmptyElim a
#align function.extend_of_empty Function.extend_of_isEmpty


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.fully_faithful
import Mathlib.PostPort

universes v u₁ u₂ u_1

namespace Mathlib

namespace category_theory

/- Induced categories.

  Given a category D and a function F : C → D from a type C to the
  objects of D, there is an essentially unique way to give C a
  category structure such that F becomes a fully faithful functor,
  namely by taking Hom_C(X, Y) = Hom_D(FX, FY). We call this the
  category induced from D along F.

  As a special case, if C is a subtype of D, this produces the full
  subcategory of D on the objects belonging to C. In general the
  induced category is equivalent to the full subcategory of D on the
  image of F.

-/

/-
It looks odd to make D an explicit argument of `induced_category`,
when it is determined by the argument F anyways. The reason to make D
explicit is in order to control its syntactic form, so that instances
like `induced_category.has_forget₂` (elsewhere) refer to the correct
form of D. This is used to set up several algebraic categories like

  def CommMon : Type (u+1) := induced_category Mon (bundled.map @comm_monoid.to_monoid)
  -- not `induced_category (bundled monoid) (bundled.map @comm_monoid.to_monoid)`,
  -- even though `Mon = bundled monoid`!
-/

/--
`induced_category D F`, where `F : C → D`, is a typeclass synonym for `C`,
which provides a category structure so that the morphisms `X ⟶ Y` are the morphisms
in `D` from `F X` to `F Y`.
-/
def induced_category {C : Type u₁} (D : Type u₂) [category D] (F : C → D) :=
  C

protected instance induced_category.has_coe_to_sort {C : Type u₁} {D : Type u₂} [category D] (F : C → D) [has_coe_to_sort D] : has_coe_to_sort (induced_category D F) :=
  has_coe_to_sort.mk (has_coe_to_sort.S D) fun (c : induced_category D F) => ↥(F c)

protected instance induced_category.category {C : Type u₁} {D : Type u₂} [category D] (F : C → D) : category (induced_category D F) :=
  category.mk

/--
The forgetful functor from an induced category to the original category,
forgetting the extra data.
-/
@[simp] theorem induced_functor_obj {C : Type u₁} {D : Type u₂} [category D] (F : C → D) : ∀ (ᾰ : C), functor.obj (induced_functor F) ᾰ = F ᾰ :=
  fun (ᾰ : C) => Eq.refl (functor.obj (induced_functor F) ᾰ)

protected instance induced_category.full {C : Type u₁} {D : Type u₂} [category D] (F : C → D) : full (induced_functor F) :=
  full.mk
    fun (x y : induced_category D F) (f : functor.obj (induced_functor F) x ⟶ functor.obj (induced_functor F) y) => f

protected instance induced_category.faithful {C : Type u₁} {D : Type u₂} [category D] (F : C → D) : faithful (induced_functor F) :=
  faithful.mk

/- A full subcategory is the special case of an induced category with F = subtype.val. -/

/--
The category structure on a subtype; morphisms just ignore the property.

See https://stacks.math.columbia.edu/tag/001D. We do not define 'strictly full' subcategories.
-/
protected instance full_subcategory {C : Type u₂} [category C] (Z : C → Prop) : category (Subtype fun (X : C) => Z X) :=
  induced_category.category subtype.val

/--
The forgetful functor from a full subcategory into the original category
("forgetting" the condition).
-/
def full_subcategory_inclusion {C : Type u₂} [category C] (Z : C → Prop) : (Subtype fun (X : C) => Z X) ⥤ C :=
  induced_functor subtype.val

@[simp] theorem full_subcategory_inclusion.obj {C : Type u₂} [category C] (Z : C → Prop) {X : Subtype fun (X : C) => Z X} : functor.obj (full_subcategory_inclusion Z) X = subtype.val X :=
  rfl

@[simp] theorem full_subcategory_inclusion.map {C : Type u₂} [category C] (Z : C → Prop) {X : Subtype fun (X : C) => Z X} {Y : Subtype fun (X : C) => Z X} {f : X ⟶ Y} : functor.map (full_subcategory_inclusion Z) f = f :=
  rfl

protected instance full_subcategory.full {C : Type u₂} [category C] (Z : C → Prop) : full (full_subcategory_inclusion Z) :=
  induced_category.full subtype.val

protected instance full_subcategory.faithful {C : Type u₂} [category C] (Z : C → Prop) : faithful (full_subcategory_inclusion Z) :=
  induced_category.faithful subtype.val


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.basic

/-!
# The powerset of a multiset
-/

namespace multiset
open list

variables {α : Type*}

/-! ### powerset -/

/-- A helper function for the powerset of a multiset. Given a list `l`, returns a list
of sublists of `l` (using `sublists_aux`), as multisets. -/
def powerset_aux (l : list α) : list (multiset α) :=
0 :: sublists_aux l (λ x y, x :: y)

theorem powerset_aux_eq_map_coe {l : list α} :
  powerset_aux l = (sublists l).map coe :=
by simp [powerset_aux, sublists];
   rw [← show @sublists_aux₁ α (multiset α) l (λ x, [↑x]) =
              sublists_aux l (λ x, list.cons ↑x),
         from sublists_aux₁_eq_sublists_aux _ _,
       sublists_aux_cons_eq_sublists_aux₁,
       ← bind_ret_eq_map, sublists_aux₁_bind]; refl

@[simp] theorem mem_powerset_aux {l : list α} {s} :
  s ∈ powerset_aux l ↔ s ≤ ↑l :=
quotient.induction_on s $
by simp [powerset_aux_eq_map_coe, subperm, and.comm]

/-- Helper function for the powerset of a multiset. Given a list `l`, returns a list
of sublists of `l` (using `sublists'`), as multisets. -/
def powerset_aux' (l : list α) : list (multiset α) := (sublists' l).map coe

theorem powerset_aux_perm_powerset_aux' {l : list α} :
  powerset_aux l ~ powerset_aux' l :=
by rw powerset_aux_eq_map_coe; exact (sublists_perm_sublists' _).map _

@[simp] theorem powerset_aux'_nil : powerset_aux' (@nil α) = [0] := rfl

@[simp] theorem powerset_aux'_cons (a : α) (l : list α) :
  powerset_aux' (a::l) = powerset_aux' l ++ list.map (cons a) (powerset_aux' l) :=
by simp [powerset_aux']; refl

theorem powerset_aux'_perm {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  powerset_aux' l₁ ~ powerset_aux' l₂ :=
begin
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { simp, exact IH.append (IH.map _) },
  { simp, apply perm.append_left,
    rw [← append_assoc, ← append_assoc,
        (by funext s; simp [cons_swap] : cons b ∘ cons a = cons a ∘ cons b)],
    exact perm_append_comm.append_right _ },
  { exact IH₁.trans IH₂ }
end

theorem powerset_aux_perm {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  powerset_aux l₁ ~ powerset_aux l₂ :=
powerset_aux_perm_powerset_aux'.trans $
(powerset_aux'_perm p).trans powerset_aux_perm_powerset_aux'.symm

/-- The power set of a multiset. -/
def powerset (s : multiset α) : multiset (multiset α) :=
quot.lift_on s
  (λ l, (powerset_aux l : multiset (multiset α)))
  (λ l₁ l₂ h, quot.sound (powerset_aux_perm h))

theorem powerset_coe (l : list α) :
  @powerset α l = ((sublists l).map coe : list (multiset α)) :=
congr_arg coe powerset_aux_eq_map_coe

@[simp] theorem powerset_coe' (l : list α) :
  @powerset α l = ((sublists' l).map coe : list (multiset α)) :=
quot.sound powerset_aux_perm_powerset_aux'

@[simp] theorem powerset_zero : @powerset α 0 = 0 ::ₘ 0 := rfl

@[simp] theorem powerset_cons (a : α) (s) :
  powerset (a ::ₘ s) = powerset s + map (cons a) (powerset s) :=
quotient.induction_on s $ λ l, by simp; refl

@[simp] theorem mem_powerset {s t : multiset α} :
  s ∈ powerset t ↔ s ≤ t :=
quotient.induction_on₂ s t $ by simp [subperm, and.comm]

theorem map_single_le_powerset (s : multiset α) :
  s.map (λ a, a ::ₘ 0) ≤ powerset s :=
quotient.induction_on s $ λ l, begin
  simp [powerset_coe],
  show l.map (coe ∘ list.ret) <+~ (sublists l).map coe,
  rw ← list.map_map,
  exact ((map_ret_sublist_sublists _).map _).subperm
end

@[simp] theorem card_powerset (s : multiset α) :
  card (powerset s) = 2 ^ card s :=
quotient.induction_on s $ by simp

theorem revzip_powerset_aux {l : list α} ⦃x⦄
  (h : x ∈ revzip (powerset_aux l)) : x.1 + x.2 = ↑l :=
begin
  rw [revzip, powerset_aux_eq_map_coe, ← map_reverse, zip_map, ← revzip] at h,
  simp at h, rcases h with ⟨l₁, l₂, h, rfl, rfl⟩,
  exact quot.sound (revzip_sublists _ _ _ h)
end

theorem revzip_powerset_aux' {l : list α} ⦃x⦄
  (h : x ∈ revzip (powerset_aux' l)) : x.1 + x.2 = ↑l :=
begin
  rw [revzip, powerset_aux', ← map_reverse, zip_map, ← revzip] at h,
  simp at h, rcases h with ⟨l₁, l₂, h, rfl, rfl⟩,
  exact quot.sound (revzip_sublists' _ _ _ h)
end

theorem revzip_powerset_aux_lemma [decidable_eq α] (l : list α)
  {l' : list (multiset α)} (H : ∀ ⦃x : _ × _⦄, x ∈ revzip l' → x.1 + x.2 = ↑l) :
  revzip l' = l'.map (λ x, (x, ↑l - x)) :=
begin
  have : forall₂ (λ (p : multiset α × multiset α) (s : multiset α), p = (s, ↑l - s))
    (revzip l') ((revzip l').map prod.fst),
  { rw forall₂_map_right_iff,
    apply forall₂_same, rintro ⟨s, t⟩ h,
    dsimp, rw [← H h, add_sub_cancel_left] },
  rw [← forall₂_eq_eq_eq, forall₂_map_right_iff], simpa
end

theorem revzip_powerset_aux_perm {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  revzip (powerset_aux l₁) ~ revzip (powerset_aux l₂) :=
begin
  haveI := classical.dec_eq α,
  simp [λ l:list α, revzip_powerset_aux_lemma l revzip_powerset_aux, coe_eq_coe.2 p],
  exact (powerset_aux_perm p).map _
end

/-! ### powerset_len -/

/-- Helper function for `powerset_len`. Given a list `l`, `powerset_len_aux n l` is the list
of sublists of length `n`, as multisets. -/
def powerset_len_aux (n : ℕ) (l : list α) : list (multiset α) :=
sublists_len_aux n l coe []

theorem powerset_len_aux_eq_map_coe {n} {l : list α} :
  powerset_len_aux n l = (sublists_len n l).map coe :=
by rw [powerset_len_aux, sublists_len_aux_eq, append_nil]

@[simp] theorem mem_powerset_len_aux {n} {l : list α} {s} :
  s ∈ powerset_len_aux n l ↔ s ≤ ↑l ∧ card s = n :=
quotient.induction_on s $
by simp [powerset_len_aux_eq_map_coe, subperm]; exact
  λ l₁, ⟨λ ⟨l₂, ⟨s, e⟩, p⟩, ⟨⟨_, p, s⟩, p.symm.length_eq.trans e⟩,
    λ ⟨⟨l₂, p, s⟩, e⟩, ⟨_, ⟨s, p.length_eq.trans e⟩, p⟩⟩

@[simp] theorem powerset_len_aux_zero (l : list α) :
  powerset_len_aux 0 l = [0] :=
by simp [powerset_len_aux_eq_map_coe]

@[simp] theorem powerset_len_aux_nil (n : ℕ) :
  powerset_len_aux (n+1) (@nil α) = [] := rfl

@[simp] theorem powerset_len_aux_cons (n : ℕ) (a : α) (l : list α) :
  powerset_len_aux (n+1) (a::l) =
  powerset_len_aux (n+1) l ++ list.map (cons a) (powerset_len_aux n l) :=
by simp [powerset_len_aux_eq_map_coe]; refl

theorem powerset_len_aux_perm {n} {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  powerset_len_aux n l₁ ~ powerset_len_aux n l₂ :=
begin
  induction n with n IHn generalizing l₁ l₂, {simp},
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {refl},
  { simp, exact IH.append ((IHn p).map _) },
  { simp, apply perm.append_left,
    cases n, {simp, apply perm.swap},
    simp,
    rw [← append_assoc, ← append_assoc,
        (by funext s; simp [cons_swap] : cons b ∘ cons a = cons a ∘ cons b)],
    exact perm_append_comm.append_right _ },
  { exact IH₁.trans IH₂ }
end

/-- `powerset_len n s` is the multiset of all submultisets of `s` of length `n`. -/
def powerset_len (n : ℕ) (s : multiset α) : multiset (multiset α) :=
quot.lift_on s
  (λ l, (powerset_len_aux n l : multiset (multiset α)))
  (λ l₁ l₂ h, quot.sound (powerset_len_aux_perm h))

theorem powerset_len_coe' (n) (l : list α) :
  @powerset_len α n l = powerset_len_aux n l := rfl

theorem powerset_len_coe (n) (l : list α) :
  @powerset_len α n l = ((sublists_len n l).map coe : list (multiset α)) :=
congr_arg coe powerset_len_aux_eq_map_coe

@[simp] theorem powerset_len_zero_left (s : multiset α) :
  powerset_len 0 s = 0 ::ₘ 0 :=
quotient.induction_on s $ λ l, by simp [powerset_len_coe']; refl

@[simp] theorem powerset_len_zero_right (n : ℕ) :
  @powerset_len α (n + 1) 0 = 0 := rfl

@[simp] theorem powerset_len_cons (n : ℕ) (a : α) (s) :
  powerset_len (n + 1) (a ::ₘ s) =
  powerset_len (n + 1) s + map (cons a) (powerset_len n s) :=
quotient.induction_on s $ λ l, by simp [powerset_len_coe']; refl

@[simp] theorem mem_powerset_len {n : ℕ} {s t : multiset α} :
  s ∈ powerset_len n t ↔ s ≤ t ∧ card s = n :=
quotient.induction_on t $ λ l, by simp [powerset_len_coe']

@[simp] theorem card_powerset_len (n : ℕ) (s : multiset α) :
  card (powerset_len n s) = nat.choose (card s) n :=
quotient.induction_on s $ by simp [powerset_len_coe]

theorem powerset_len_le_powerset (n : ℕ) (s : multiset α) :
  powerset_len n s ≤ powerset s :=
quotient.induction_on s $ λ l, by simp [powerset_len_coe]; exact
  ((sublists_len_sublist_sublists' _ _).map _).subperm

theorem powerset_len_mono (n : ℕ) {s t : multiset α} (h : s ≤ t) :
  powerset_len n s ≤ powerset_len n t :=
le_induction_on h $ λ l₁ l₂ h, by simp [powerset_len_coe]; exact
  ((sublists_len_sublist_of_sublist _ h).map _).subperm

end multiset


import tactic

namespace chapter2

  --Exercise 1
  /-
  2047 = 2^10 + 2^9 + 2^8 + 2^7 + 2^6 + 2^5 + 2^4 + 2^3 + 2^2 + 2^1 + 2^0
       = 0b011111111111

  1205 = 2^10 + 2^7 + 2^5 + 2^4 + 2^2 + 2^0
       = 0b010010110101

   sum = 0b110010110100
       = 2^11 + 2^10 + 2^7 + 2^5 + 2^4 + 2^2 = 3252
  -/

  --Exercise 2
  /-
  ---------------------
  |  + |  0 |  1 |  2 |
  ---------------------
  |  0 |  0 |  1 |  2 |
  ---------------------
  |  1 |  1 |  2 | 10 |
  ---------------------
  |  2 |  2 | 10 | 11 |
  ---------------------
  -/

  --Exercise 3
  /-
  ---- ----
  ⊢ C  ⊢ C
  --------- ----
    ⊢ CC    ⊢ L
  -------------- ----
      ⊢ CCL      ⊢ X
  -------------------
        ⊢ CCLX
  -/

  --------------------------------------------------------------------

  --Definitions introduced in this chapter:

  inductive roman
  | I | V | X | L | C | D | M
  | append : roman → roman → roman

  namespace roman

    instance : has_one roman := ⟨I⟩
    instance : has_add roman := ⟨append⟩
    infixl `⬝`:60 := append

    inductive eq_r : roman → roman → Prop
    --equivalence relation
    | refl (r) : eq_r r r
    | symm {r₁ r₂} (h : eq_r r₁ r₂) : eq_r r₂ r₁
    | trans {r₁ r₂ r₃} (h₁ : eq_r r₁ r₂) (h₂ : eq_r r₂ r₃) : eq_r r₁ r₃
    --congruence
    | congr {r₁ r₂ r₃ r₄} (h₁ : eq_r r₁ r₃) (h₂ : eq_r r₂ r₄) : eq_r (r₁⬝r₂) (r₃⬝r₄)
    --collecting like-terms
    | assoc (r₁ r₂ r₃) : eq_r ((r₁⬝r₂)⬝r₃) (r₁⬝(r₂⬝r₃))
    | comm (r₁ r₂) : eq_r (r₁⬝r₂) (r₂⬝r₁)
    --rules for operators
    | opV : eq_r (V) (I⬝I⬝I⬝I⬝I)
    | opX : eq_r (X) (V⬝V)
    | opL : eq_r (L) (X⬝X⬝X⬝X⬝X)
    | opC : eq_r (C) (L⬝L)
    | opD : eq_r (D) (C⬝C⬝C⬝C⬝C)
    | opM : eq_r (M) (D⬝D)

    namespace eq_r

      infixl ` =ᵣ `:50 := eq_r

      @[refl]
      lemma has_refl (r) : r =ᵣ r :=
      by apply refl

      @[symm]
      lemma has_symm {r₁ r₂} (h : r₁ =ᵣ r₂) : r₂ =ᵣ r₁ :=
      by {apply symm, assumption}

      @[trans]
      lemma has_trans {r₁ r₂ r₃} (h₁ : r₁ =ᵣ r₂) (h₂ : r₂ =ᵣ r₃) : r₁ =ᵣ r₃ :=
      by {apply trans, exact h₁, assumption}

    end eq_r

  end roman

  open roman

  inductive arith
  | zero
  | succ : arith → arith
  | add : arith → arith → arith

  namespace arith

    instance : has_zero arith := ⟨zero⟩
    instance : has_one arith := ⟨succ zero⟩
    instance : has_add arith := ⟨add⟩

    inductive eq_a : arith → arith → Prop
    --equivalence relation
    | refl (a) : eq_a a a
    | symm {a₁ a₂} (h : eq_a a₁ a₂) : eq_a a₂ a₁
    | trans {a₁ a₂ a₃} (h₁ : eq_a a₁ a₂) (h₂ : eq_a a₂ a₃) : eq_a a₁ a₃
    --congruence
    | congr_succ {a₁ a₂} (h : eq_a a₁ a₂) : eq_a (succ a₁) (succ a₂)
    | congr_add {a₁ a₂ a₃ a₄} (h₁ : eq_a a₁ a₃) (h₂ : eq_a a₂ a₄) : eq_a (a₁ + a₂) (a₃ + a₄)
    --characterization of addition
    | zero_add (a) : eq_a (0 + a) a
    | succ_add (a₁ a₂) : eq_a (succ a₁ + a₂) (succ (a₁ + a₂))

    namespace eq_a
      infixl ` =ₐ `:50 := eq_a

      @[refl]
      lemma has_refl (a : arith) : a =ₐ a := --why do we need to specify type here?
      by apply refl

      @[symm]
      lemma has_symm {a₁ a₂ : arith} (h : a₁ =ₐ a₂) : a₂ =ₐ a₁ :=
      by {apply symm, assumption}

      @[trans]
      lemma has_trans {a₁ a₂ a₃ : arith} (h₁ : a₁ =ₐ a₂) (h₂ : a₂ =ₐ a₃) : a₁ =ₐ a₃ :=
      by {apply trans, exact h₁, assumption}

    end eq_a

  end arith

  open arith

  inductive is_numeral : arith → Prop
  | zero : is_numeral 0
  | succ {a} (h : is_numeral a) : is_numeral (succ a)

  def numeral := {a : arith // is_numeral a}

  --Theorems introduced in this chapter:

  --1
  theorem numeral_add_closure (m n : numeral) : ∃ (p : numeral), m.val + n.val =ₐ p.val := begin
    cases m with m hₘ,
    induction hₘ,
    case is_numeral.zero {
      split,
        apply arith.eq_a.zero_add,
    },
    case is_numeral.succ : m' hₘ' h {
      cases h with p' hₚ,
      split,
        show numeral,
        split,
          show arith,
          exact p'.val.succ,
        apply is_numeral.succ,
        exact p'.property,
      apply arith.eq_a.trans,
          apply arith.eq_a.succ_add,
      apply arith.eq_a.congr_succ,
      assumption,
    },
  end

  --2
  theorem arith_to_numeral (a : arith) : ∃ (n : numeral), a =ₐ n.val := begin
    induction a,
    case zero {
      split,
        show numeral,
        split,
          apply is_numeral.zero,
      apply arith.eq_a.refl,
    },
    case succ : a h {
      cases h with n h,
      split,
        show numeral,
        split,
          apply is_numeral.succ,
          exact n.property,
      dsimp only,
      apply arith.eq_a.congr_succ,
      assumption,
    },
    case add : a₁ a₂ h₁ h₂ {
      cases h₁ with n₁ h₁,
      cases h₂ with n₂ h₂,
      have h₃ := numeral_add_closure n₁ n₂,
      cases h₃ with p h,
      split,
        transitivity,
          apply arith.eq_a.congr_add,
                assumption,
              assumption,
          assumption,
    },
  end

  --3
  theorem numeral_add_succ (m n : numeral) : m.val + succ n.val =ₐ succ (m.val + n.val) := begin
    cases m with m hₘ,
    induction hₘ,
    case zero {
      dsimp only,
      transitivity,
        apply arith.eq_a.zero_add,
      apply arith.eq_a.congr_succ,
      symmetry,
      apply arith.eq_a.zero_add,
    },
    case succ : m' hₘ' h {
      dsimp only at *,
      transitivity,
        apply arith.eq_a.succ_add,
      apply arith.eq_a.congr_succ,
      symmetry,
      transitivity,
        apply arith.eq_a.succ_add,
      symmetry,
      assumption,
    }
  end

  --4
  theorem numeral_zero_unit (n : numeral) : 0 + n.val =ₐ n.val ∧ n.val + 0 =ₐ n.val := begin
    split,
      apply arith.eq_a.zero_add,
    cases n with n hₙ,
    dsimp only,
    induction hₙ,
    case zero {
      apply arith.eq_a.zero_add,
    },
    case succ : n' hₙ' h {
      transitivity,
        apply arith.eq_a.succ_add,
      apply arith.eq_a.congr_succ,
      assumption,
    },
  end

  lemma numeral_add_comm (n₁ n₂ : numeral) : n₁.val + n₂.val =ₐ n₂.val + n₁.val := begin
    cases n₁ with n₁ hn₁,
    dsimp only at *,
    induction hn₁,
    case zero {
      symmetry,
      transitivity,
        exact (numeral_zero_unit n₂).2,
      symmetry,
      apply arith.eq_a.zero_add,
    },
    case succ : n₁' hn₁' h {
      transitivity,
        apply arith.eq_a.succ_add,
      transitivity,
        apply arith.eq_a.congr_succ,
          assumption,
      symmetry,
      exact numeral_add_succ n₂ ⟨n₁', hn₁'⟩,
    }
  end

  --5
  theorem add_comm (a₁ a₂ : arith) : a₁ + a₂ =ₐ a₂ + a₁ := begin
    have h₁ := arith_to_numeral a₁,
    cases h₁ with n₁ h₁,
    have h₂ := arith_to_numeral a₂,
    cases h₂ with n₂ h₂,
    transitivity,
      apply arith.eq_a.congr_add,
            assumption,
        assumption,
    symmetry,
    transitivity,
      apply arith.eq_a.congr_add,
            assumption,
        assumption,
    symmetry,
    apply numeral_add_comm,
  end

  lemma numeral_add_assoc (n₁ n₂ n₃ : numeral) : (n₁.val + n₂.val) + n₃.val =ₐ n₁.val + (n₂.val + n₃.val) := begin
    cases n₁ with n₁ hn₁,
    dsimp only at *,
    induction hn₁,
    case zero {
      transitivity,
        apply arith.eq_a.congr_add,
              apply arith.eq_a.zero_add,
          refl,
      symmetry,
      transitivity,
        apply arith.eq_a.zero_add,
      refl,
    },
    case succ : n₁' hn₁' h {
      transitivity,
        apply arith.eq_a.congr_add,
              apply arith.eq_a.succ_add,
          refl,
      transitivity,
        apply arith.eq_a.succ_add,
      transitivity,
        apply arith.eq_a.congr_succ,
          assumption,
      symmetry,
      transitivity,
        apply arith.eq_a.succ_add,
      refl,
    },
  end

  --6
  theorem add_assoc (a₁ a₂ a₃ : arith) : (a₁ + a₂) + a₃ =ₐ a₁ + (a₂ + a₃) := begin
    have h₁ := arith_to_numeral a₁,
    cases h₁ with n₁ h₁,
    have h₂ := arith_to_numeral a₂,
    cases h₂ with n₂ h₂,
    have h₃ := arith_to_numeral a₃,
    cases h₃ with n₃ h₃,
    transitivity,
      apply arith.eq_a.congr_add,
            apply arith.eq_a.congr_add,
                assumption,
            assumption,
        assumption,
    symmetry,
    transitivity,
      apply arith.eq_a.congr_add,
            assumption,
        apply arith.eq_a.congr_add,
            assumption,
        assumption,
    symmetry,
    apply numeral_add_assoc,
  end

  --Conversion from roman numerals to arithmetic expressions
  def c : roman → arith := begin
    let c1 := (1 : arith),
    let cV := c1 + c1 + c1 + c1 + c1,
    let cX := cV + cV,
    let cL := cX + cX + cX + cX + cX,
    let cC := cL + cL,
    let cD := cC + cC + cC + cC + cC,
    let cM := cD + cD,
    intro r,
    induction r,
    exact c1,
    exact cV,
    exact cX,
    exact cL,
    exact cC,
    exact cD,
    exact cM,
    case roman.append : r s cr cs {
      exact cr + cs,
    },
  end

  --7
  theorem congr_conversion {r s : roman} (h : r =ᵣ s) : c r =ₐ c s := begin
    induction h,
    case eq_r.refl {
      refl,
    },
    case eq_r.symm : s r h h' {
      symmetry,
      assumption,
    },
    case eq_r.trans : r t s h₁ h₂ h₁' h₂' {
      transitivity,
      assumption,
      assumption,
    },
    case eq_r.congr : r s r' s' h₁ h₂ h₁' h₂' {
      transitivity,
      apply arith.eq_a.congr_add,
      assumption,
      assumption,
      refl,
    },
    case eq_r.assoc : r s t {
      apply add_assoc,
    },
    case eq_r.comm : r s {
      apply add_comm,
    },
    repeat {refl},
  end

  --------------------------------------------------------------------

  --Exercise 4
  example : (M⬝M⬝X⬝X⬝X⬝X⬝V⬝I⬝I) + (M⬝C⬝C⬝V) =ᵣ M⬝M⬝M⬝C⬝C⬝L⬝I⬝I := begin
    have h₀ : (M⬝M⬝X⬝X⬝X⬝X⬝V⬝I⬝I) + (M⬝C⬝C⬝V) =ᵣ M⬝M⬝X⬝X⬝X⬝X⬝V⬝I⬝I⬝M⬝C⬝C⬝V,
    transitivity, --remove rightmost
    symmetry,
    apply roman.eq_r.assoc,
    transitivity, --remove next
    apply roman.eq_r.congr,
    symmetry,
    apply roman.eq_r.assoc,
    refl,
    transitivity, --remove final
    apply roman.eq_r.congr,
    apply roman.eq_r.congr,
    symmetry,
    apply roman.eq_r.assoc,
    repeat {refl},
    have h₁ : M⬝M⬝X⬝X⬝X⬝X⬝V⬝I⬝I⬝M⬝C⬝C⬝V =ᵣ M⬝M⬝M⬝C⬝C⬝X⬝X⬝X⬝X⬝V⬝V⬝I⬝I,
    --move m into place
    transitivity, --remove 3 rightmost letters
    apply roman.eq_r.congr,
    apply roman.eq_r.congr,
    apply roman.eq_r.congr,
    { transitivity, --swap I⬝M to M⬝I and remove I
      apply roman.eq_r.assoc,
      transitivity,
      apply roman.eq_r.congr,
      refl,
      apply roman.eq_r.comm,
      transitivity,
      symmetry,
      apply roman.eq_r.assoc,
      apply roman.eq_r.congr,
      { transitivity, --repeat process
        apply roman.eq_r.assoc,
        transitivity,
        apply roman.eq_r.congr,
        refl,
        apply roman.eq_r.comm,
        transitivity,
        symmetry,
        apply roman.eq_r.assoc,
        apply roman.eq_r.congr,
        { transitivity, --...
          apply roman.eq_r.assoc,
          transitivity,
          apply roman.eq_r.congr,
          refl,
          apply roman.eq_r.comm,
          transitivity,
          symmetry,
          apply roman.eq_r.assoc,
          apply roman.eq_r.congr,
          { transitivity,
            apply roman.eq_r.assoc,
            transitivity,
            apply roman.eq_r.congr,
            refl,
            apply roman.eq_r.comm,
            transitivity,
            symmetry,
            apply roman.eq_r.assoc,
            apply roman.eq_r.congr,
            { transitivity,
              apply roman.eq_r.assoc,
              transitivity,
              apply roman.eq_r.congr,
              refl,
              apply roman.eq_r.comm,
              transitivity,
              symmetry,
              apply roman.eq_r.assoc,
              apply roman.eq_r.congr,
              { transitivity,
                apply roman.eq_r.assoc,
                transitivity,
                apply roman.eq_r.congr,
                refl,
                apply roman.eq_r.comm,
                transitivity,
                symmetry,
                apply roman.eq_r.assoc,
                apply roman.eq_r.congr,
                { transitivity,
                  apply roman.eq_r.assoc,
                  transitivity,
                  apply roman.eq_r.congr,
                  refl,
                  apply roman.eq_r.comm,
                  transitivity,
                  symmetry,
                  apply roman.eq_r.assoc,
                  apply roman.eq_r.congr,
                  { refl, --m is now in place
                  },
                  refl,
                },
                refl,
              },
              refl,
            },
            refl,
          },
          refl,
        },
        refl,
      },
      refl,
    },
    repeat {refl},
    --move c into place
    transitivity, --remove 1 rightmost letters
    apply roman.eq_r.congr,
    { transitivity,
      apply roman.eq_r.assoc,
      transitivity,
      apply roman.eq_r.congr,
      refl,
      apply roman.eq_r.comm,
      transitivity,
      symmetry,
      apply roman.eq_r.assoc,
      apply roman.eq_r.congr,
      { transitivity,
        apply roman.eq_r.assoc,
        transitivity,
        apply roman.eq_r.congr,
        refl,
        apply roman.eq_r.comm,
        transitivity,
        symmetry,
        apply roman.eq_r.assoc,
        apply roman.eq_r.congr,
        { transitivity,
          apply roman.eq_r.assoc,
          transitivity,
          apply roman.eq_r.congr,
          refl,
          apply roman.eq_r.comm,
          transitivity,
          symmetry,
          apply roman.eq_r.assoc,
          apply roman.eq_r.congr,
          { transitivity,
            apply roman.eq_r.assoc,
            transitivity,
            apply roman.eq_r.congr,
            refl,
            apply roman.eq_r.comm,
            transitivity,
            symmetry,
            apply roman.eq_r.assoc,
            apply roman.eq_r.congr,
            { transitivity,
              apply roman.eq_r.assoc,
              transitivity,
              apply roman.eq_r.congr,
              refl,
              apply roman.eq_r.comm,
              transitivity,
              symmetry,
              apply roman.eq_r.assoc,
              apply roman.eq_r.congr,
              { transitivity,
                apply roman.eq_r.assoc,
                transitivity,
                apply roman.eq_r.congr,
                refl,
                apply roman.eq_r.comm,
                transitivity,
                symmetry,
                apply roman.eq_r.assoc,
                apply roman.eq_r.congr,
                { transitivity,
                  apply roman.eq_r.assoc,
                  transitivity,
                  apply roman.eq_r.congr,
                  refl,
                  apply roman.eq_r.comm,
                  transitivity,
                  symmetry,
                  apply roman.eq_r.assoc,
                  apply roman.eq_r.congr,
                  { transitivity,
                    apply roman.eq_r.assoc,
                    transitivity,
                    apply roman.eq_r.congr,
                    refl,
                    apply roman.eq_r.comm,
                    transitivity,
                    symmetry,
                    apply roman.eq_r.assoc,
                    apply roman.eq_r.congr,
                    { refl, --c is now in place
                    },
                    refl,
                  },
                  refl,
                },
                refl,
              },
              refl,
            },
            refl,
          },
          refl,
        },
        refl,
      },
      refl,
    },
    refl,
    --move c2 into place
    transitivity, --remove 1 rightmost letters
    apply roman.eq_r.congr,
    { transitivity,
      apply roman.eq_r.assoc,
      transitivity,
      apply roman.eq_r.congr,
      refl,
      apply roman.eq_r.comm,
      transitivity,
      symmetry,
      apply roman.eq_r.assoc,
      apply roman.eq_r.congr,
      { transitivity,
        apply roman.eq_r.assoc,
        transitivity,
        apply roman.eq_r.congr,
        refl,
        apply roman.eq_r.comm,
        transitivity,
        symmetry,
        apply roman.eq_r.assoc,
        apply roman.eq_r.congr,
        { transitivity,
          apply roman.eq_r.assoc,
          transitivity,
          apply roman.eq_r.congr,
          refl,
          apply roman.eq_r.comm,
          transitivity,
          symmetry,
          apply roman.eq_r.assoc,
          apply roman.eq_r.congr,
          { transitivity,
            apply roman.eq_r.assoc,
            transitivity,
            apply roman.eq_r.congr,
            refl,
            apply roman.eq_r.comm,
            transitivity,
            symmetry,
            apply roman.eq_r.assoc,
            apply roman.eq_r.congr,
            { transitivity,
              apply roman.eq_r.assoc,
              transitivity,
              apply roman.eq_r.congr,
              refl,
              apply roman.eq_r.comm,
              transitivity,
              symmetry,
              apply roman.eq_r.assoc,
              apply roman.eq_r.congr,
              { transitivity,
                apply roman.eq_r.assoc,
                transitivity,
                apply roman.eq_r.congr,
                refl,
                apply roman.eq_r.comm,
                transitivity,
                symmetry,
                apply roman.eq_r.assoc,
                apply roman.eq_r.congr,
                { transitivity,
                  apply roman.eq_r.assoc,
                  transitivity,
                  apply roman.eq_r.congr,
                  refl,
                  apply roman.eq_r.comm,
                  transitivity,
                  symmetry,
                  apply roman.eq_r.assoc,
                  apply roman.eq_r.congr,
                  { transitivity,
                    apply roman.eq_r.assoc,
                    transitivity,
                    apply roman.eq_r.congr,
                    refl,
                    apply roman.eq_r.comm,
                    transitivity,
                    symmetry,
                    apply roman.eq_r.assoc,
                    apply roman.eq_r.congr,
                    { refl, --c2 is now in place
                    },
                    refl,
                  },
                  refl,
                },
                refl,
              },
              refl,
            },
            refl,
          },
          refl,
        },
        refl,
      },
      refl,
    },
    refl,
    --move v into place
    { transitivity,
      apply roman.eq_r.assoc,
      transitivity,
      apply roman.eq_r.congr,
      refl,
      apply roman.eq_r.comm,
      transitivity,
      symmetry,
      apply roman.eq_r.assoc,
      apply roman.eq_r.congr,
      { transitivity,
        apply roman.eq_r.assoc,
        transitivity,
        apply roman.eq_r.congr,
        refl,
        apply roman.eq_r.comm,
        transitivity,
        symmetry,
        apply roman.eq_r.assoc,
        apply roman.eq_r.congr,
        { refl, --v is now in place
        },
        refl,
      },
      refl,
    },
    have h₂ : M⬝M⬝M⬝C⬝C⬝X⬝X⬝X⬝X⬝V⬝V⬝I⬝I =ᵣ M⬝M⬝M⬝C⬝C⬝X⬝X⬝X⬝X⬝X⬝I⬝I,
    --put brackets in right place
    transitivity,
    apply roman.eq_r.congr,
    apply roman.eq_r.congr,
    { transitivity,
      apply roman.eq_r.assoc,
      --simplify
      apply roman.eq_r.congr,
      refl,
      symmetry,
      apply roman.eq_r.opX,
    },
    repeat {refl},
    have h₃ : M⬝M⬝M⬝C⬝C⬝X⬝X⬝X⬝X⬝X⬝I⬝I =ᵣ M⬝M⬝M⬝C⬝C⬝L⬝I⬝I,
    --put brackets in right place
    transitivity,
    apply roman.eq_r.congr,
    apply roman.eq_r.congr,
    { transitivity,
      apply roman.eq_r.congr,
      { transitivity,
        apply roman.eq_r.congr,
        { transitivity,
          apply roman.eq_r.congr,
          { apply roman.eq_r.assoc,
          },
          refl,
          apply roman.eq_r.assoc,
        },
        refl,
        apply roman.eq_r.assoc,
      },
      refl,
      transitivity,
      apply roman.eq_r.assoc,
      --simplify
      apply roman.eq_r.congr,
      refl,
      symmetry,
      apply roman.eq_r.opL,
    },
    repeat {refl},

    --finally, string all existing hypotheses together
    repeat {
      transitivity,
      assumption,
    },
    refl,
  end

  --Exercise 5
  def one := succ 0
  def two := succ one
  def three := succ two
  def four := succ three
  example : two + two =ₐ four := begin
    repeat {
      transitivity,
      apply arith.eq_a.succ_add,
      apply arith.eq_a.congr_succ,
    },
    apply arith.eq_a.zero_add,
  end

  --Exercise 6
  example {m n p: arith} : m + n + p =ₐ p + n + m := begin
    --swap m and n
    transitivity,
    apply arith.eq_a.congr_add,
    apply add_comm,
    refl,
    --swap m and p
    transitivity,
    apply add_assoc,
    transitivity,
    apply arith.eq_a.congr_add,
    refl,
    apply add_comm,
    transitivity,
    symmetry,
    apply add_assoc,
    --swap n and p
    transitivity,
    apply arith.eq_a.congr_add,
    apply add_comm,
    refl,
    --done
    refl,
  end

  --Exercise 7
  /-
  Need to think about this..
  -/

end chapter2


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl, Patrick Massot
-/
import data.set.basic

/-!
# Sets in product and pi types

This file defines the product of sets in `α × β` and in `Π i, α i` along with the diagonal of a
type.

## Main declarations

* `set.prod`: Binary product of sets. For `s : set α`, `t : set β`, we have
  `s.prod t : set (α × β)`.
* `set.diagonal`: Diagonal of a type. `set.diagonal α = {(x, x) | x : α}`.
* `set.pi`: Arbitrary product of sets.
-/

open function

/-- Notation class for product of subobjects (sets, submonoids, subgroups, etc). -/
class has_set_prod (α β : Type*) (γ : out_param Type*) :=
(prod : α → β → γ)

infixr ` ×ˢ `:72 := has_set_prod.prod

namespace set

/-! ### Cartesian binary product of sets -/

section prod
variables {α β γ δ : Type*} {s s₁ s₂ : set α} {t t₁ t₂ : set β} {a : α} {b : β}

/-- The cartesian product `prod s t` is the set of `(a, b)`
  such that `a ∈ s` and `b ∈ t`. -/
instance : has_set_prod (set α) (set β) (set (α × β)) :=
⟨λ s t, {p | p.1 ∈ s ∧ p.2 ∈ t}⟩

lemma prod_eq (s : set α) (t : set β) : s ×ˢ t = prod.fst ⁻¹' s ∩ prod.snd ⁻¹' t := rfl

lemma mem_prod_eq {p : α × β} : p ∈ s ×ˢ t = (p.1 ∈ s ∧ p.2 ∈ t) := rfl

@[simp] lemma mem_prod {p : α × β} : p ∈ s ×ˢ t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

@[simp] lemma prod_mk_mem_set_prod_eq : (a, b) ∈ s ×ˢ t = (a ∈ s ∧ b ∈ t) := rfl

lemma mk_mem_prod (ha : a ∈ s) (hb : b ∈ t) : (a, b) ∈ s ×ˢ t := ⟨ha, hb⟩

lemma prod_mono (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁ ×ˢ t₁ ⊆ s₂ ×ˢ t₂ :=
λ x ⟨h₁, h₂⟩, ⟨hs h₁, ht h₂⟩

lemma prod_subset_iff {P : set (α × β)} : (s ×ˢ t ⊆ P) ↔ ∀ (x ∈ s) (y ∈ t), (x, y) ∈ P :=
⟨λ h _ hx _ hy, h (mk_mem_prod hx hy), λ h ⟨_, _⟩ hp, h _ hp.1 _ hp.2⟩

lemma forall_prod_set {p : α × β → Prop} : (∀ x ∈ s ×ˢ t, p x) ↔ ∀ (x ∈ s) (y ∈ t), p (x, y) :=
prod_subset_iff

lemma exists_prod_set {p : α × β → Prop} : (∃ x ∈ s ×ˢ t, p x) ↔ ∃ (x ∈ s) (y ∈ t), p (x, y) :=
by simp [and_assoc]

@[simp] lemma prod_empty : s ×ˢ (∅ : set β) = ∅ := by { ext, exact and_false _ }

@[simp] lemma empty_prod : (∅ : set α) ×ˢ t = ∅ := by { ext, exact false_and _ }

@[simp] lemma univ_prod_univ : @univ α ×ˢ @univ β = univ := by { ext, exact true_and _ }

lemma univ_prod {t : set β} : (univ : set α) ×ˢ t = prod.snd ⁻¹' t := by simp [prod_eq]

lemma prod_univ {s : set α} : s ×ˢ (univ : set β) = prod.fst ⁻¹' s := by simp [prod_eq]

@[simp] lemma singleton_prod : ({a} : set α) ×ˢ t = prod.mk a '' t :=
by { ext ⟨x, y⟩, simp [and.left_comm, eq_comm] }

@[simp] lemma prod_singleton : s ×ˢ ({b} : set β) = (λ a, (a, b)) '' s :=
by { ext ⟨x, y⟩, simp [and.left_comm, eq_comm] }

lemma singleton_prod_singleton : ({a} : set α) ×ˢ ({b} : set β) = {(a, b)} :=by simp

@[simp] lemma union_prod : (s₁ ∪ s₂) ×ˢ t = s₁ ×ˢ t ∪ s₂ ×ˢ t :=
by { ext ⟨x, y⟩, simp [or_and_distrib_right] }

@[simp] lemma prod_union : s ×ˢ (t₁ ∪ t₂) = s ×ˢ t₁ ∪ s ×ˢ t₂ :=
by { ext ⟨x, y⟩, simp [and_or_distrib_left] }

lemma prod_inter_prod : s₁ ×ˢ t₁ ∩ s₂ ×ˢ t₂ = (s₁ ∩ s₂) ×ˢ (t₁ ∩ t₂) :=
by { ext ⟨x, y⟩, simp [and_assoc, and.left_comm] }

lemma insert_prod : insert a s ×ˢ t = (prod.mk a '' t) ∪ s ×ˢ t :=
by { ext ⟨x, y⟩, simp [image, iff_def, or_imp_distrib, imp.swap] {contextual := tt} }

lemma prod_insert : s ×ˢ (insert b t) = ((λa, (a, b)) '' s) ∪ s ×ˢ t :=
by { ext ⟨x, y⟩, simp [image, iff_def, or_imp_distrib, imp.swap] {contextual := tt} }

lemma prod_preimage_eq {f : γ → α} {g : δ → β} :
  (f ⁻¹' s) ×ˢ (g ⁻¹' t) = (λ p : γ × δ, (f p.1, g p.2)) ⁻¹' (s ×ˢ t) := rfl

lemma prod_preimage_left {f : γ → α} :
  (f ⁻¹' s) ×ˢ t = (λ p : γ × β, (f p.1, p.2)) ⁻¹' (s ×ˢ t) := rfl

lemma prod_preimage_right {g : δ → β} :
  s ×ˢ (g ⁻¹' t) = (λ p : α × δ, (p.1, g p.2)) ⁻¹' (s ×ˢ t) := rfl

lemma preimage_prod_map_prod (f : α → β) (g : γ → δ) (s : set β) (t : set δ) :
  prod.map f g ⁻¹' (s ×ˢ t) = (f ⁻¹' s) ×ˢ (g ⁻¹' t) :=
rfl

lemma mk_preimage_prod (f : γ → α) (g : γ → β) :
  (λ x, (f x, g x)) ⁻¹' (s ×ˢ t) = f ⁻¹' s ∩ g ⁻¹' t := rfl

@[simp] lemma mk_preimage_prod_left (hb : b ∈ t) : (λ a, (a, b)) ⁻¹' (s ×ˢ t) = s :=
by { ext a, simp [hb] }

@[simp] lemma mk_preimage_prod_right (ha : a ∈ s) : prod.mk a ⁻¹' (s ×ˢ t) = t :=
by { ext b, simp [ha] }

@[simp] lemma mk_preimage_prod_left_eq_empty (hb : b ∉ t) : (λ a, (a, b)) ⁻¹' (s ×ˢ t) = ∅ :=
by { ext a, simp [hb] }

@[simp] lemma mk_preimage_prod_right_eq_empty (ha : a ∉ s) : prod.mk a ⁻¹' (s ×ˢ t) = ∅ :=
by { ext b, simp [ha] }

lemma mk_preimage_prod_left_eq_if [decidable_pred (∈ t)] :
  (λ a, (a, b)) ⁻¹' (s ×ˢ t) = if b ∈ t then s else ∅ :=
by split_ifs; simp [h]

lemma mk_preimage_prod_left_fn_eq_if [decidable_pred (∈ t)] (f : γ → α) :
  (λ a, (f a, b)) ⁻¹' (s ×ˢ t) = if b ∈ t then f ⁻¹' s else ∅ :=
by rw [← mk_preimage_prod_left_eq_if, prod_preimage_left, preimage_preimage]

lemma mk_preimage_prod_right_fn_eq_if [decidable_pred (∈ s)] (g : δ → β) :
  (λ b, (a, g b)) ⁻¹' (s ×ˢ t) = if a ∈ s then g ⁻¹' t else ∅ :=
by rw [← mk_preimage_prod_right_eq_if, prod_preimage_right, preimage_preimage]

lemma preimage_swap_prod {s : set α} {t : set β} : prod.swap ⁻¹' (t ×ˢ s) = s ×ˢ t :=
by { ext ⟨x, y⟩, simp [and_comm] }

lemma image_swap_prod : prod.swap '' (t ×ˢ s) = s ×ˢ t :=
by rw [image_swap_eq_preimage_swap, preimage_swap_prod]

lemma prod_image_image_eq {m₁ : α → γ} {m₂ : β → δ} :
  (m₁ '' s) ×ˢ (m₂ '' t) = image (λ p : α × β, (m₁ p.1, m₂ p.2)) (s ×ˢ t) :=
ext $ by simp [-exists_and_distrib_right, exists_and_distrib_right.symm, and.left_comm,
  and.assoc, and.comm]

lemma prod_range_range_eq {m₁ : α → γ} {m₂ : β → δ} :
  (range m₁) ×ˢ (range m₂) = range (λ p : α × β, (m₁ p.1, m₂ p.2)) :=
ext $ by simp [range]

@[simp] lemma range_prod_map {m₁ : α → γ} {m₂ : β → δ} :
  range (prod.map m₁ m₂) = (range m₁) ×ˢ (range m₂) :=
prod_range_range_eq.symm

lemma prod_range_univ_eq {m₁ : α → γ} :
  (range m₁) ×ˢ (univ : set β) = range (λ p : α × β, (m₁ p.1, p.2)) :=
ext $ by simp [range]

lemma prod_univ_range_eq {m₂ : β → δ} :
  (univ : set α) ×ˢ (range m₂) = range (λ p : α × β, (p.1, m₂ p.2)) :=
ext $ by simp [range]

lemma range_pair_subset (f : α → β) (g : α → γ) :
  range (λ x, (f x, g x)) ⊆ (range f) ×ˢ (range g) :=
have (λ x, (f x, g x)) = prod.map f g ∘ (λ x, (x, x)), from funext (λ x, rfl),
by { rw [this, ← range_prod_map], apply range_comp_subset_range }

lemma nonempty.prod : s.nonempty → t.nonempty → (s ×ˢ t : set _).nonempty :=
λ ⟨x, hx⟩ ⟨y, hy⟩, ⟨(x, y), ⟨hx, hy⟩⟩

lemma nonempty.fst : (s ×ˢ t : set _).nonempty → s.nonempty := λ ⟨x, hx⟩, ⟨x.1, hx.1⟩
lemma nonempty.snd : (s ×ˢ t : set _).nonempty → t.nonempty := λ ⟨x, hx⟩, ⟨x.2, hx.2⟩

lemma prod_nonempty_iff : (s ×ˢ t : set _).nonempty ↔ s.nonempty ∧ t.nonempty :=
⟨λ h, ⟨h.fst, h.snd⟩, λ h, h.1.prod h.2⟩

lemma prod_eq_empty_iff : s ×ˢ t = ∅ ↔ (s = ∅ ∨ t = ∅) :=
by simp only [not_nonempty_iff_eq_empty.symm, prod_nonempty_iff, not_and_distrib]

lemma prod_sub_preimage_iff {W : set γ} {f : α × β → γ} :
  s ×ˢ t ⊆ f ⁻¹' W ↔ ∀ a b, a ∈ s → b ∈ t → f (a, b) ∈ W :=
by simp [subset_def]

lemma image_prod_mk_subset_prod_left (hb : b ∈ t) : (λ a, (a, b)) '' s ⊆ s ×ˢ t :=
by { rintro _ ⟨a, ha, rfl⟩, exact ⟨ha, hb⟩ }

lemma image_prod_mk_subset_prod_right (ha : a ∈ s) : prod.mk a '' t ⊆ s ×ˢ t :=
by { rintro _ ⟨b, hb, rfl⟩, exact ⟨ha, hb⟩ }

lemma fst_image_prod_subset (s : set α) (t : set β) : prod.fst '' (s ×ˢ t) ⊆ s :=
λ _ h, let ⟨_, ⟨h₂, _⟩, h₁⟩ := (set.mem_image _ _ _).1 h in h₁ ▸ h₂

lemma prod_subset_preimage_fst (s : set α) (t : set β) : s ×ˢ t ⊆ prod.fst ⁻¹' s :=
image_subset_iff.1 (fst_image_prod_subset s t)

lemma fst_image_prod (s : set β) {t : set α} (ht : t.nonempty) : prod.fst '' (s ×ˢ t) = s :=
(fst_image_prod_subset _ _).antisymm $ λ y hy, let ⟨x, hx⟩ := ht in ⟨(y, x), ⟨hy, hx⟩, rfl⟩

lemma snd_image_prod_subset (s : set α) (t : set β) : prod.snd '' (s ×ˢ t) ⊆ t :=
λ _ h, let ⟨_, ⟨_, h₂⟩, h₁⟩ := (set.mem_image _ _ _).1 h in h₁ ▸ h₂

lemma prod_subset_preimage_snd (s : set α) (t : set β) : s ×ˢ t ⊆ prod.snd ⁻¹' t :=
image_subset_iff.1 (snd_image_prod_subset s t)

lemma snd_image_prod {s : set α} (hs : s.nonempty) (t : set β) : prod.snd '' (s ×ˢ t) = t :=
(snd_image_prod_subset _ _).antisymm $ λ y y_in, let ⟨x, x_in⟩ := hs in ⟨(x, y), ⟨x_in, y_in⟩, rfl⟩

lemma prod_diff_prod : s ×ˢ t \ s₁ ×ˢ t₁ = s ×ˢ (t \ t₁) ∪ (s \ s₁) ×ˢ t :=
by { ext x, by_cases h₁ : x.1 ∈ s₁; by_cases h₂ : x.2 ∈ t₁; simp * }

/-- A product set is included in a product set if and only factors are included, or a factor of the
first set is empty. -/
lemma prod_subset_prod_iff : s ×ˢ t ⊆ s₁ ×ˢ t₁ ↔ s ⊆ s₁ ∧ t ⊆ t₁ ∨ s = ∅ ∨ t = ∅ :=
begin
  cases (s ×ˢ t : set _).eq_empty_or_nonempty with h h,
  { simp [h, prod_eq_empty_iff.1 h] },
  have st : s.nonempty ∧ t.nonempty, by rwa [prod_nonempty_iff] at h,
  refine ⟨λ H, or.inl ⟨_, _⟩, _⟩,
  { have := image_subset (prod.fst : α × β → α) H,
    rwa [fst_image_prod _ st.2, fst_image_prod _ (h.mono H).snd] at this },
  { have := image_subset (prod.snd : α × β → β) H,
    rwa [snd_image_prod st.1, snd_image_prod (h.mono H).fst] at this },
  { intro H,
    simp only [st.1.ne_empty, st.2.ne_empty, or_false] at H,
    exact prod_mono H.1 H.2 }
end

@[simp] lemma prod_eq_iff_eq (ht : t.nonempty) : s ×ˢ t = s₁ ×ˢ t ↔ s = s₁ :=
begin
  obtain ⟨b, hb⟩ := ht,
  split,
  { simp only [set.ext_iff],
    intros h a,
    simpa [hb, set.mem_prod] using h (a, b) },
  { rintros rfl,
    refl },
end

@[simp] lemma image_prod (f : α → β → γ) : (λ x : α × β, f x.1 x.2) '' (s ×ˢ t) = image2 f s t :=
set.ext $ λ a,
⟨ by { rintro ⟨_, _, rfl⟩, exact ⟨_, _, (mem_prod.mp ‹_›).1, (mem_prod.mp ‹_›).2, rfl⟩ },
  by { rintro ⟨_, _, _, _, rfl⟩, exact ⟨(_, _), mem_prod.mpr ⟨‹_›, ‹_›⟩, rfl⟩ }⟩

end prod

/-! ### Diagonal -/

section diagonal
variables {α : Type*}

/-- `diagonal α` is the set of `α × α` consisting of all pairs of the form `(a, a)`. -/
def diagonal (α : Type*) : set (α × α) := {p | p.1 = p.2}

@[simp] lemma mem_diagonal (x : α) : (x, x) ∈ diagonal α := by simp [diagonal]

lemma preimage_coe_coe_diagonal (s : set α) : (prod.map coe coe) ⁻¹' (diagonal α) = diagonal s :=
by { ext ⟨⟨x, hx⟩, ⟨y, hy⟩⟩, simp [set.diagonal] }

lemma diagonal_eq_range : diagonal α = range (λ x, (x, x)) :=
by { ext ⟨x, y⟩, simp [diagonal, eq_comm] }

end diagonal

/-! ### Cartesian set-indexed product of sets -/

section pi
variables {ι : Type*} {α β : ι → Type*} {s s₁ s₂ : set ι} {t t₁ t₂ : Π i, set (α i)} {i : ι}

/-- Given an index set `ι` and a family of sets `t : Π i, set (α i)`, `pi s t`
is the set of dependent functions `f : Πa, π a` such that `f a` belongs to `t a`
whenever `a ∈ s`. -/
def pi (s : set ι) (t : Π i, set (α i)) : set (Π i, α i) := {f | ∀ i ∈ s, f i ∈ t i}

@[simp] lemma mem_pi {f : Π i, α i} : f ∈ s.pi t ↔ ∀ i ∈ s, f i ∈ t i := iff.rfl

@[simp] lemma mem_univ_pi {f : Π i, α i} : f ∈ pi univ t ↔ ∀ i, f i ∈ t i := by simp

@[simp] lemma empty_pi (s : Π i, set (α i)) : pi ∅ s = univ := by { ext, simp [pi] }

@[simp] lemma pi_univ (s : set ι) : pi s (λ i, (univ : set (α i))) = univ :=
eq_univ_of_forall $ λ f i hi, mem_univ _

lemma pi_mono (h : ∀ i ∈ s, t₁ i ⊆ t₂ i) : pi s t₁ ⊆ pi s t₂ :=
λ x hx i hi, (h i hi $ hx i hi)

lemma pi_inter_distrib : s.pi (λ i, t i ∩ t₁ i) = s.pi t ∩ s.pi t₁ :=
ext $ λ x, by simp only [forall_and_distrib, mem_pi, mem_inter_eq]

lemma pi_congr (h : s₁ = s₂) (h' : ∀ i ∈ s₁, t₁ i = t₂ i) : s₁.pi t₁ = s₂.pi t₂ :=
h ▸ (ext $ λ x, forall₂_congr $ λ i hi, h' i hi ▸ iff.rfl)

lemma pi_eq_empty (hs : i ∈ s) (ht : t i = ∅) : s.pi t = ∅ :=
by { ext f, simp only [mem_empty_eq, not_forall, iff_false, mem_pi, not_imp],
     exact ⟨i, hs, by simp [ht]⟩ }

lemma univ_pi_eq_empty (ht : t i = ∅) : pi univ t = ∅ := pi_eq_empty (mem_univ i) ht

lemma pi_nonempty_iff : (s.pi t).nonempty ↔ ∀ i, ∃ x, i ∈ s → x ∈ t i :=
by simp [classical.skolem, set.nonempty]

lemma univ_pi_nonempty_iff : (pi univ t).nonempty ↔ ∀ i, (t i).nonempty :=
by simp [classical.skolem, set.nonempty]

lemma pi_eq_empty_iff : s.pi t = ∅ ↔ ∃ i, is_empty (α i) ∨ i ∈ s ∧ t i = ∅ :=
begin
  rw [← not_nonempty_iff_eq_empty, pi_nonempty_iff],
  push_neg,
  refine exists_congr (λ i, ⟨λ h, (is_empty_or_nonempty (α i)).imp_right _, _⟩),
  { rintro ⟨x⟩,
    exact ⟨(h x).1, by simp [eq_empty_iff_forall_not_mem, h]⟩ },
  { rintro (h | h) x,
    { exact h.elim' x },
    { simp [h] } }
end

lemma univ_pi_eq_empty_iff : pi univ t = ∅ ↔ ∃ i, t i = ∅ :=
by simp [← not_nonempty_iff_eq_empty, univ_pi_nonempty_iff]

@[simp] lemma univ_pi_empty [h : nonempty ι] : pi univ (λ i, ∅ : Π i, set (α i)) = ∅ :=
univ_pi_eq_empty_iff.2 $ h.elim $ λ x, ⟨x, rfl⟩

@[simp] lemma range_dcomp (f : Π i, α i → β i) :
  range (λ (g : Π i, α i), (λ i, f i (g i))) = pi univ (λ i, range (f i)) :=
begin
  apply subset.antisymm _ (λ x hx, _),
  { rintro _ ⟨x, rfl⟩ i -,
    exact ⟨x i, rfl⟩ },
  { choose y hy using hx,
    exact ⟨λ i, y i trivial, funext $ λ i, hy i trivial⟩ }
end

@[simp] lemma insert_pi (i : ι) (s : set ι) (t : Π i, set (α i)) :
  pi (insert i s) t = (eval i ⁻¹' t i) ∩ pi s t :=
by { ext, simp [pi, or_imp_distrib, forall_and_distrib] }

@[simp] lemma singleton_pi (i : ι) (t : Π i, set (α i)) : pi {i} t = (eval i ⁻¹' t i) :=
by { ext, simp [pi] }

lemma singleton_pi' (i : ι) (t : Π i, set (α i)) : pi {i} t = {x | x i ∈ t i} := singleton_pi i t

lemma pi_if {p : ι → Prop} [h : decidable_pred p] (s : set ι) (t₁ t₂ : Π i, set (α i)) :
  pi s (λ i, if p i then t₁ i else t₂ i) = pi {i ∈ s | p i} t₁ ∩ pi {i ∈ s | ¬ p i} t₂ :=
begin
  ext f,
  refine ⟨λ h, _, _⟩,
  { split; { rintro i ⟨his, hpi⟩, simpa [*] using h i } },
  { rintro ⟨ht₁, ht₂⟩ i his,
    by_cases p i; simp * at * }
end

lemma union_pi : (s₁ ∪ s₂).pi t = s₁.pi t ∩ s₂.pi t :=
by simp [pi, or_imp_distrib, forall_and_distrib, set_of_and]

@[simp] lemma pi_inter_compl (s : set ι) : pi s t ∩ pi sᶜ t = pi univ t :=
by rw [← union_pi, union_compl_self]

lemma pi_update_of_not_mem [decidable_eq ι] (hi : i ∉ s) (f : Π j, α j) (a : α i)
  (t : Π j, α j → set (β j)) :
  s.pi (λ j, t j (update f i a j)) = s.pi (λ j, t j (f j)) :=
pi_congr rfl $ λ j hj, by { rw update_noteq, exact λ h, hi (h ▸ hj) }

lemma pi_update_of_mem [decidable_eq ι] (hi : i ∈ s) (f : Π j, α j) (a : α i)
  (t : Π j, α j → set (β j)) :
  s.pi (λ j, t j (update f i a j)) = {x | x i ∈ t i a} ∩ (s \ {i}).pi (λ j, t j (f j)) :=
calc s.pi (λ j, t j (update f i a j)) = ({i} ∪ s \ {i}).pi (λ j, t j (update f i a j)) :
  by rw [union_diff_self, union_eq_self_of_subset_left (singleton_subset_iff.2 hi)]
... = {x | x i ∈ t i a} ∩ (s \ {i}).pi (λ j, t j (f j)) :
  by { rw [union_pi, singleton_pi', update_same, pi_update_of_not_mem], simp }

lemma univ_pi_update [decidable_eq ι] {β : Π i, Type*} (i : ι) (f : Π j, α j) (a : α i)
  (t : Π j, α j → set (β j)) :
  pi univ (λ j, t j (update f i a j)) = {x | x i ∈ t i a} ∩ pi {i}ᶜ (λ j, t j (f j)) :=
by rw [compl_eq_univ_diff, ← pi_update_of_mem (mem_univ _)]

lemma univ_pi_update_univ [decidable_eq ι] (i : ι) (s : set (α i)) :
  pi univ (update (λ j : ι, (univ : set (α j))) i s) = eval i ⁻¹' s :=
by rw [univ_pi_update i (λ j, (univ : set (α j))) s (λ j t, t), pi_univ, inter_univ, preimage]

lemma eval_image_pi (hs : i ∈ s) (ht : (s.pi t).nonempty) : eval i '' s.pi t = t i :=
begin
  classical,
  ext x,
  obtain ⟨f, hf⟩ := ht,
  refine ⟨_, λ hg, ⟨update f i x, λ j hj, _, by simp⟩⟩,
  { rintro ⟨g, hg, rfl⟩,
    exact hg i hs },
  { obtain rfl | hji := eq_or_ne j i,
    { simp [hg] },
    { rw [mem_pi] at hf, simp [hji, hf _ hj] } }
end

@[simp] lemma eval_image_univ_pi (ht : (pi univ t).nonempty) :
  (λ f : Π i, α i, f i) '' pi univ t = t i :=
eval_image_pi (mem_univ i) ht

lemma eval_preimage [decidable_eq ι] {s : set (α i)} :
  eval i ⁻¹' s = pi univ (update (λ i, univ) i s) :=
by { ext x, simp [@forall_update_iff _ (λ i, set (α i)) _ _ _ _ (λ i' y, x i' ∈ y)] }

lemma eval_preimage' [decidable_eq ι] {s : set (α i)} :
  eval i ⁻¹' s = pi {i} (update (λ i, univ) i s) :=
by { ext, simp }

lemma update_preimage_pi [decidable_eq ι] {f : Π i, α i} (hi : i ∈ s)
  (hf : ∀ j ∈ s, j ≠ i → f j ∈ t j) :
  (update f i) ⁻¹' s.pi t = t i :=
begin
  ext x,
  refine ⟨λ h, _, λ hx j hj, _⟩,
  { convert h i hi,
    simp },
  { obtain rfl | h := eq_or_ne j i,
    { simpa },
    { rw update_noteq h,
      exact hf j hj h } }
end

lemma update_preimage_univ_pi [decidable_eq ι] {f : Π i, α i} (hf : ∀ j ≠ i, f j ∈ t j) :
  (update f i) ⁻¹' pi univ t = t i :=
update_preimage_pi (mem_univ i) (λ j _, hf j)

lemma subset_pi_eval_image (s : set ι) (u : set (Π i, α i)) : u ⊆ pi s (λ i, eval i '' u) :=
λ f hf i hi, ⟨f, hf, rfl⟩

lemma univ_pi_ite (s : set ι) [decidable_pred (∈ s)] (t : Π i, set (α i)) :
  pi univ (λ i, if i ∈ s then t i else univ) = s.pi t :=
by { ext, simp_rw [mem_univ_pi], refine forall_congr (λ i, _), split_ifs; simp [h] }

end pi
end set