/-
Copyright (c) 2021 Aaron Anderson, Jesse Michael Han, Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Jesse Michael Han, Floris van Doorn
-/
import category_theory.concrete_category.bundled
import data.fin.tuple.basic
import data.fin.vec_notation
import logic.encodable.basic
import logic.small
import set_theory.cardinal.basic

/-!
# Basics on First-Order Structures
This file defines first-order languages and structures in the style of the
[Flypitch project](https://flypitch.github.io/), as well as several important maps between
structures.

## Main Definitions
* A `first_order.language` defines a language as a pair of functions from the natural numbers to
  `Type l`. One sends `n` to the type of `n`-ary functions, and the other sends `n` to the type of
  `n`-ary relations.
* A `first_order.language.Structure` interprets the symbols of a given `first_order.language` in the
  context of a given type.
* A `first_order.language.hom`, denoted `M →[L] N`, is a map from the `L`-structure `M` to the
  `L`-structure `N` that commutes with the interpretations of functions, and which preserves the
  interpretations of relations (although only in the forward direction).
* A `first_order.language.embedding`, denoted `M ↪[L] N`, is an embedding from the `L`-structure `M`
  to the `L`-structure `N` that commutes with the interpretations of functions, and which preserves
  the interpretations of relations in both directions.
* A `first_order.language.elementary_embedding`, denoted `M ↪ₑ[L] N`, is an embedding from the
  `L`-structure `M` to the `L`-structure `N` that commutes with the realizations of all formulas.
* A `first_order.language.equiv`, denoted `M ≃[L] N`, is an equivalence from the `L`-structure `M`
  to the `L`-structure `N` that commutes with the interpretations of functions, and which preserves
  the interpretations of relations in both directions.

## References
For the Flypitch project:
- [J. Han, F. van Doorn, *A formal proof of the independence of the continuum hypothesis*]
[flypitch_cpp]
- [J. Han, F. van Doorn, *A formalization of forcing and the unprovability of
the continuum hypothesis*][flypitch_itp]

-/
universes u v u' v' w w'

open_locale cardinal
open cardinal

namespace first_order

/-! ### Languages and Structures -/

/-- A first-order language consists of a type of functions of every natural-number arity and a
  type of relations of every natural-number arity. -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
structure language :=
(functions : ℕ → Type u) (relations : ℕ → Type v)

/-- Used to define `first_order.language₂`. -/
@[simp] def sequence₂ (a₀ a₁ a₂ : Type u) : ℕ → Type u
| 0 := a₀
| 1 := a₁
| 2 := a₂
| _ := pempty

namespace sequence₂

variables (a₀ a₁ a₂ : Type u)

instance inhabited₀ [h : inhabited a₀] : inhabited (sequence₂ a₀ a₁ a₂ 0) := h

instance inhabited₁ [h : inhabited a₁] : inhabited (sequence₂ a₀ a₁ a₂ 1) := h

instance inhabited₂ [h : inhabited a₂] : inhabited (sequence₂ a₀ a₁ a₂ 2) := h

instance {n : ℕ} : is_empty (sequence₂ a₀ a₁ a₂ (n + 3)) := pempty.is_empty

@[simp] lemma lift_mk {i : ℕ} :
  cardinal.lift (# (sequence₂ a₀ a₁ a₂ i)) = # (sequence₂ (ulift a₀) (ulift a₁) (ulift a₂) i) :=
begin
  rcases i with (_ | _ | _ | i);
  simp only [sequence₂, mk_ulift, mk_fintype, fintype.card_of_is_empty, nat.cast_zero, lift_zero],
end

@[simp] lemma sum_card :
  cardinal.sum (λ i, # (sequence₂ a₀ a₁ a₂ i)) = # a₀ + # a₁ + # a₂ :=
begin
  rw [sum_nat_eq_add_sum_succ, sum_nat_eq_add_sum_succ, sum_nat_eq_add_sum_succ],
  simp [add_assoc],
end

end sequence₂

namespace language

/-- A constructor for languages with only constants, unary and binary functions, and
unary and binary relations. -/
@[simps] protected def mk₂ (c f₁ f₂ : Type u) (r₁ r₂ : Type v) : language :=
⟨sequence₂ c f₁ f₂, sequence₂ pempty r₁ r₂⟩

/-- The empty language has no symbols. -/
protected def empty : language := ⟨λ _, empty, λ _, empty⟩

instance : inhabited language := ⟨language.empty⟩

/-- The sum of two languages consists of the disjoint union of their symbols. -/
protected def sum (L : language.{u v}) (L' : language.{u' v'}) : language :=
⟨λn, L.functions n ⊕ L'.functions n, λ n, L.relations n ⊕ L'.relations n⟩

variable (L : language.{u v})

/-- The type of constants in a given language. -/
@[nolint has_inhabited_instance] protected def «constants» := L.functions 0

@[simp] lemma constants_mk₂ (c f₁ f₂ : Type u) (r₁ r₂ : Type v) :
  (language.mk₂ c f₁ f₂ r₁ r₂).constants = c :=
rfl

/-- The type of symbols in a given language. -/
@[nolint has_inhabited_instance] def symbols := (Σl, L.functions l) ⊕ (Σl, L.relations l)

/-- The cardinality of a language is the cardinality of its type of symbols. -/
def card : cardinal := # L.symbols

/-- A language is countable when it has countably many symbols. -/
class countable : Prop := (card_le_aleph_0' : L.card ≤ ℵ₀)

lemma card_le_aleph_0 [L.countable] : L.card ≤ ℵ₀ := countable.card_le_aleph_0'

/-- A language is relational when it has no function symbols. -/
class is_relational : Prop :=
(empty_functions : ∀ n, is_empty (L.functions n))

/-- A language is algebraic when it has no relation symbols. -/
class is_algebraic : Prop :=
(empty_relations : ∀ n, is_empty (L.relations n))

/-- A language is countable when it has countably many symbols. -/
class countable_functions : Prop := (card_functions_le_aleph_0' : # (Σ l, L.functions l) ≤ ℵ₀)

lemma card_functions_le_aleph_0 [L.countable_functions] : #(Σ l, L.functions l) ≤ ℵ₀ :=
countable_functions.card_functions_le_aleph_0'

variables {L} {L' : language.{u' v'}}

lemma card_eq_card_functions_add_card_relations :
  L.card = cardinal.sum (λ l, (cardinal.lift.{v} (#(L.functions l)))) +
    cardinal.sum (λ l, cardinal.lift.{u} (#(L.relations l))) :=
by simp [card, symbols]

instance [L.is_relational] {n : ℕ} : is_empty (L.functions n) := is_relational.empty_functions n

instance [L.is_algebraic] {n : ℕ} : is_empty (L.relations n) := is_algebraic.empty_relations n

instance is_relational_of_empty_functions {symb : ℕ → Type*} : is_relational ⟨λ _, empty, symb⟩ :=
⟨λ _, empty.is_empty⟩

instance is_algebraic_of_empty_relations {symb : ℕ → Type*}  : is_algebraic ⟨symb, λ _, empty⟩ :=
⟨λ _, empty.is_empty⟩

instance is_relational_empty : is_relational language.empty :=
language.is_relational_of_empty_functions

instance is_algebraic_empty : is_algebraic language.empty :=
language.is_algebraic_of_empty_relations

instance is_relational_sum [L.is_relational] [L'.is_relational] : is_relational (L.sum L') :=
⟨λ n, sum.is_empty⟩

instance is_algebraic_sum [L.is_algebraic] [L'.is_algebraic] : is_algebraic (L.sum L') :=
⟨λ n, sum.is_empty⟩

instance is_relational_mk₂ {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  [h0 : is_empty c] [h1 : is_empty f₁] [h2 : is_empty f₂] :
  is_relational (language.mk₂ c f₁ f₂ r₁ r₂) :=
⟨λ n, nat.cases_on n h0 (λ n, nat.cases_on n h1 (λ n, nat.cases_on n h2 (λ _, pempty.is_empty)))⟩

instance is_algebraic_mk₂ {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  [h1 : is_empty r₁] [h2 : is_empty r₂] :
  is_algebraic (language.mk₂ c f₁ f₂ r₁ r₂) :=
⟨λ n, nat.cases_on n pempty.is_empty
  (λ n, nat.cases_on n h1 (λ n, nat.cases_on n h2 (λ _, pempty.is_empty)))⟩

instance subsingleton_mk₂_functions {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  [h0 : subsingleton c] [h1 : subsingleton f₁] [h2 : subsingleton f₂] {n : ℕ} :
  subsingleton ((language.mk₂ c f₁ f₂ r₁ r₂).functions n) :=
nat.cases_on n h0 (λ n, nat.cases_on n h1 (λ n, nat.cases_on n h2 (λ n, ⟨λ x, pempty.elim x⟩)))

instance subsingleton_mk₂_relations {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  [h1 : subsingleton r₁] [h2 : subsingleton r₂] {n : ℕ} :
  subsingleton ((language.mk₂ c f₁ f₂ r₁ r₂).relations n) :=
nat.cases_on n ⟨λ x, pempty.elim x⟩
  (λ n, nat.cases_on n h1 (λ n, nat.cases_on n h2 (λ n, ⟨λ x, pempty.elim x⟩)))

lemma encodable.countable [h : encodable L.symbols] : L.countable :=
⟨cardinal.encodable_iff.1 ⟨h⟩⟩

@[simp] lemma empty_card : language.empty.card = 0 :=
by simp [card_eq_card_functions_add_card_relations]

instance countable_empty : language.empty.countable :=
⟨by simp⟩

@[priority 100] instance countable.countable_functions [L.countable] : L.countable_functions :=
⟨begin
  refine lift_le_aleph_0.1 (trans _ L.card_le_aleph_0),
  rw [card, symbols, mk_sum],
  exact le_self_add
end⟩

lemma encodable.countable_functions [h : encodable (Σl, L.functions l)] : L.countable_functions :=
⟨cardinal.encodable_iff.1 ⟨h⟩⟩

@[priority 100] instance is_relational.countable_functions [L.is_relational] :
  L.countable_functions :=
encodable.countable_functions

@[simp] lemma card_functions_sum (i : ℕ) :
  #((L.sum L').functions i) = (#(L.functions i)).lift + cardinal.lift.{u} (#(L'.functions i)) :=
by simp [language.sum]

@[simp] lemma card_relations_sum (i : ℕ) :
  #((L.sum L').relations i) = (#(L.relations i)).lift + cardinal.lift.{v} (#(L'.relations i)) :=
by simp [language.sum]

@[simp] lemma card_sum :
  (L.sum L').card = cardinal.lift.{max u' v'} L.card + cardinal.lift.{max u v} L'.card :=
begin
  simp only [card_eq_card_functions_add_card_relations, card_functions_sum, card_relations_sum,
    sum_add_distrib', lift_add, lift_sum, lift_lift],
  rw [add_assoc, ←add_assoc (cardinal.sum (λ i, (# (L'.functions i)).lift)),
    add_comm (cardinal.sum (λ i, (# (L'.functions i)).lift)), add_assoc, add_assoc]
end

@[simp] lemma card_mk₂ (c f₁ f₂ : Type u) (r₁ r₂ : Type v) :
  (language.mk₂ c f₁ f₂ r₁ r₂).card =
    cardinal.lift.{v} (# c) + cardinal.lift.{v} (# f₁) + cardinal.lift.{v} (# f₂)
    + cardinal.lift.{u} (# r₁) + cardinal.lift.{u} (# r₂) :=
by simp [card_eq_card_functions_add_card_relations, add_assoc]

variables (L) (M : Type w)

/-- A first-order structure on a type `M` consists of interpretations of all the symbols in a given
  language. Each function of arity `n` is interpreted as a function sending tuples of length `n`
  (modeled as `(fin n → M)`) to `M`, and a relation of arity `n` is a function from tuples of length
  `n` to `Prop`. -/
@[ext] class Structure :=
(fun_map : ∀{n}, L.functions n → (fin n → M) → M)
(rel_map : ∀{n}, L.relations n → (fin n → M) → Prop)

variables (N : Type w') [L.Structure M] [L.Structure N]

open Structure

/-- Used for defining `first_order.language.Theory.Model.inhabited`. -/
def trivial_unit_structure : L.Structure unit := ⟨default, default⟩

/-! ### Maps -/

/-- A homomorphism between first-order structures is a function that commutes with the
  interpretations of functions and maps tuples in one structure where a given relation is true to
  tuples in the second structure where that relation is still true. -/
structure hom :=
(to_fun : M → N)
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r x → rel_map r (to_fun ∘ x) . obviously)

localized "notation A ` →[`:25 L `] ` B := first_order.language.hom L A B" in first_order

/-- An embedding of first-order structures is an embedding that commutes with the
  interpretations of functions and relations. -/
@[ancestor function.embedding] structure embedding extends M ↪ N :=
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r (to_fun ∘ x) ↔ rel_map r x . obviously)

localized "notation A ` ↪[`:25 L `] ` B := first_order.language.embedding L A B" in first_order

/-- An equivalence of first-order structures is an equivalence that commutes with the
  interpretations of functions and relations. -/
structure equiv extends M ≃ N :=
(map_fun' : ∀{n} (f : L.functions n) x, to_fun (fun_map f x) = fun_map f (to_fun ∘ x) . obviously)
(map_rel' : ∀{n} (r : L.relations n) x, rel_map r (to_fun ∘ x) ↔ rel_map r x . obviously)

localized "notation A ` ≃[`:25 L `] ` B := first_order.language.equiv L A B" in first_order

variables {L M N} {P : Type*} [L.Structure P] {Q : Type*} [L.Structure Q]

instance : has_coe_t L.constants M :=
⟨λ c, fun_map c default⟩

lemma fun_map_eq_coe_constants {c : L.constants} {x : fin 0 → M} :
  fun_map c x = c := congr rfl (funext fin.elim0)

/-- Given a language with a nonempty type of constants, any structure will be nonempty. This cannot
  be a global instance, because `L` becomes a metavariable. -/
lemma nonempty_of_nonempty_constants [h : nonempty L.constants] : nonempty M :=
h.map coe

/-- The function map for `first_order.language.Structure₂`. -/
def fun_map₂ {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  (c' : c → M) (f₁' : f₁ → M → M) (f₂' : f₂ → M → M → M) :
  ∀{n}, (language.mk₂ c f₁ f₂ r₁ r₂).functions n → (fin n → M) → M
| 0 f _ := c' f
| 1 f x := f₁' f (x 0)
| 2 f x := f₂' f (x 0) (x 1)
| (n + 3) f _ := pempty.elim f

/-- The relation map for `first_order.language.Structure₂`. -/
def rel_map₂ {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  (r₁' : r₁ → set M) (r₂' : r₂ → M → M → Prop) :
  ∀{n}, (language.mk₂ c f₁ f₂ r₁ r₂).relations n → (fin n → M) → Prop
| 0 r _ := pempty.elim r
| 1 r x := (x 0) ∈ r₁' r
| 2 r x := r₂' r (x 0) (x 1)
| (n + 3) r _ := pempty.elim r

/-- A structure constructor to match `first_order.language₂`. -/
protected def Structure.mk₂ {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
  (c' : c → M) (f₁' : f₁ → M → M) (f₂' : f₂ → M → M → M)
  (r₁' : r₁ → set M) (r₂' : r₂ → M → M → Prop) :
  (language.mk₂ c f₁ f₂ r₁ r₂).Structure M :=
⟨λ _, fun_map₂ c' f₁' f₂', λ _, rel_map₂ r₁' r₂'⟩

namespace Structure

variables {c f₁ f₂ : Type u} {r₁ r₂ : Type v}
variables {c' : c → M} {f₁' : f₁ → M → M} {f₂' : f₂ → M → M → M}
variables {r₁' : r₁ → set M} {r₂' : r₂ → M → M → Prop}

@[simp] lemma fun_map_apply₀ (c₀ : c) {x : fin 0 → M} :
  @Structure.fun_map _ M (Structure.mk₂ c' f₁' f₂' r₁' r₂') 0 c₀ x = c' c₀ := rfl

@[simp] lemma fun_map_apply₁ (f : f₁) (x : M) :
  @Structure.fun_map _ M (Structure.mk₂ c' f₁' f₂' r₁' r₂') 1 f (![x]) = f₁' f x := rfl

@[simp] lemma fun_map_apply₂ (f : f₂) (x y : M) :
  @Structure.fun_map _ M (Structure.mk₂ c' f₁' f₂' r₁' r₂') 2 f (![x,y]) = f₂' f x y := rfl

@[simp] lemma rel_map_apply₁ (r : r₁) (x : M) :
  @Structure.rel_map _ M (Structure.mk₂ c' f₁' f₂' r₁' r₂') 1 r (![x]) = (x ∈ r₁' r) := rfl

@[simp]

end Structure

/-- `hom_class L F M N` states that `F` is a type of `L`-homomorphisms. You should extend this
  typeclass when you extend `first_order.language.hom`. -/
class hom_class (L : out_param language) (F : Type*)
  (M N : out_param $ Type*) [fun_like F M (λ _, N)] [L.Structure M] [L.Structure N] :=
(map_fun : ∀ (φ : F) {n} (f : L.functions n) x, φ (fun_map f x) = fun_map f (φ ∘ x))
(map_rel : ∀ (φ : F) {n} (r : L.relations n) x, rel_map r x → rel_map r (φ ∘ x))

/-- `strong_hom_class L F M N` states that `F` is a type of `L`-homomorphisms which preserve
  relations in both directions. -/
class strong_hom_class (L : out_param language) (F : Type*) (M N : out_param $ Type*)
  [fun_like F M (λ _, N)] [L.Structure M] [L.Structure N] :=
(map_fun : ∀ (φ : F) {n} (f : L.functions n) x, φ (fun_map f x) = fun_map f (φ ∘ x))
(map_rel : ∀ (φ : F) {n} (r : L.relations n) x, rel_map r (φ ∘ x) ↔ rel_map r x)

@[priority 100] instance strong_hom_class.hom_class
  {F M N} [L.Structure M] [L.Structure N] [fun_like F M (λ _, N)] [strong_hom_class L F M N] :
  hom_class L F M N :=
{ map_fun := strong_hom_class.map_fun,
  map_rel := λ φ n R x, (strong_hom_class.map_rel φ R x).2 }

/-- Not an instance to avoid a loop. -/
def hom_class.strong_hom_class_of_is_algebraic [L.is_algebraic]
  {F M N} [L.Structure M] [L.Structure N] [fun_like F M (λ _, N)] [hom_class L F M N] :
  strong_hom_class L F M N :=
{ map_fun := hom_class.map_fun,
  map_rel := λ φ n R x, (is_algebraic.empty_relations n).elim R }

lemma hom_class.map_constants {F M N} [L.Structure M] [L.Structure N] [fun_like F M (λ _, N)]
  [hom_class L F M N]
  (φ : F) (c : L.constants) : φ (c) = c :=
(hom_class.map_fun φ c default).trans (congr rfl (funext default))

namespace hom

instance fun_like : fun_like (M →[L] N) M (λ _, N) :=
{ coe := hom.to_fun,
  coe_injective' := λ f g h, by {cases f, cases g, cases h, refl} }

instance hom_class : hom_class L (M →[L] N) M N :=
{ map_fun := map_fun',
  map_rel := map_rel' }

instance [L.is_algebraic] : strong_hom_class L (M →[L] N) M N :=
hom_class.strong_hom_class_of_is_algebraic

instance has_coe_to_fun : has_coe_to_fun (M →[L] N) (λ _, M → N) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : M →[L] N} : f.to_fun = (f : M → N) := rfl

@[ext]
lemma ext ⦃f g : M →[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

lemma ext_iff {f g : M →[L] N} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

@[simp] lemma map_fun (φ : M →[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) :=
hom_class.map_fun φ f x

@[simp] lemma map_constants (φ : M →[L] N) (c : L.constants) : φ c = c :=
hom_class.map_constants φ c

@[simp] lemma map_rel (φ : M →[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r x → rel_map r (φ ∘ x) :=
hom_class.map_rel φ r x

variables (L) (M)
/-- The identity map from a structure to itself -/
@[refl] def id : M →[L] M :=
{ to_fun := id }

variables {L} {M}

instance : inhabited (M →[L] M) := ⟨id L M⟩

@[simp] lemma id_apply (x : M) :
  id L M x = x := rfl

/-- Composition of first-order homomorphisms -/
@[trans] def comp (hnp : N →[L] P) (hmn : M →[L] N) : M →[L] P :=
{ to_fun := hnp ∘ hmn,
  map_rel' := λ _ _ _ h, by simp [h] }

@[simp] lemma comp_apply (g : N →[L] P) (f : M →[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order homomorphisms is associative. -/
lemma comp_assoc (f : M →[L] N) (g : N →[L] P) (h : P →[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end hom

/-- Any element of a `hom_class` can be realized as a first_order homomorphism. -/
def hom_class.to_hom {F M N} [L.Structure M] [L.Structure N]
  [fun_like F M (λ _, N)] [hom_class L F M N] :
  F → (M →[L] N) :=
λ φ, ⟨φ, λ _, hom_class.map_fun φ, λ _, hom_class.map_rel φ⟩

namespace embedding

instance embedding_like : embedding_like (M ↪[L] N) M N :=
{ coe := λ f, f.to_fun,
  injective' := λ f, f.to_embedding.injective,
  coe_injective' := λ f g h, begin
    cases f,
    cases g,
    simp only,
    ext x,
    exact function.funext_iff.1 h x end }

instance strong_hom_class : strong_hom_class L (M ↪[L] N) M N :=
{ map_fun := map_fun',
  map_rel := map_rel' }

instance has_coe_to_fun : has_coe_to_fun (M ↪[L] N) (λ _, M → N) :=
fun_like.has_coe_to_fun

@[simp] lemma map_fun (φ : M ↪[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) :=
hom_class.map_fun φ f x

@[simp] lemma map_constants (φ : M ↪[L] N) (c : L.constants) : φ c = c :=
hom_class.map_constants φ c

@[simp] lemma map_rel (φ : M ↪[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x :=
strong_hom_class.map_rel φ r x

/-- A first-order embedding is also a first-order homomorphism. -/
def to_hom : (M ↪[L] N) → M →[L] N := hom_class.to_hom

@[simp]
lemma coe_to_hom {f : M ↪[L] N} : (f.to_hom : M → N) = f := rfl

lemma coe_injective : @function.injective (M ↪[L] N) (M → N) coe_fn
| f g h :=
begin
  cases f,
  cases g,
  simp only,
  ext x,
  exact function.funext_iff.1 h x,
end

@[ext]
lemma ext ⦃f g : M ↪[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

lemma ext_iff {f g : M ↪[L] N} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

lemma injective (f : M ↪[L] N) : function.injective f := f.to_embedding.injective

/-- In an algebraic language, any injective homomorphism is an embedding. -/
@[simps] def of_injective [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) : M ↪[L] N :=
{ inj' := hf,
  map_rel' := λ n r x, strong_hom_class.map_rel f r x,
  .. f }

@[simp] lemma coe_fn_of_injective [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) :
  (of_injective hf : M → N) = f := rfl

@[simp] lemma of_injective_to_hom [L.is_algebraic] {f : M →[L] N} (hf : function.injective f) :
  (of_injective hf).to_hom = f :=
by { ext, simp }

variables (L) (M)
/-- The identity embedding from a structure to itself -/
@[refl] def refl : M ↪[L] M :=
{ to_embedding := function.embedding.refl M }

variables {L} {M}

instance : inhabited (M ↪[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of first-order embeddings -/
@[trans] def comp (hnp : N ↪[L] P) (hmn : M ↪[L] N) : M ↪[L] P :=
{ to_fun := hnp ∘ hmn,
  inj' := hnp.injective.comp hmn.injective }

@[simp] lemma comp_apply (g : N ↪[L] P) (f : M ↪[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order embeddings is associative. -/
lemma comp_assoc (f : M ↪[L] N) (g : N ↪[L] P) (h : P ↪[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

@[simp] lemma comp_to_hom (hnp : N ↪[L] P) (hmn : M ↪[L] N) :
  (hnp.comp hmn).to_hom = hnp.to_hom.comp hmn.to_hom :=
by { ext, simp only [coe_to_hom, comp_apply, hom.comp_apply] }

end embedding

/-- Any element of an injective `strong_hom_class` can be realized as a first_order embedding. -/
def strong_hom_class.to_embedding {F M N} [L.Structure M] [L.Structure N]
  [embedding_like F M N] [strong_hom_class L F M N] :
  F → (M ↪[L] N) :=
λ φ, ⟨⟨φ, embedding_like.injective φ⟩,
  λ _, strong_hom_class.map_fun φ, λ _, strong_hom_class.map_rel φ⟩

namespace equiv

instance : equiv_like (M ≃[L] N) M N :=
{ coe := λ f, f.to_fun,
  inv := λ f, f.inv_fun,
  left_inv := λ f, f.left_inv,
  right_inv := λ f, f.right_inv,
  coe_injective' := λ f g h₁ h₂, begin
    cases f,
    cases g,
    simp only,
    ext x,
    exact function.funext_iff.1 h₁ x,
  end, }

instance : strong_hom_class L (M ≃[L] N) M N :=
{ map_fun := map_fun',
  map_rel := map_rel', }

/-- The inverse of a first-order equivalence is a first-order equivalence. -/
@[symm] def symm (f : M ≃[L] N) : N ≃[L] M :=
{ map_fun' := λ n f' x, begin
    simp only [equiv.to_fun_as_coe],
    rw [equiv.symm_apply_eq],
    refine eq.trans _ (f.map_fun' f' (f.to_equiv.symm ∘ x)).symm,
    rw [← function.comp.assoc, equiv.to_fun_as_coe, equiv.self_comp_symm, function.comp.left_id]
  end,
  map_rel' := λ n r x, begin
    simp only [equiv.to_fun_as_coe],
    refine (f.map_rel' r (f.to_equiv.symm ∘ x)).symm.trans _,
    rw [← function.comp.assoc, equiv.to_fun_as_coe, equiv.self_comp_symm, function.comp.left_id]
  end,
  .. f.to_equiv.symm }

instance has_coe_to_fun : has_coe_to_fun (M ≃[L] N) (λ _, M → N) :=
fun_like.has_coe_to_fun

@[simp]
lemma apply_symm_apply (f : M ≃[L] N) (a : N) : f (f.symm a) = a := f.to_equiv.apply_symm_apply a

@[simp]
lemma symm_apply_apply (f : M ≃[L] N) (a : M) : f.symm (f a) = a := f.to_equiv.symm_apply_apply a

@[simp] lemma map_fun (φ : M ≃[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) :=
hom_class.map_fun φ f x

@[simp] lemma map_constants (φ : M ≃[L] N) (c : L.constants) : φ c = c :=
hom_class.map_constants φ c

@[simp] lemma map_rel (φ : M ≃[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x :=
strong_hom_class.map_rel φ r x

/-- A first-order equivalence is also a first-order embedding. -/
def to_embedding : (M ≃[L] N) → M ↪[L] N := strong_hom_class.to_embedding

/-- A first-order equivalence is also a first-order homomorphism. -/
def to_hom : (M ≃[L] N) → M →[L] N := hom_class.to_hom

@[simp] lemma to_embedding_to_hom (f : M ≃[L] N) : f.to_embedding.to_hom = f.to_hom := rfl

@[simp]
lemma coe_to_hom {f : M ≃[L] N} : (f.to_hom : M → N) = (f : M → N) := rfl

@[simp] lemma coe_to_embedding (f : M ≃[L] N) : (f.to_embedding : M → N) = (f : M → N) := rfl

lemma coe_injective : @function.injective (M ≃[L] N) (M → N) coe_fn :=
fun_like.coe_injective

@[ext]
lemma ext ⦃f g : M ≃[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

lemma ext_iff {f g : M ≃[L] N} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

lemma bijective (f : M ≃[L] N) : function.bijective f := equiv_like.bijective f

lemma injective (f : M ≃[L] N) : function.injective f := equiv_like.injective f

lemma surjective (f : M ≃[L] N) : function.surjective f := equiv_like.surjective f

variables (L) (M)
/-- The identity equivalence from a structure to itself -/
@[refl] def refl : M ≃[L] M :=
{ to_equiv := equiv.refl M }

variables {L} {M}

instance : inhabited (M ≃[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of first-order equivalences -/
@[trans] def comp (hnp : N ≃[L] P) (hmn : M ≃[L] N) : M ≃[L] P :=
{ to_fun := hnp ∘ hmn,
  .. (hmn.to_equiv.trans hnp.to_equiv) }

@[simp] lemma comp_apply (g : N ≃[L] P) (f : M ≃[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of first-order homomorphisms is associative. -/
lemma comp_assoc (f : M ≃[L] N) (g : N ≃[L] P) (h : P ≃[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end equiv

/-- Any element of a bijective `strong_hom_class` can be realized as a first_order isomorphism. -/
def strong_hom_class.to_equiv {F M N} [L.Structure M] [L.Structure N]
  [equiv_like F M N] [strong_hom_class L F M N] :
  F → (M ≃[L] N) :=
λ φ, ⟨⟨φ, equiv_like.inv φ, equiv_like.left_inv φ, equiv_like.right_inv φ⟩,
  λ _, hom_class.map_fun φ, λ _, strong_hom_class.map_rel φ⟩

section sum_Structure
variables (L₁ L₂ : language) (S : Type*) [L₁.Structure S] [L₂.Structure S]

instance sum_Structure :
  (L₁.sum L₂).Structure S :=
{ fun_map := λ n, sum.elim fun_map fun_map,
  rel_map := λ n, sum.elim rel_map rel_map, }

variables {L₁ L₂ S}

@[simp] lemma fun_map_sum_inl {n : ℕ} (f : L₁.functions n) :
  @fun_map (L₁.sum L₂) S _ n (sum.inl f) = fun_map f := rfl

@[simp] lemma fun_map_sum_inr {n : ℕ} (f : L₂.functions n) :
  @fun_map (L₁.sum L₂) S _ n (sum.inr f) = fun_map f := rfl

@[simp] lemma rel_map_sum_inl {n : ℕ} (R : L₁.relations n) :
  @rel_map (L₁.sum L₂) S _ n (sum.inl R) = rel_map R := rfl

@[simp] lemma rel_map_sum_inr {n : ℕ} (R : L₂.relations n) :
  @rel_map (L₁.sum L₂) S _ n (sum.inr R) = rel_map R := rfl

end sum_Structure

section empty
section
variables [language.empty.Structure M] [language.empty.Structure N]

@[simp] lemma empty.nonempty_embedding_iff :
  nonempty (M ↪[language.empty] N) ↔ cardinal.lift.{w'} (# M) ≤ cardinal.lift.{w} (# N) :=
trans ⟨nonempty.map (λ f, f.to_embedding), nonempty.map (λ f, {to_embedding := f})⟩
  cardinal.lift_mk_le'.symm

@[simp] lemma empty.nonempty_equiv_iff :
  nonempty (M ≃[language.empty] N) ↔ cardinal.lift.{w'} (# M) = cardinal.lift.{w} (# N) :=
trans ⟨nonempty.map (λ f, f.to_equiv), nonempty.map (λ f, {to_equiv := f})⟩
  cardinal.lift_mk_eq'.symm

end

instance empty_Structure : language.empty.Structure M :=
⟨λ _, empty.elim, λ _, empty.elim⟩

instance : unique (language.empty.Structure M) :=
⟨⟨language.empty_Structure⟩, λ a, begin
  ext n f,
  { exact empty.elim f },
  { exact subsingleton.elim _ _ },
end⟩

@[priority 100] instance strong_hom_class_empty {F M N} [fun_like F M (λ _, N)] :
  strong_hom_class language.empty F M N :=
⟨λ _ _ f, empty.elim f, λ _ _ r, empty.elim r⟩

/-- Makes a `language.empty.hom` out of any function. -/
@[simps] def _root_.function.empty_hom (f : M → N) : (M →[language.empty] N) :=
{ to_fun := f }

/-- Makes a `language.empty.embedding` out of any function. -/
@[simps] def _root_.embedding.empty (f : M ↪ N) : (M ↪[language.empty] N) :=
{ to_embedding := f }

/-- Makes a `language.empty.equiv` out of any function. -/
@[simps] def _root_.equiv.empty (f : M ≃ N) : (M ≃[language.empty] N) :=
{ to_equiv := f }

end empty

end language
end first_order

namespace equiv
open first_order first_order.language first_order.language.Structure
open_locale first_order

variables {L : language} {M : Type*} {N : Type*} [L.Structure M]

/-- A structure induced by a bijection. -/
@[simps] def induced_Structure (e : M ≃ N) : L.Structure N :=
⟨λ n f x, e (fun_map f (e.symm ∘ x)), λ n r x, rel_map r (e.symm ∘ x)⟩

/-- A bijection as a first-order isomorphism with the induced structure on the codomain. -/
@[simps] def induced_Structure_equiv (e : M ≃ N) :
  @language.equiv L M N _ (induced_Structure e) :=
{ map_fun' := λ n f x, by simp [← function.comp.assoc e.symm e x],
  map_rel' := λ n r x, by simp [← function.comp.assoc e.symm e x],
  .. e }

end equiv


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

Coherence conditions for operations on pathovers
-/

import ..init
universe u
hott_theory

namespace hott

open function equiv

namespace eq

  variables {A : Type _} {A' : Type _} {A'' : Type _} {B : A → Type _} {B' : A → Type _} {B'' : A' → Type _}
            {C : Π⦃a⦄, B a → Type _}
            {a a₂ a₃ a₄ : A} {p p' p'' : a = a₂} {p₂ p₂' : a₂ = a₃} {p₃ : a₃ = a₄} {p₁₃ : a = a₃}
            {a' : A'}
            {b b' : B a} {b₂ b₂' : B a₂} {b₃ : B a₃} {b₄ : B a₄}
            {c : C b} {c₂ : C b₂}

  @[hott] def pathover_ap_id (q : b =[p] b₂) : pathover_ap B id q = change_path (ap_id p)⁻¹ q :=
  by induction q; reflexivity

  @[hott] def pathover_ap_compose (B : A'' → Type _) (g : A' → A'') (f : A → A')
    {b : B (g (f a))} {b₂ : B (g (f a₂))} (q : b =[p; λa, B (g (f a))] b₂) : pathover_ap B (g ∘ f) q
      = change_path (ap_compose g f p)⁻¹ (pathover_ap B g (pathover_ap (B ∘ g) f q)) :=
  by induction q; reflexivity

  @[hott] def pathover_ap_compose_rev (B : A'' → Type _) (g : A' → A'') (f : A → A')
    {b : B (g (f a))} {b₂ : B (g (f a₂))} (q : b =[p; λa, B (g (f a))] b₂) :
    pathover_ap B g (pathover_ap (B ∘ g) f q)
      = change_path (ap_compose g f p) (pathover_ap B (g ∘ f) q) :=
  by induction q; reflexivity

  @[hott, hsimp] def pathover_of_tr_eq_idp (r : b = b') :
    @pathover_of_tr_eq _ _ _ _ idp _ _ r = pathover_idp_of_eq B r :=
  idp

  @[hott] def pathover_of_tr_eq_eq_concato (r : p ▸ b = b₂)
    : pathover_of_tr_eq r = pathover_tr p b ⬝o pathover_idp_of_eq B r :=
  by induction r; induction p; reflexivity

  @[hott] def apd011_eq_apo11_apd (f : Πa, B a → A') (p : a = a₂) (q : b =[p] b₂)
      : apd011 f p q = apo11_constant_right (apd f p) q :=
  by induction q; reflexivity

  @[hott] def change_path_con (q : p = p') (q' : p' = p'') (r : b =[p] b₂) :
    change_path (q ⬝ q') r = change_path q' (change_path q r) :=
  by induction q; induction q'; reflexivity

  @[hott] def change_path_invo (q : p = p') (r : b =[p] b₂) :
    change_path (inverse2 q) r⁻¹ᵒ = (change_path q r)⁻¹ᵒ :=
  by induction q; reflexivity

  @[hott] def change_path_cono (q : p = p') (q₂ : p₂ = p₂') (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃):
    change_path (q ◾ q₂) (r ⬝o r₂) = change_path q r ⬝o change_path q₂ r₂ :=
  by induction q; induction q₂; reflexivity

  @[hott] def pathover_of_pathover_ap_invo (B' : A' → Type _) (f : A → A')
    {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[ap f p] b₂) :
    pathover_of_pathover_ap B' f (change_path (ap_inv f p)⁻¹ q⁻¹ᵒ) =
      (pathover_of_pathover_ap B' f q)⁻¹ᵒ:=
  by induction p; eapply idp_rec_on q; reflexivity

  @[hott] def pathover_of_pathover_ap_cono (B' : A' → Type _) (f : A → A')
    {b : B' (f a)} {b₂ : B' (f a₂)} {b₃ : B' (f a₃)} (q : b =[ap f p] b₂) (q₂ : b₂ =[ap f p₂] b₃) :
    pathover_of_pathover_ap B' f (change_path (ap_con f p p₂)⁻¹ (q ⬝o q₂)) =
      pathover_of_pathover_ap B' f q ⬝o pathover_of_pathover_ap B' f q₂ :=
  begin induction p₂, apply idp_rec_on q₂, refl end

  @[hott] def pathover_ap_pathover_of_pathover_ap (P : A'' → Type _) (g : A' → A'') (f : A → A')
    {p : a = a₂} {b : P (g (f a))} {b₂ : P (g (f a₂))} (q : b =[ap f p; P ∘ g] b₂) :
    pathover_ap P (g ∘ f) ((pathover_of_pathover_ap (P ∘ g) f q) : b =[p; (P ∘ g) ∘ f] b₂) =
    change_path (ap_compose g f p)⁻¹ (pathover_ap P g q) :=
  by induction p; eapply (idp_rec_on q); reflexivity

  @[hott] def change_path_pathover_of_pathover_ap (B' : A' → Type _) (f : A → A') {p p' : a = a₂}
    (r : p = p') {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[ap f p] b₂) :
    change_path r (pathover_of_pathover_ap B' f q) =
      pathover_of_pathover_ap B' f (change_path (ap02 f r) q) :=
  by induction r; reflexivity

  @[hott] def pathover_ap_change_path (B' : A' → Type _) (f : A → A') {p p' : a = a₂}
    (r : p = p') {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[p; B' ∘ f] b₂) :
    pathover_ap B' f (change_path r q) = change_path (ap02 f r) (pathover_ap B' f q) :=
  by induction r; reflexivity

  @[hott] def change_path_equiv (b : B a) (b₂ : B a₂) (q : p = p')
    : (b =[p] b₂) ≃ (b =[p'] b₂) :=
  begin
    fapply equiv.MK,
    { exact change_path q},
    { exact change_path q⁻¹},
    { intro r, induction q, reflexivity},
    { intro r, induction q, reflexivity},
  end

  @[hott] def apd_ap {B : A' → Type _} (g : Πb, B b) (f : A → A') (p : a = a₂)
    :  apd g (ap f p) = pathover_ap B f (apd (λx, g (f x)) p)  :=
  by induction p; reflexivity

  @[hott] def apd_eq_apd_ap {B : A' → Type _} (g : Πb, B b) (f : A → A') (p : a = a₂)
    : apd (λx, g (f x)) p = pathover_of_pathover_ap B f (apd g (ap f p)) :=
  by induction p; reflexivity

  @[hott] def ap_compose_ap02_constant {A B C : Type _} {a a' : A} (p : a = a') (b : B) (c : C) :
  ap_compose (λc, b) (λa, c) p ⬝ ap02 (λc, b) (ap_constant p c) = ap_constant p b :=
  by induction p; reflexivity

  @[hott] def pathover_ap_pathover_of_eq (p : a₂ = a₃) (q : b = b') :
    pathover_ap B (λa', a) (pathover_of_eq p q) = change_path (ap_constant p a)⁻¹ (pathover_idp_of_eq B q) :=
  by induction p; induction q; refl

  @[hott] theorem apd_constant (b : B'' a') (p : a = a₂) :
    pathover_ap B'' (λa, a') (apd (λa, b) p) = change_path (ap_constant p a')⁻¹ idpo :=
  by induction p; reflexivity

  @[hott] theorem apd_constant' {A A' : Type _} {B : A' → Type _} {a₁ a₂ : A} {a' : A'} (b : B a')
    (p : a₁ = a₂) : apd (λx, b) p = pathover_of_eq p idp :=
  by induction p; reflexivity

  @[hott] def apd_change_path {B : A → Type _} {a a₂ : A} (f : Πa, B a) {p p' : a = a₂} (s : p = p')
    : apd f p' = change_path s (apd f p) :=
  by induction s; reflexivity

  @[hott] def cono_invo_eq_idpo {q q' : b =[p] b₂} (r : q = q')
    : change_path (con.right_inv p) (q ⬝o q'⁻¹ᵒ) = idpo :=
  by induction r; induction q; reflexivity

  @[hott] def tr_eq_of_pathover_concato_eq {A : Type _} {B : A → Type _} {a a' : A} {p : a = a'}
    {b : B a} {b' b'' : B a'} (q : b =[p] b') (r : b' = b'') :
    tr_eq_of_pathover (q ⬝op r) = tr_eq_of_pathover q ⬝ r :=
  by induction r; reflexivity

end eq
end hott


/-
Copyright (c) 2014 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
(Ported from standard library)
Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad

Basic operations on the natural numbers.
-/
import hott.algebra.ring
universes u v w
hott_theory
namespace hott
open eq hott.algebra is_trunc nat unit hott.decidable hott.binary

namespace nat

-- /- a variant of add, defined by recursion on the first argument -/

-- @[hott] def addl (x y : ℕ) : ℕ :=
-- nat.rec_on x y (λ n r, succ r)
-- infix ` ⊕ ` := addl

-- @[hott] theorem addl_succ_right (n m : ℕ) : n ⊕ succ m = succ (n ⊕ m) :=
-- nat.rec_on n
--   rfl
--   (λ n₁ ih, calc
--     succ n₁ ⊕ succ m = succ (n₁ ⊕ succ m)   : rfl
--              ...     = succ (succ (n₁ ⊕ m)) : ih
--              ...     = succ (succ n₁ ⊕ m)   : rfl)

-- @[hott] theorem add_eq_addl (x : ℕ) : Πy, x + y = x ⊕ y :=
-- nat.rec_on x
--   (λ y, nat.rec_on y
--     rfl
--     (λ y₁ ih, calc
--       0 + succ y₁ = succ (0 + y₁)  : rfl
--            ...    = succ (0 ⊕ y₁) : {ih}
--            ...    = 0 ⊕ (succ y₁) : rfl))
--   (λ x₁ ih₁ y, nat.rec_on y
--     (calc
--       succ x₁ + 0  = succ (x₁ + 0)  : rfl
--                ... = succ (x₁ ⊕ 0) : {ih₁ 0}
--                ... = succ x₁ ⊕ 0   : rfl)
--     (λ y₁ ih₂, calc
--       succ x₁ + succ y₁ = succ (succ x₁ + y₁) : rfl
--                    ...  = succ (succ x₁ ⊕ y₁) : {ih₂}
--                    ...  = succ x₁ ⊕ succ y₁   : addl_succ_right))

/- successor and predecessor -/

@[hott, reducible] protected def code : ℕ → ℕ → Type
| 0        0        := unit
| 0        (succ m) := empty
| (succ n) 0        := empty
| (succ n) (succ m) := code n m

@[hott] protected def refl : Πn, nat.code n n
| 0        := star
| (succ n) := refl n

@[hott] protected def encode {n m : ℕ} (p : n = m) : nat.code n m :=
p ▸ nat.refl n

@[hott] protected def decode : Π(n m : ℕ), nat.code n m → n = m
| 0        0        := λc, idp
| 0        (succ l) := λc, empty.elim c
| (succ k) 0        := λc, empty.elim c
| (succ k) (succ l) := λc, ap succ (decode k l c)

@[hott] def succ_ne_zero (n : ℕ) : succ n ≠ 0 :=
nat.encode

@[hott, hsimp] def pred_zero : pred 0 = 0 :=
rfl

@[hott, hsimp] def pred_succ (n : ℕ) : pred (succ n) = n :=
rfl

@[hott, hsimp] theorem sub_one (n : ℕ) : n - 1 = pred n :=
rfl

@[hott] theorem eq_zero_sum_eq_succ_pred (n : ℕ) : n = 0 ⊎ n = succ (pred n) :=
begin
  hinduction n with n IH,
  { exact sum.inl rfl },
  { exact sum.inr rfl }
end

@[hott] theorem exists_eq_succ_of_ne_zero {n : ℕ} (H : n ≠ 0) : Σk : ℕ, n = succ k :=
sigma.mk (pred n) (sum.resolve_left (eq_zero_sum_eq_succ_pred n) H)

@[hott] def succ.inj {n m : ℕ} (H : succ n = succ m) : n = m :=
nat.decode n m (@nat.encode (succ n) (succ m) H)

@[hott] theorem eq_of_succ_eq_succ {n m : ℕ} (H : succ n = succ m) : n = m := succ.inj H

@[hott] theorem succ_ne_self {n : ℕ} : succ n ≠ n :=
begin
  induction n with n IH,
  { apply succ_ne_zero },
  { intro H, apply IH, apply succ.inj, exact H }
end

@[hott, instance, priority nat.prio] protected def has_decidable_eq : Π x y : nat, decidable (x = y)
| 0        0        := inl rfl
| (succ x) 0        := inr (succ_ne_zero x)
| 0        (succ y) := inr (ne.symm (succ_ne_zero y))
| (succ x) (succ y) :=
    match has_decidable_eq x y with
    | inl xeqy := inl (ap succ xeqy)
    | inr xney := inr (λH, xney (succ.inj H))
    end

@[hott] theorem discriminate {B : Type _} {n : ℕ} (H1: n = 0 → B) (H2 : Πm, n = succ m → B) : B :=
have H : n = n → B, begin induction n with n IH, exact H1, apply H2 end,
H rfl

@[hott] theorem two_step_rec_on {P : ℕ → Type _} (a : ℕ) (H1 : P 0) (H2 : P 1)
    (H3 : Π (n : ℕ) (IH1 : P n) (IH2 : P (succ n)), P (succ (succ n))) : P a :=
have stronger : P a × P (succ a), from
  nat.rec_on a
    (pair H1 H2)
    (λk IH,
      have IH1 : P k, from IH.fst,
      have IH2 : P (succ k), from IH.snd,
        pair IH2 (H3 k IH1 IH2)),
  stronger.fst

@[hott, elab_as_eliminator] theorem sub_induction {P : ℕ → ℕ → Type _} (n m : ℕ) (H1 : Πm, P 0 m)
   (H2 : Πn, P (succ n) 0) (H3 : Πn m, P n m → P (succ n) (succ m)) : P n m :=
have general : Πm, P n m, from nat.rec_on n H1
  (λk : ℕ,
    assume IH : Πm, P k m,
    λm : ℕ,
    nat.cases_on m (H2 k) (λl, (H3 k l (IH l)))),
general m

/- addition -/

@[hott, hsimp] protected def add_zero (n : ℕ) : n + 0 = n :=
rfl

@[hott, hsimp] def add_succ (n m : ℕ) : n + succ m = succ (n + m) :=
rfl

@[hott, hsimp] protected def zero_add (n : ℕ) : 0 + n = n :=
begin
  induction n with n IH,
    reflexivity,
    exact ap succ IH
end

@[hott, hsimp] def succ_add (n m : ℕ) : (succ n) + m = succ (n + m) :=
begin
  induction m with m IH,
    reflexivity,
    exact ap succ IH
end

@[hott, hsimp] protected def add_comm (n m : ℕ) : n + m = m + n :=
begin
  induction n with n IH,
  { apply nat.zero_add},
  { exact succ_add n m ⬝ ap succ IH}
end

@[hott] protected def add_add (n l k : ℕ) : n + l + k = n + (k + l) :=
begin
  induction l with l IH,
    reflexivity,
    exact succ_add (n + l) k ⬝ ap succ IH
end

@[hott] def succ_add_eq_succ_add (n m : ℕ) : succ n + m = n + succ m :=
succ_add n m

@[hott, hsimp] protected def add_assoc (n m k : ℕ) : (n + m) + k = n + (m + k) :=
begin
  induction k with k IH,
    reflexivity,
    exact ap succ IH
end

@[hott] protected theorem add_left_comm : Π (n m k : ℕ), n + (m + k) = m + (n + k) :=
left_comm nat.add_comm nat.add_assoc

@[hott] protected theorem add_right_comm : Π (n m k : ℕ), n + m + k = n + k + m :=
right_comm nat.add_comm nat.add_assoc

@[hott] protected def add_left_cancel {n m k : ℕ} : n + m = n + k → m = k :=
nat.rec_on n
  (λH : 0 + m = 0 + k,
    (nat.zero_add _)⁻¹ ⬝ H ⬝ nat.zero_add _)
  (λ(n : ℕ) (IH : n + m = n + k → m = k) (H : succ n + m = succ n + k),
    have succ (n + m) = succ (n + k),
    from calc
      succ (n + m) = succ n + m   : by rwr succ_add
               ... = succ n + k   : H
               ... = succ (n + k) : by rwr succ_add,
    have n + m = n + k, from succ.inj this,
    IH this)

@[hott] protected def add_right_cancel {n m k : ℕ} (H : n + m = k + m) : n = k :=
have H2 : m + n = m + k, from nat.add_comm _ _ ⬝ H ⬝ nat.add_comm _ _,
  nat.add_left_cancel H2

@[hott] theorem eq_zero_of_add_eq_zero_right {n m : ℕ} : n + m = 0 → n = 0 :=
nat.rec_on n
  (λ(H : 0 + m = 0), rfl)
  (λk IH,
    assume H : succ k + m = 0,
    absurd
      (show succ (k + m) = 0, from calc
         succ (k + m) = succ k + m : by rwr succ_add
                  ... = 0          : H)
      (succ_ne_zero _))

@[hott] theorem eq_zero_of_add_eq_zero_left {n m : ℕ} (H : n + m = 0) : m = 0 :=
eq_zero_of_add_eq_zero_right (nat.add_comm _ _ ⬝ H)

@[hott] theorem eq_zero_prod_eq_zero_of_add_eq_zero {n m : ℕ} (H : n + m = 0) : n = 0 × m = 0 :=
pair (eq_zero_of_add_eq_zero_right H) (eq_zero_of_add_eq_zero_left H)

@[hott, hsimp] theorem add_one (n : ℕ) : n + 1 = succ n := rfl

@[hott] theorem one_add (n : ℕ) : 1 + n = succ n :=
succ_add 0 n ⬝ ap succ (nat.zero_add n)

/- multiplication -/

@[hott, hsimp] protected def mul_zero (n : ℕ) : n * 0 = 0 :=
rfl

@[hott, hsimp] def mul_succ (n m : ℕ) : n * succ m = n * m + n :=
rfl

-- commutativity, distributivity, associativity, identity

@[hott, hsimp] protected def zero_mul (n : ℕ) : 0 * n = 0 :=
begin induction n with n IH, refl, exact IH end

@[hott, hsimp] def succ_mul (n m : ℕ) : succ n * m = n * m + m :=
begin
  hinduction m with m IH,
  { refl },
  { rwr [mul_succ, IH, add_succ, nat.add_assoc, nat.add_comm m n, ←nat.add_assoc] }
end

@[hott, hsimp] protected def mul_comm (n m : ℕ) : n * m = m * n :=
begin
  hinduction m with m IH,
  { rwr [nat.zero_mul] },
  { rwr [mul_succ, succ_mul, IH] }
end

@[hott] protected def right_distrib (n m k : ℕ) : (n + m) * k = n * k + m * k :=
begin
  hinduction k with k IH,
  { refl },
  { rwr [mul_succ, IH, nat.add_assoc (n*k), ←nat.add_assoc (m*k), nat.add_comm (m*k),
         nat.add_assoc n, ←nat.add_assoc (n*k)] }
end

@[hott] protected def left_distrib (n m k : ℕ) : n * (m + k) = n * m + n * k :=
calc
  n * (m + k) = (m + k) * n    : by rwr nat.mul_comm
          ... = m * n + k * n  : by rwr nat.right_distrib
          ... = n * m + k * n  : by rwr nat.mul_comm
          ... = n * m + n * k  : by rwr nat.mul_comm k n

@[hott, hsimp] protected def mul_assoc (n m k : ℕ) : (n * m) * k = n * (m * k) :=
begin
  hinduction k with k IH,
  { refl },
  { rwr [mul_succ, IH, ←nat.left_distrib] }
end

@[hott, hsimp] protected def mul_one (n : ℕ) : n * 1 = n :=
calc
  n * 1 = n * 0 + n : by rwr mul_succ
    ... = 0 + n     : by rwr nat.mul_zero
    ... = n         : by rwr nat.zero_add

@[hott, hsimp] protected def one_mul (n : ℕ) : 1 * n = n :=
calc
  1 * n = n * 1 : by rwr nat.mul_comm
    ... = n     : by rwr nat.mul_one

@[hott] theorem eq_zero_sum_eq_zero_of_mul_eq_zero {n m : ℕ} : n * m = 0 → n = 0 ⊎ m = 0 :=
begin
  intro H, hinduction n with n IH, { exact sum.inl rfl },
  induction m with m IH, { exact sum.inr rfl },
  apply empty.elim, exact succ_ne_zero _ H
end

@[hott, instance] protected def comm_semiring : hott.algebra.comm_semiring nat :=
{ add            := nat.add,
  add_assoc      := nat.add_assoc,
  zero           := nat.zero,
  zero_add       := nat.zero_add,
  add_zero       := nat.add_zero,
  add_comm       := nat.add_comm,
  mul            := nat.mul,
  mul_assoc      := nat.mul_assoc,
  one            := nat.succ nat.zero,
  one_mul        := nat.one_mul,
  mul_one        := nat.mul_one,
  left_distrib   := nat.left_distrib,
  right_distrib  := nat.right_distrib,
  zero_mul       := nat.zero_mul,
  mul_zero       := nat.mul_zero,
  mul_comm       := nat.mul_comm,
  is_set_carrier := by apply_instance }
end nat

section
open nat
@[hott] def iterate {A : Type _} (op : A → A) : ℕ → A → A
 | 0 := λ a, a
 | (succ k) := λ a, op (iterate k a)

notation f `^[`:80 n:0 `]`:0 := iterate f n
end
end hott


import category_theory.limits.shapes.pullbacks

/-!
Thanks to Markus Himmel for suggesting this question.
-/

open category_theory
open category_theory.limits

/-!
Let C be a category, X and Y be objects and f : X ⟶ Y be a morphism. Show that f is an epimorphism
if and only if the diagram

X --f--→ Y
|        |
f        𝟙
|        |
↓        ↓
Y --𝟙--→ Y

is a pushout.
-/

variables {C : Type*} [category C]

def pushout_of_epi {X Y : C} (f : X ⟶ Y) [epi f] :
  is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f) :=
-- Hint: you can start a proof with `fapply pushout_cocone.is_colimit.mk`
-- to save a little bit of work over just building a `is_colimit` structure directly.
-- sorry
begin
  fapply pushout_cocone.is_colimit.mk,
  { intro s,
    apply s.ι.app walking_span.left, },
  { tidy, },
  { tidy,
    apply (cancel_epi f).1,
    have fst := s.ι.naturality walking_span.hom.fst,
    simp at fst,
    rw fst,
    have snd := s.ι.naturality walking_span.hom.snd,
    simp at snd,
    rw snd, },
  { tidy, }
end
-- sorry

theorem epi_of_pushout {X Y : C} (f : X ⟶ Y)
  (is_colim : is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f)) : epi f :=
-- Hint: You can use `pushout_cocone.mk` to conveniently construct a cocone over a cospan.
-- Hint: use `is_colim.desc` to construct the map from a colimit cocone to any other cocone.
-- Hint: use `is_colim.fac` to show that this map gives a factorisation of the cocone maps through the colimit cocone.
-- Hint: if `simp` won't correctly simplify `𝟙 X ≫ f`, try `dsimp, simp`.
-- sorry
{ left_cancellation := λ Z g h hf,
  begin
    let a := pushout_cocone.mk _ _ hf,
    have hg : is_colim.desc a = g, {
      convert is_colim.fac a walking_span.left,
      simp, dsimp, simp,
    },
    have hh : is_colim.desc a = h, {
      convert is_colim.fac a walking_span.right,
      simp, dsimp, simp,
    },
    rw [←hg, ←hh],
  end }
-- sorry

/-!
There are some further hints in
`hints/category_theory/exercise6/`
-/


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import data.prod.basic
import data.subtype
import logic.function.basic
import logic.unique

/-!
# Nontrivial types

A type is *nontrivial* if it contains at least two elements. This is useful in particular for rings
(where it is equivalent to the fact that zero is different from one) and for vector spaces
(where it is equivalent to the fact that the dimension is positive).

We introduce a typeclass `nontrivial` formalizing this property.
-/

variables {α : Type*} {β : Type*}

open_locale classical

/-- Predicate typeclass for expressing that a type is not reduced to a single element. In rings,
this is equivalent to `0 ≠ 1`. In vector spaces, this is equivalent to positive dimension. -/
class nontrivial (α : Type*) : Prop :=
(exists_pair_ne : ∃ (x y : α), x ≠ y)

lemma nontrivial_iff : nontrivial α ↔ ∃ (x y : α), x ≠ y :=
⟨λ h, h.exists_pair_ne, λ h, ⟨h⟩⟩

lemma exists_pair_ne (α : Type*) [nontrivial α] : ∃ (x y : α), x ≠ y :=
nontrivial.exists_pair_ne

-- See Note [decidable namespace]
protected lemma decidable.exists_ne [nontrivial α] [decidable_eq α] (x : α) : ∃ y, y ≠ x :=
begin
  rcases exists_pair_ne α with ⟨y, y', h⟩,
  by_cases hx : x = y,
  { rw ← hx at h,
    exact ⟨y', h.symm⟩ },
  { exact ⟨y, ne.symm hx⟩ }
end

lemma exists_ne [nontrivial α] (x : α) : ∃ y, y ≠ x :=
by classical; exact decidable.exists_ne x

-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
lemma nontrivial_of_ne (x y : α) (h : x ≠ y) : nontrivial α :=
⟨⟨x, y, h⟩⟩

-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
lemma nontrivial_of_lt [preorder α] (x y : α) (h : x < y) : nontrivial α :=
⟨⟨x, y, ne_of_lt h⟩⟩

lemma exists_pair_lt (α : Type*) [nontrivial α] [linear_order α] : ∃ (x y : α), x < y :=
begin
  rcases exists_pair_ne α with ⟨x, y, hxy⟩,
  cases lt_or_gt_of_ne hxy;
  exact ⟨_, _, h⟩
end

lemma nontrivial_iff_lt [linear_order α] : nontrivial α ↔ ∃ (x y : α), x < y :=
⟨λ h, @exists_pair_lt α h _, λ ⟨x, y, h⟩, nontrivial_of_lt x y h⟩

lemma nontrivial_iff_exists_ne (x : α) : nontrivial α ↔ ∃ y, y ≠ x :=
⟨λ h, @exists_ne α h x, λ ⟨y, hy⟩, nontrivial_of_ne _ _ hy⟩

lemma subtype.nontrivial_iff_exists_ne (p : α → Prop) (x : subtype p) :
  nontrivial (subtype p) ↔ ∃ (y : α) (hy : p y), y ≠ x :=
by simp only [nontrivial_iff_exists_ne x, subtype.exists, ne.def, subtype.ext_iff, subtype.coe_mk]

instance : nontrivial Prop := ⟨⟨true, false, true_ne_false⟩⟩

/--
See Note [lower instance priority]

Note that since this and `nonempty_of_inhabited` are the most "obvious" way to find a nonempty
instance if no direct instance can be found, we give this a higher priority than the usual `100`.
-/
@[priority 500]
instance nontrivial.to_nonempty [nontrivial α] : nonempty α :=
let ⟨x, _⟩ := exists_pair_ne α in ⟨x⟩

attribute [instance, priority 500] nonempty_of_inhabited

/-- An inhabited type is either nontrivial, or has a unique element. -/
noncomputable def nontrivial_psum_unique (α : Type*) [inhabited α] :
  psum (nontrivial α) (unique α) :=
if h : nontrivial α then psum.inl h else psum.inr
{ default := default,
  uniq := λ (x : α),
  begin
    change x = default,
    contrapose! h,
    use [x, default]
  end }

lemma subsingleton_iff : subsingleton α ↔ ∀ (x y : α), x = y :=
⟨by { introsI h, exact subsingleton.elim }, λ h, ⟨h⟩⟩

lemma not_nontrivial_iff_subsingleton : ¬(nontrivial α) ↔ subsingleton α :=
by { rw [nontrivial_iff, subsingleton_iff], push_neg, refl }

lemma not_nontrivial (α) [subsingleton α] : ¬nontrivial α :=
λ ⟨⟨x, y, h⟩⟩, h $ subsingleton.elim x y

lemma not_subsingleton (α) [h : nontrivial α] : ¬subsingleton α :=
let ⟨⟨x, y, hxy⟩⟩ := h in λ ⟨h'⟩, hxy $ h' x y

/-- A type is either a subsingleton or nontrivial. -/
lemma subsingleton_or_nontrivial (α : Type*) : subsingleton α ∨ nontrivial α :=
by { rw [← not_nontrivial_iff_subsingleton, or_comm], exact classical.em _ }

lemma false_of_nontrivial_of_subsingleton (α : Type*) [nontrivial α] [subsingleton α] : false :=
let ⟨x, y, h⟩ := exists_pair_ne α in h $ subsingleton.elim x y

instance option.nontrivial [nonempty α] : nontrivial (option α) :=
by { inhabit α, use [none, some default] }

/-- Pushforward a `nontrivial` instance along an injective function. -/
protected lemma function.injective.nontrivial [nontrivial α]
  {f : α → β} (hf : function.injective f) : nontrivial β :=
let ⟨x, y, h⟩ := exists_pair_ne α in ⟨⟨f x, f y, hf.ne h⟩⟩

/-- Pullback a `nontrivial` instance along a surjective function. -/
protected lemma function.surjective.nontrivial [nontrivial β]
  {f : α → β} (hf : function.surjective f) : nontrivial α :=
begin
  rcases exists_pair_ne β with ⟨x, y, h⟩,
  rcases hf x with ⟨x', hx'⟩,
  rcases hf y with ⟨y', hy'⟩,
  have : x' ≠ y', by { contrapose! h, rw [← hx', ← hy', h] },
  exact ⟨⟨x', y', this⟩⟩
end

/-- An injective function from a nontrivial type has an argument at
which it does not take a given value. -/
protected lemma function.injective.exists_ne [nontrivial α] {f : α → β}
  (hf : function.injective f) (y : β) : ∃ x, f x ≠ y :=
begin
  rcases exists_pair_ne α with ⟨x₁, x₂, hx⟩,
  by_cases h : f x₂ = y,
  { exact ⟨x₁, (hf.ne_iff' h).2 hx⟩ },
  { exact ⟨x₂, h⟩ }
end

instance nontrivial_prod_right [nonempty α] [nontrivial β] : nontrivial (α × β) :=
prod.snd_surjective.nontrivial

instance nontrivial_prod_left [nontrivial α] [nonempty β] : nontrivial (α × β) :=
prod.fst_surjective.nontrivial

namespace pi

variables {I : Type*} {f : I → Type*}

/-- A pi type is nontrivial if it's nonempty everywhere and nontrivial somewhere. -/
lemma nontrivial_at (i' : I) [inst : Π i, nonempty (f i)] [nontrivial (f i')] :
  nontrivial (Π i : I, f i) :=
by classical; exact
(function.update_injective (λ i, classical.choice (inst i)) i').nontrivial

/--
As a convenience, provide an instance automatically if `(f default)` is nontrivial.

If a different index has the non-trivial type, then use `haveI := nontrivial_at that_index`.
-/
instance nontrivial [inhabited I] [inst : Π i, nonempty (f i)] [nontrivial (f default)] :
  nontrivial (Π i : I, f i) := nontrivial_at default

end pi

instance function.nontrivial [h : nonempty α] [nontrivial β] : nontrivial (α → β) :=
h.elim $ λ a, pi.nontrivial_at a

mk_simp_attribute nontriviality "Simp lemmas for `nontriviality` tactic"

protected lemma subsingleton.le [preorder α] [subsingleton α] (x y : α) : x ≤ y :=
le_of_eq (subsingleton.elim x y)

attribute [nontriviality] eq_iff_true_of_subsingleton subsingleton.le

namespace tactic

/--
Tries to generate a `nontrivial α` instance by performing case analysis on
`subsingleton_or_nontrivial α`,
attempting to discharge the subsingleton branch using lemmas with `@[nontriviality]` attribute,
including `subsingleton.le` and `eq_iff_true_of_subsingleton`.
-/
meta def nontriviality_by_elim (α : expr) (lems : interactive.parse simp_arg_list) : tactic unit :=
do
  alternative ← to_expr ``(subsingleton_or_nontrivial %%α),
  n ← get_unused_name "_inst",
  tactic.cases alternative [n, n],
  (solve1 $ do
    reset_instance_cache,
    apply_instance <|>
      interactive.simp none none ff lems [`nontriviality] (interactive.loc.ns [none])) <|>
      fail format!"Could not prove goal assuming `subsingleton {α}`",
  reset_instance_cache

/--
Tries to generate a `nontrivial α` instance using `nontrivial_of_ne` or `nontrivial_of_lt`
and local hypotheses.
-/
meta def nontriviality_by_assumption (α : expr) : tactic unit :=
do
  n ← get_unused_name "_inst",
  to_expr ``(nontrivial %%α) >>= assert n,
  apply_instance <|> `[solve_by_elim [nontrivial_of_ne, nontrivial_of_lt]],
  reset_instance_cache

end tactic

namespace tactic.interactive

open tactic

setup_tactic_parser

/--
Attempts to generate a `nontrivial α` hypothesis.

The tactic first looks for an instance using `apply_instance`.

If the goal is an (in)equality, the type `α` is inferred from the goal.
Otherwise, the type needs to be specified in the tactic invocation, as `nontriviality α`.

The `nontriviality` tactic will first look for strict inequalities amongst the hypotheses,
and use these to derive the `nontrivial` instance directly.

Otherwise, it will perform a case split on `subsingleton α ∨ nontrivial α`, and attempt to discharge
the `subsingleton` goal using `simp [lemmas] with nontriviality`, where `[lemmas]` is a list of
additional `simp` lemmas that can be passed to `nontriviality` using the syntax
`nontriviality α using [lemmas]`.

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : 0 < a :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  assumption,
end
```

```
example {R : Type} [comm_ring R] {r s : R} : r * s = s * r :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  apply mul_comm,
end
```

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : (2 : ℕ) ∣ 4 :=
begin
  nontriviality R, -- there is now a `nontrivial R` hypothesis available.
  dec_trivial
end
```

```
def myeq {α : Type} (a b : α) : Prop := a = b

example {α : Type} (a b : α) (h : a = b) : myeq a b :=
begin
  success_if_fail { nontriviality α }, -- Fails
  nontriviality α using [myeq], -- There is now a `nontrivial α` hypothesis available
  assumption
end
```
-/
meta def nontriviality (t : parse texpr?)
  (lems : parse (tk "using" *> simp_arg_list <|> pure [])) :
  tactic unit :=
do
  α ← match t with
  | some α := to_expr α
  | none :=
    (do t ← mk_mvar, e ← to_expr ``(@eq %%t _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@has_le.le %%t _ _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@ne %%t _ _), target >>= unify e, return t) <|>
    (do t ← mk_mvar, e ← to_expr ``(@has_lt.lt %%t _ _ _), target >>= unify e, return t) <|>
    fail "The goal is not an (in)equality, so you'll need to specify the desired `nontrivial α`
      instance by invoking `nontriviality α`."
  end,
  nontriviality_by_assumption α <|> nontriviality_by_elim α lems

add_tactic_doc
{ name                     := "nontriviality",
  category                 := doc_category.tactic,
  decl_names               := [`tactic.interactive.nontriviality],
  tags                     := ["logic", "type class"] }

end tactic.interactive

namespace bool

instance : nontrivial bool := ⟨⟨tt,ff, tt_eq_ff_eq_false⟩⟩

end bool


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

/-!
# Typeclasses for groups with an adjoined zero element

This file provides just the typeclass definitions, and the projection lemmas that expose their
members.

## Main definitions

* `group_with_zero`
* `comm_group_with_zero`
-/

set_option old_structure_cmd true

universe u

-- We have to fix the universe of `G₀` here, since the default argument to
-- `group_with_zero.div'` cannot contain a universe metavariable.
variables {G₀ : Type u} {M₀ M₀' G₀' : Type*}

section

/-- Typeclass for expressing that a type `M₀` with multiplication and a zero satisfies
`0 * a = 0` and `a * 0 = 0` for all `a : M₀`. -/
@[protect_proj, ancestor has_mul has_zero]
class mul_zero_class (M₀ : Type*) extends has_mul M₀, has_zero M₀ :=
(zero_mul : ∀ a : M₀, 0 * a = 0)
(mul_zero : ∀ a : M₀, a * 0 = 0)

section mul_zero_class

variables [mul_zero_class M₀] {a b : M₀}

@[ematch, simp] lemma zero_mul (a : M₀) : 0 * a = 0 :=
mul_zero_class.zero_mul a

@[ematch, simp] lemma mul_zero (a : M₀) : a * 0 = 0 :=
mul_zero_class.mul_zero a

end mul_zero_class

/-- Predicate typeclass for expressing that `a * b = 0` implies `a = 0` or `b = 0`
for all `a` and `b` of type `G₀`. -/
class no_zero_divisors (M₀ : Type*) [has_mul M₀] [has_zero M₀] : Prop :=
(eq_zero_or_eq_zero_of_mul_eq_zero : ∀ {a b : M₀}, a * b = 0 → a = 0 ∨ b = 0)

export no_zero_divisors (eq_zero_or_eq_zero_of_mul_eq_zero)

/-- A type `S₀` is a "semigroup with zero” if it is a semigroup with zero element, and `0` is left
and right absorbing. -/
@[protect_proj] class semigroup_with_zero (S₀ : Type*) extends semigroup S₀, mul_zero_class S₀.

/- By defining this _after_ `semigroup_with_zero`, we ensure that searches for `mul_zero_class` find
this class first. -/
/-- A typeclass for non-associative monoids with zero elements. -/
@[protect_proj] class mul_zero_one_class (M₀ : Type*) extends mul_one_class M₀, mul_zero_class M₀.

/-- A type `M₀` is a “monoid with zero” if it is a monoid with zero element, and `0` is left
and right absorbing. -/
@[protect_proj] class monoid_with_zero (M₀ : Type*) extends monoid M₀, mul_zero_one_class M₀.

@[priority 100] -- see Note [lower instance priority]
instance monoid_with_zero.to_semigroup_with_zero (M₀ : Type*) [monoid_with_zero M₀] :
  semigroup_with_zero M₀ :=
{ ..‹monoid_with_zero M₀› }

/-- A type `M` is a `cancel_monoid_with_zero` if it is a monoid with zero element, `0` is left
and right absorbing, and left/right multiplication by a non-zero element is injective. -/
@[protect_proj] class cancel_monoid_with_zero (M₀ : Type*) extends monoid_with_zero M₀ :=
(mul_left_cancel_of_ne_zero : ∀ {a b c : M₀}, a ≠ 0 → a * b = a * c → b = c)
(mul_right_cancel_of_ne_zero : ∀ {a b c : M₀}, b ≠ 0 → a * b = c * b → a = c)

section cancel_monoid_with_zero

variables [cancel_monoid_with_zero M₀] {a b c : M₀}

lemma mul_left_cancel' (ha : a ≠ 0) (h : a * b = a * c) : b = c :=
cancel_monoid_with_zero.mul_left_cancel_of_ne_zero ha h

lemma mul_right_cancel' (hb : b ≠ 0) (h : a * b = c * b) : a = c :=
cancel_monoid_with_zero.mul_right_cancel_of_ne_zero hb h

lemma mul_right_injective' (ha : a ≠ 0) : function.injective ((*) a) :=
λ b c, mul_left_cancel' ha

lemma mul_left_injective' (hb : b ≠ 0) : function.injective (λ a, a * b) :=
λ a c, mul_right_cancel' hb

end cancel_monoid_with_zero

/-- A type `M` is a commutative “monoid with zero” if it is a commutative monoid with zero
element, and `0` is left and right absorbing. -/
@[protect_proj]
class comm_monoid_with_zero (M₀ : Type*) extends comm_monoid M₀, monoid_with_zero M₀.

/-- A type `M` is a `comm_cancel_monoid_with_zero` if it is a commutative monoid with zero element,
 `0` is left and right absorbing,
  and left/right multiplication by a non-zero element is injective. -/
@[protect_proj] class comm_cancel_monoid_with_zero (M₀ : Type*) extends
  comm_monoid_with_zero M₀, cancel_monoid_with_zero M₀.

/-- A type `G₀` is a “group with zero” if it is a monoid with zero element (distinct from `1`)
such that every nonzero element is invertible.
The type is required to come with an “inverse” function, and the inverse of `0` must be `0`.

Examples include division rings and the ordered monoids that are the
target of valuations in general valuation theory.-/
class group_with_zero (G₀ : Type u) extends
  monoid_with_zero G₀, div_inv_monoid G₀, nontrivial G₀ :=
(inv_zero : (0 : G₀)⁻¹ = 0)
(mul_inv_cancel : ∀ a:G₀, a ≠ 0 → a * a⁻¹ = 1)

section group_with_zero
variables [group_with_zero G₀]

@[simp] lemma inv_zero : (0 : G₀)⁻¹ = 0 :=
group_with_zero.inv_zero

@[simp] lemma mul_inv_cancel {a : G₀} (h : a ≠ 0) : a * a⁻¹ = 1 :=
group_with_zero.mul_inv_cancel a h

end group_with_zero

/-- A type `G₀` is a commutative “group with zero”
if it is a commutative monoid with zero element (distinct from `1`)
such that every nonzero element is invertible.
The type is required to come with an “inverse” function, and the inverse of `0` must be `0`. -/
class comm_group_with_zero (G₀ : Type*) extends comm_monoid_with_zero G₀, group_with_zero G₀.

end


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.bool.basic
import data.set.image

/-!
# Booleans and set operations

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

This file contains two trivial lemmas about `bool`, `set.univ`, and `set.range`.
-/

open set

namespace bool

@[simp] lemma univ_eq : (univ : set bool) = {ff, tt} :=
(eq_univ_of_forall bool.dichotomy).symm

@[simp] lemma range_eq {α : Type*} (f : bool → α) : range f = {f ff, f tt} :=
by rw [← image_univ, univ_eq, image_pair]

@[simp] lemma compl_singleton (b : bool) : ({b}ᶜ : set bool) = { !b } :=
ext $ λ _, eq_bnot_iff.symm

end bool