/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.monotone
import order.rel_classes
import tactic.simps
import tactic.pi_instances

/-!
# (Semi-)lattices

Semilattices are partially ordered sets with join (greatest lower bound, or `sup`) or
meet (least upper bound, or `inf`) operations. Lattices are posets that are both
join-semilattices and meet-semilattices.

Distributive lattices are lattices which satisfy any of four equivalent distributivity properties,
of `sup` over `inf`, on the left or on the right.

## Main declarations

* `has_sup`: type class for the `⊔` notation
* `has_inf`: type class for the `⊓` notation

* `semilattice_sup`: a type class for join semilattices
* `semilattice_sup.mk'`: an alternative constructor for `semilattice_sup` via proofs that `⊔` is
  commutative, associative and idempotent.
* `semilattice_inf`: a type class for meet semilattices
* `semilattice_sup.mk'`: an alternative constructor for `semilattice_inf` via proofs that `⊓` is
  commutative, associative and idempotent.

* `lattice`: a type class for lattices
* `lattice.mk'`: an alternative constructor for `lattice` via profs that `⊔` and `⊓` are
  commutative, associative and satisfy a pair of "absorption laws".

* `distrib_lattice`: a type class for distributive lattices.

## Notations

* `a ⊔ b`: the supremum or join of `a` and `b`
* `a ⊓ b`: the infimum or meet of `a` and `b`

## TODO

* (Semi-)lattice homomorphisms
* Alternative constructors for distributive lattices from the other distributive properties

## Tags

semilattice, lattice

-/
set_option old_structure_cmd true

universes u v w

variables {α : Type u} {β : Type v}

-- TODO: move this eventually, if we decide to use them
attribute [ematch] le_trans lt_of_le_of_lt lt_of_lt_of_le lt_trans

section
-- TODO: this seems crazy, but it also seems to work reasonably well
@[ematch] theorem le_antisymm' [partial_order α] : ∀ {a b : α}, (: a ≤ b :) → b ≤ a → a = b :=
@le_antisymm _ _
end

/- TODO: automatic construction of dual definitions / theorems -/

/-- Typeclass for the `⊔` (`\lub`) notation -/
@[notation_class] class has_sup (α : Type u) := (sup : α → α → α)
/-- Typeclass for the `⊓` (`\glb`) notation -/
@[notation_class] class has_inf (α : Type u) := (inf : α → α → α)

infix ⊔ := has_sup.sup
infix ⊓ := has_inf.inf

/-!
### Join-semilattices
-/

/-- A `semilattice_sup` is a join-semilattice, that is, a partial order
  with a join (a.k.a. lub / least upper bound, sup / supremum) operation
  `⊔` which is the least element larger than both factors. -/
class semilattice_sup (α : Type u) extends has_sup α, partial_order α :=
(le_sup_left : ∀ a b : α, a ≤ a ⊔ b)
(le_sup_right : ∀ a b : α, b ≤ a ⊔ b)
(sup_le : ∀ a b c : α, a ≤ c → b ≤ c → a ⊔ b ≤ c)

/--
A type with a commutative, associative and idempotent binary `sup` operation has the structure of a
join-semilattice.

The partial order is defined so that `a ≤ b` unfolds to `a ⊔ b = b`; cf. `sup_eq_right`.
-/
def semilattice_sup.mk' {α : Type*} [has_sup α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (sup_idem : ∀ (a : α), a ⊔ a = a) : semilattice_sup α :=
{ sup := (⊔),
  le := λ a b, a ⊔ b = b,
  le_refl := sup_idem,
  le_trans := λ a b c hab hbc,
    begin
      dsimp only [(≤)] at *,
      rwa [←hbc, ←sup_assoc, hab],
    end,
  le_antisymm := λ a b hab hba,
    begin
      dsimp only [(≤)] at *,
      rwa [←hba, sup_comm],
    end,
  le_sup_left  := λ a b, show a ⊔ (a ⊔ b) = (a ⊔ b), by rw [←sup_assoc, sup_idem],
  le_sup_right := λ a b, show b ⊔ (a ⊔ b) = (a ⊔ b), by rw [sup_comm, sup_assoc, sup_idem],
  sup_le := λ a b c hac hbc,
    begin
      dsimp only [(≤), preorder.le] at *,
      rwa [sup_assoc, hbc],
    end }

instance (α : Type*) [has_inf α] : has_sup (order_dual α) := ⟨((⊓) : α → α → α)⟩
instance (α : Type*) [has_sup α] : has_inf (order_dual α) := ⟨((⊔) : α → α → α)⟩

section semilattice_sup
variables [semilattice_sup α] {a b c d : α}

@[simp] theorem le_sup_left : a ≤ a ⊔ b :=
semilattice_sup.le_sup_left a b

@[ematch] theorem le_sup_left' : a ≤ (: a ⊔ b :) :=
le_sup_left

@[simp] theorem le_sup_right : b ≤ a ⊔ b :=
semilattice_sup.le_sup_right a b

@[ematch] theorem le_sup_right' : b ≤ (: a ⊔ b :) :=
le_sup_right

theorem le_sup_of_le_left (h : c ≤ a) : c ≤ a ⊔ b :=
le_trans h le_sup_left

theorem le_sup_of_le_right (h : c ≤ b) : c ≤ a ⊔ b :=
le_trans h le_sup_right

theorem sup_le : a ≤ c → b ≤ c → a ⊔ b ≤ c :=
semilattice_sup.sup_le a b c

@[simp] theorem sup_le_iff : a ⊔ b ≤ c ↔ a ≤ c ∧ b ≤ c :=
⟨assume h : a ⊔ b ≤ c, ⟨le_trans le_sup_left h, le_trans le_sup_right h⟩,
  assume ⟨h₁, h₂⟩, sup_le h₁ h₂⟩

@[simp] theorem sup_eq_left : a ⊔ b = a ↔ b ≤ a :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem sup_of_le_left (h : b ≤ a) : a ⊔ b = a :=
sup_eq_left.2 h

@[simp] theorem left_eq_sup : a = a ⊔ b ↔ b ≤ a :=
eq_comm.trans sup_eq_left

@[simp] theorem sup_eq_right : a ⊔ b = b ↔ a ≤ b :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem sup_of_le_right (h : a ≤ b) : a ⊔ b = b :=
sup_eq_right.2 h

@[simp] theorem right_eq_sup : b = a ⊔ b ↔ a ≤ b :=
eq_comm.trans sup_eq_right

theorem sup_le_sup (h₁ : a ≤ b) (h₂ : c ≤ d) : a ⊔ c ≤ b ⊔ d :=
sup_le (le_sup_of_le_left h₁) (le_sup_of_le_right h₂)

theorem sup_le_sup_left (h₁ : a ≤ b) (c) : c ⊔ a ≤ c ⊔ b :=
sup_le_sup (le_refl _) h₁

theorem sup_le_sup_right (h₁ : a ≤ b) (c) : a ⊔ c ≤ b ⊔ c :=
sup_le_sup h₁ (le_refl _)

theorem le_of_sup_eq (h : a ⊔ b = b) : a ≤ b :=
by { rw ← h, simp }

lemma sup_ind [is_total α (≤)] (a b : α) {p : α → Prop} (ha : p a) (hb : p b) : p (a ⊔ b) :=
(is_total.total a b).elim (λ h : a ≤ b, by rwa sup_eq_right.2 h) (λ h, by rwa sup_eq_left.2 h)

@[simp] lemma sup_lt_iff [is_total α (≤)] {a b c : α} : b ⊔ c < a ↔ b < a ∧ c < a :=
⟨λ h, ⟨le_sup_left.trans_lt h, le_sup_right.trans_lt h⟩, λ h, sup_ind b c h.1 h.2⟩

@[simp] lemma le_sup_iff [is_total α (≤)] {a b c : α} : a ≤ b ⊔ c ↔ a ≤ b ∨ a ≤ c :=
⟨λ h, (total_of (≤) c b).imp
  (λ bc, by rwa sup_eq_left.2 bc at h)
  (λ bc, by rwa sup_eq_right.2 bc at h),
 λ h, h.elim le_sup_of_le_left le_sup_of_le_right⟩

@[simp] lemma lt_sup_iff [is_total α (≤)] {a b c : α} : a < b ⊔ c ↔ a < b ∨ a < c :=
⟨λ h, (total_of (≤) c b).imp
  (λ bc, by rwa sup_eq_left.2 bc at h)
  (λ bc, by rwa sup_eq_right.2 bc at h),
 λ h, h.elim (λ h, h.trans_le le_sup_left) (λ h, h.trans_le le_sup_right)⟩

@[simp] theorem sup_idem : a ⊔ a = a :=
by apply le_antisymm; simp

instance sup_is_idempotent : is_idempotent α (⊔) := ⟨@sup_idem _ _⟩

theorem sup_comm : a ⊔ b = b ⊔ a :=
by apply le_antisymm; simp

instance sup_is_commutative : is_commutative α (⊔) := ⟨@sup_comm _ _⟩

theorem sup_assoc : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) :=
le_antisymm
  (sup_le
    (sup_le le_sup_left (le_sup_of_le_right le_sup_left))
    (le_sup_of_le_right le_sup_right))
  (sup_le
    (le_sup_of_le_left le_sup_left)
    (sup_le (le_sup_of_le_left le_sup_right) le_sup_right))

instance sup_is_associative : is_associative α (⊔) := ⟨@sup_assoc _ _⟩

lemma sup_left_right_swap (a b c : α) : a ⊔ b ⊔ c = c ⊔ b ⊔ a :=
by rw [sup_comm, @sup_comm _ _ a, sup_assoc]

@[simp] lemma sup_left_idem : a ⊔ (a ⊔ b) = a ⊔ b :=
by rw [← sup_assoc, sup_idem]

@[simp] lemma sup_right_idem : (a ⊔ b) ⊔ b = a ⊔ b :=
by rw [sup_assoc, sup_idem]

lemma sup_left_comm (a b c : α) : a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) :=
by rw [← sup_assoc, ← sup_assoc, @sup_comm α _ a]

lemma sup_right_comm (a b c : α) : a ⊔ b ⊔ c = a ⊔ c ⊔ b :=
by rw [sup_assoc, sup_assoc, @sup_comm _ _ b]

lemma sup_sup_sup_comm (a b c d : α) : a ⊔ b ⊔ (c ⊔ d) = a ⊔ c ⊔ (b ⊔ d) :=
by rw [sup_assoc, sup_left_comm b, ←sup_assoc]

lemma forall_le_or_exists_lt_sup (a : α) : (∀b, b ≤ a) ∨ (∃b, a < b) :=
suffices (∃b, ¬b ≤ a) → (∃b, a < b),
  by rwa [or_iff_not_imp_left, not_forall],
assume ⟨b, hb⟩,
⟨a ⊔ b, lt_of_le_of_ne le_sup_left $ mt left_eq_sup.1 hb⟩

/-- If `f` is monotone, `g` is antitone, and `f ≤ g`, then for all `a`, `b` we have `f a ≤ g b`. -/
theorem monotone.forall_le_of_antitone {β : Type*} [preorder β] {f g : α → β}
  (hf : monotone f) (hg : antitone g) (h : f ≤ g) (m n : α) :
  f m ≤ g n :=
calc f m ≤ f (m ⊔ n) : hf le_sup_left
     ... ≤ g (m ⊔ n) : h _
     ... ≤ g n       : hg le_sup_right

theorem semilattice_sup.ext_sup {α} {A B : semilattice_sup α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y)
  (x y : α) : (by haveI := A; exact (x ⊔ y)) = x ⊔ y :=
eq_of_forall_ge_iff $ λ c,
by simp only [sup_le_iff]; rw [← H, @sup_le_iff α A, H, H]

theorem semilattice_sup.ext {α} {A B : semilattice_sup α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have := partial_order.ext H,
  have ss := funext (λ x, funext $ semilattice_sup.ext_sup H x),
  casesI A, casesI B,
  injection this; congr'
end

theorem exists_lt_of_sup (α : Type*) [semilattice_sup α] [nontrivial α] : ∃ a b : α, a < b :=
begin
  rcases exists_pair_ne α with ⟨a, b, hne⟩,
  rcases forall_le_or_exists_lt_sup b with (hb|H),
  exacts [⟨a, b, (hb a).lt_of_ne hne⟩, ⟨b, H⟩]
end

end semilattice_sup

/-!
### Meet-semilattices
-/

/-- A `semilattice_inf` is a meet-semilattice, that is, a partial order
  with a meet (a.k.a. glb / greatest lower bound, inf / infimum) operation
  `⊓` which is the greatest element smaller than both factors. -/
class semilattice_inf (α : Type u) extends has_inf α, partial_order α :=
(inf_le_left : ∀ a b : α, a ⊓ b ≤ a)
(inf_le_right : ∀ a b : α, a ⊓ b ≤ b)
(le_inf : ∀ a b c : α, a ≤ b → a ≤ c → a ≤ b ⊓ c)

instance (α) [semilattice_inf α] : semilattice_sup (order_dual α) :=
{ le_sup_left  := semilattice_inf.inf_le_left,
  le_sup_right := semilattice_inf.inf_le_right,
  sup_le := assume a b c hca hcb, @semilattice_inf.le_inf α _ _ _ _ hca hcb,
  .. order_dual.partial_order α, .. order_dual.has_sup α }

instance (α) [semilattice_sup α] : semilattice_inf (order_dual α) :=
{ inf_le_left  := @le_sup_left α _,
  inf_le_right := @le_sup_right α _,
  le_inf := assume a b c hca hcb, @sup_le α _ _ _ _ hca hcb,
  .. order_dual.partial_order α, .. order_dual.has_inf α }

theorem semilattice_sup.dual_dual (α : Type*) [H : semilattice_sup α] :
  order_dual.semilattice_sup (order_dual α) = H :=
semilattice_sup.ext $ λ _ _, iff.rfl

section semilattice_inf
variables [semilattice_inf α] {a b c d : α}

@[simp] theorem inf_le_left : a ⊓ b ≤ a :=
semilattice_inf.inf_le_left a b

@[ematch] theorem inf_le_left' : (: a ⊓ b :) ≤ a :=
semilattice_inf.inf_le_left a b

@[simp] theorem inf_le_right : a ⊓ b ≤ b :=
semilattice_inf.inf_le_right a b

@[ematch] theorem inf_le_right' : (: a ⊓ b :) ≤ b :=
semilattice_inf.inf_le_right a b

theorem le_inf : a ≤ b → a ≤ c → a ≤ b ⊓ c :=
semilattice_inf.le_inf a b c

theorem inf_le_of_left_le (h : a ≤ c) : a ⊓ b ≤ c :=
le_trans inf_le_left h

theorem inf_le_of_right_le (h : b ≤ c) : a ⊓ b ≤ c :=
le_trans inf_le_right h

@[simp] theorem le_inf_iff : a ≤ b ⊓ c ↔ a ≤ b ∧ a ≤ c :=
@sup_le_iff (order_dual α) _ _ _ _

@[simp] theorem inf_eq_left : a ⊓ b = a ↔ a ≤ b :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem inf_of_le_left (h : a ≤ b) : a ⊓ b = a :=
inf_eq_left.2 h

@[simp] theorem left_eq_inf : a = a ⊓ b ↔ a ≤ b :=
eq_comm.trans inf_eq_left

@[simp] theorem inf_eq_right : a ⊓ b = b ↔ b ≤ a :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem inf_of_le_right (h : b ≤ a) : a ⊓ b = b :=
inf_eq_right.2 h

@[simp] theorem right_eq_inf : b = a ⊓ b ↔ b ≤ a :=
eq_comm.trans inf_eq_right

theorem inf_le_inf (h₁ : a ≤ b) (h₂ : c ≤ d) : a ⊓ c ≤ b ⊓ d :=
le_inf (inf_le_of_left_le h₁) (inf_le_of_right_le h₂)

lemma inf_le_inf_right (a : α) {b c : α} (h : b ≤ c) : b ⊓ a ≤ c ⊓ a :=
inf_le_inf h (le_refl _)

lemma inf_le_inf_left (a : α) {b c : α} (h : b ≤ c) : a ⊓ b ≤ a ⊓ c :=
inf_le_inf (le_refl _) h

theorem le_of_inf_eq (h : a ⊓ b = a) : a ≤ b :=
by { rw ← h, simp }

lemma inf_ind [is_total α (≤)] (a b : α) {p : α → Prop} (ha : p a) (hb : p b) : p (a ⊓ b) :=
@sup_ind (order_dual α) _ _ _ _ _ ha hb

@[simp] lemma lt_inf_iff [is_total α (≤)] {a b c : α} : a < b ⊓ c ↔ a < b ∧ a < c :=
@sup_lt_iff (order_dual α) _ _ _ _ _

@[simp] lemma inf_le_iff [is_total α (≤)] {a b c : α} : b ⊓ c ≤ a ↔ b ≤ a ∨ c ≤ a :=
@le_sup_iff (order_dual α) _ _ _ _ _

@[simp] theorem inf_idem : a ⊓ a = a :=
@sup_idem (order_dual α) _ _

instance inf_is_idempotent : is_idempotent α (⊓) := ⟨@inf_idem _ _⟩

theorem inf_comm : a ⊓ b = b ⊓ a :=
@sup_comm (order_dual α) _ _ _

instance inf_is_commutative : is_commutative α (⊓) := ⟨@inf_comm _ _⟩

theorem inf_assoc : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) :=
@sup_assoc (order_dual α) _ a b c

instance inf_is_associative : is_associative α (⊓) := ⟨@inf_assoc _ _⟩

lemma inf_left_right_swap (a b c : α) : a ⊓ b ⊓ c = c ⊓ b ⊓ a :=
by rw [inf_comm, @inf_comm _ _ a, inf_assoc]

@[simp] lemma inf_left_idem : a ⊓ (a ⊓ b) = a ⊓ b :=
@sup_left_idem (order_dual α) _ a b

@[simp] lemma inf_right_idem : (a ⊓ b) ⊓ b = a ⊓ b :=
@sup_right_idem (order_dual α) _ a b

lemma inf_left_comm (a b c : α) : a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) :=
@sup_left_comm (order_dual α) _ a b c

lemma inf_right_comm (a b c : α) : a ⊓ b ⊓ c = a ⊓ c ⊓ b :=
@sup_right_comm (order_dual α) _ a b c

lemma inf_inf_inf_comm (a b c d : α) : a ⊓ b ⊓ (c ⊓ d) = a ⊓ c ⊓ (b ⊓ d) :=
@sup_sup_sup_comm (order_dual α) _ _ _ _ _

lemma forall_le_or_exists_lt_inf (a : α) : (∀b, a ≤ b) ∨ (∃b, b < a) :=
@forall_le_or_exists_lt_sup (order_dual α) _ a

theorem semilattice_inf.ext_inf {α} {A B : semilattice_inf α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y)
  (x y : α) : (by haveI := A; exact (x ⊓ y)) = x ⊓ y :=
eq_of_forall_le_iff $ λ c,
by simp only [le_inf_iff]; rw [← H, @le_inf_iff α A, H, H]

theorem semilattice_inf.ext {α} {A B : semilattice_inf α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have := partial_order.ext H,
  have ss := funext (λ x, funext $ semilattice_inf.ext_inf H x),
  casesI A, casesI B,
  injection this; congr'
end

theorem semilattice_inf.dual_dual (α : Type*) [H : semilattice_inf α] :
  order_dual.semilattice_inf (order_dual α) = H :=
semilattice_inf.ext $ λ _ _, iff.rfl

theorem exists_lt_of_inf (α : Type*) [semilattice_inf α] [nontrivial α] :
  ∃ a b : α, a < b :=
let ⟨a, b, h⟩ := exists_lt_of_sup (order_dual α) in ⟨b, a, h⟩

end semilattice_inf

/--
A type with a commutative, associative and idempotent binary `inf` operation has the structure of a
meet-semilattice.

The partial order is defined so that `a ≤ b` unfolds to `b ⊓ a = a`; cf. `inf_eq_right`.
-/
def semilattice_inf.mk' {α : Type*} [has_inf α]
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (inf_idem : ∀ (a : α), a ⊓ a = a) : semilattice_inf α :=
begin
  haveI : semilattice_sup (order_dual α) := semilattice_sup.mk' inf_comm inf_assoc inf_idem,
  haveI i := order_dual.semilattice_inf (order_dual α),
  exact i,
end

/-!
### Lattices
-/

/-- A lattice is a join-semilattice which is also a meet-semilattice. -/
@[protect_proj] class lattice (α : Type u) extends semilattice_sup α, semilattice_inf α

instance (α) [lattice α] : lattice (order_dual α) :=
{ .. order_dual.semilattice_sup α, .. order_dual.semilattice_inf α }

/-- The partial orders from `semilattice_sup_mk'` and `semilattice_inf_mk'` agree
if `sup` and `inf` satisfy the lattice absorption laws `sup_inf_self` (`a ⊔ a ⊓ b = a`)
and `inf_sup_self` (`a ⊓ (a ⊔ b) = a`). -/
lemma semilattice_sup_mk'_partial_order_eq_semilattice_inf_mk'_partial_order {α : Type*}
  [has_sup α] [has_inf α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (sup_idem : ∀ (a : α), a ⊔ a = a)
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (inf_idem : ∀ (a : α), a ⊓ a = a)
  (sup_inf_self : ∀ (a b : α), a ⊔ a ⊓ b = a)
  (inf_sup_self : ∀ (a b : α), a ⊓ (a ⊔ b) = a) :
  @semilattice_sup.to_partial_order _ (semilattice_sup.mk' sup_comm sup_assoc sup_idem) =
    @semilattice_inf.to_partial_order _ (semilattice_inf.mk' inf_comm inf_assoc inf_idem) :=
partial_order.ext $ λ a b, show a ⊔ b = b ↔ b ⊓ a = a, from
  ⟨λ h, by rw [←h, inf_comm, inf_sup_self],
   λ h, by rw [←h, sup_comm, sup_inf_self]⟩

/--
A type with a pair of commutative and associative binary operations which satisfy two absorption
laws relating the two operations has the structure of a lattice.

The partial order is defined so that `a ≤ b` unfolds to `a ⊔ b = b`; cf. `sup_eq_right`.
-/
def lattice.mk' {α : Type*} [has_sup α] [has_inf α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (sup_inf_self : ∀ (a b : α), a ⊔ a ⊓ b = a)
  (inf_sup_self : ∀ (a b : α), a ⊓ (a ⊔ b) = a) : lattice α :=
have sup_idem : ∀ (b : α), b ⊔ b = b := λ b,
  calc b ⊔ b = b ⊔ b ⊓ (b ⊔ b) : by rw inf_sup_self
         ... = b               : by rw sup_inf_self,
have inf_idem : ∀ (b : α), b ⊓ b = b := λ b,
  calc b ⊓ b = b ⊓ (b ⊔ b ⊓ b) : by rw sup_inf_self
         ... = b               : by rw inf_sup_self,
let semilatt_inf_inst := semilattice_inf.mk' inf_comm inf_assoc inf_idem,
    semilatt_sup_inst := semilattice_sup.mk' sup_comm sup_assoc sup_idem,
-- here we help Lean to see that the two partial orders are equal
  partial_order_inst := @semilattice_sup.to_partial_order _ semilatt_sup_inst in
have partial_order_eq :
  partial_order_inst = @semilattice_inf.to_partial_order _ semilatt_inf_inst :=
  semilattice_sup_mk'_partial_order_eq_semilattice_inf_mk'_partial_order _ _ _ _ _ _
    sup_inf_self inf_sup_self,
{ inf_le_left  := λ a b, by { rw partial_order_eq, apply inf_le_left },
  inf_le_right := λ a b, by { rw partial_order_eq, apply inf_le_right },
  le_inf := λ a b c, by { rw partial_order_eq, apply le_inf },
  ..partial_order_inst,
  ..semilatt_sup_inst,
  ..semilatt_inf_inst, }

section lattice
variables [lattice α] {a b c d : α}

lemma inf_le_sup : a ⊓ b ≤ a ⊔ b := inf_le_left.trans le_sup_left

@[simp] lemma inf_lt_sup : a ⊓ b < a ⊔ b ↔ a ≠ b :=
begin
  split,
  { rintro H rfl, simpa using H },
  { refine λ Hne, lt_iff_le_and_ne.2 ⟨inf_le_sup, λ Heq, Hne _⟩,
    refine le_antisymm _ _,
    exacts [le_sup_left.trans (Heq.symm.trans_le inf_le_right),
      le_sup_right.trans (Heq.symm.trans_le inf_le_left)] }
end

/-!
#### Distributivity laws
-/
/- TODO: better names? -/
theorem sup_inf_le : a ⊔ (b ⊓ c) ≤ (a ⊔ b) ⊓ (a ⊔ c) :=
le_inf (sup_le_sup_left inf_le_left _) (sup_le_sup_left inf_le_right _)

theorem le_inf_sup : (a ⊓ b) ⊔ (a ⊓ c) ≤ a ⊓ (b ⊔ c) :=
sup_le (inf_le_inf_left _ le_sup_left) (inf_le_inf_left _ le_sup_right)

theorem inf_sup_self : a ⊓ (a ⊔ b) = a :=
by simp

theorem sup_inf_self : a ⊔ (a ⊓ b) = a :=
by simp

theorem sup_eq_iff_inf_eq : a ⊔ b = b ↔ a ⊓ b = a :=
by rw [sup_eq_right, ←inf_eq_left]

theorem lattice.ext {α} {A B : lattice α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have SS : @lattice.to_semilattice_sup α A =
            @lattice.to_semilattice_sup α B := semilattice_sup.ext H,
  have II := semilattice_inf.ext H,
  casesI A, casesI B,
  injection SS; injection II; congr'
end

end lattice

/-!
### Distributive lattices
-/

/-- A distributive lattice is a lattice that satisfies any of four
equivalent distributive properties (of `sup` over `inf` or `inf` over `sup`,
on the left or right).

The definition here chooses `le_sup_inf`: `(x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z)`.

A classic example of a distributive lattice
is the lattice of subsets of a set, and in fact this example is
generic in the sense that every distributive lattice is realizable
as a sublattice of a powerset lattice. -/
class distrib_lattice α extends lattice α :=
(le_sup_inf : ∀x y z : α, (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z))

/- TODO: alternative constructors from the other distributive properties,
and perhaps a `tfae` statement -/

section distrib_lattice
variables [distrib_lattice α] {x y z : α}

theorem le_sup_inf : ∀{x y z : α}, (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z) :=
distrib_lattice.le_sup_inf

theorem sup_inf_left : x ⊔ (y ⊓ z) = (x ⊔ y) ⊓ (x ⊔ z) :=
le_antisymm sup_inf_le le_sup_inf

theorem sup_inf_right : (y ⊓ z) ⊔ x = (y ⊔ x) ⊓ (z ⊔ x) :=
by simp only [sup_inf_left, λy:α, @sup_comm α _ y x, eq_self_iff_true]

theorem inf_sup_left : x ⊓ (y ⊔ z) = (x ⊓ y) ⊔ (x ⊓ z) :=
calc x ⊓ (y ⊔ z) = (x ⊓ (x ⊔ z)) ⊓ (y ⊔ z)       : by rw [inf_sup_self]
             ... = x ⊓ ((x ⊓ y) ⊔ z)             : by simp only [inf_assoc, sup_inf_right,
                                                                 eq_self_iff_true]
             ... = (x ⊔ (x ⊓ y)) ⊓ ((x ⊓ y) ⊔ z) : by rw [sup_inf_self]
             ... = ((x ⊓ y) ⊔ x) ⊓ ((x ⊓ y) ⊔ z) : by rw [sup_comm]
             ... = (x ⊓ y) ⊔ (x ⊓ z)             : by rw [sup_inf_left]

instance (α : Type*) [distrib_lattice α] : distrib_lattice (order_dual α) :=
{ le_sup_inf := assume x y z, le_of_eq inf_sup_left.symm,
  .. order_dual.lattice α }

theorem inf_sup_right : (y ⊔ z) ⊓ x = (y ⊓ x) ⊔ (z ⊓ x) :=
by simp only [inf_sup_left, λy:α, @inf_comm α _ y x, eq_self_iff_true]

lemma le_of_inf_le_sup_le (h₁ : x ⊓ z ≤ y ⊓ z) (h₂ : x ⊔ z ≤ y ⊔ z) : x ≤ y :=
calc x ≤ (y ⊓ z) ⊔ x : le_sup_right
... = (y ⊔ x) ⊓ (x ⊔ z) : by rw [sup_inf_right, @sup_comm _ _ x]
... ≤ (y ⊔ x) ⊓ (y ⊔ z) : inf_le_inf_left _ h₂
... = y ⊔ (x ⊓ z) : sup_inf_left.symm
... ≤ y ⊔ (y ⊓ z) : sup_le_sup_left h₁ _
... ≤ _ : sup_le (le_refl y) inf_le_left

lemma eq_of_inf_eq_sup_eq {α : Type u} [distrib_lattice α] {a b c : α}
  (h₁ : b ⊓ a = c ⊓ a) (h₂ : b ⊔ a = c ⊔ a) : b = c :=
le_antisymm
  (le_of_inf_le_sup_le (le_of_eq h₁) (le_of_eq h₂))
  (le_of_inf_le_sup_le (le_of_eq h₁.symm) (le_of_eq h₂.symm))

end distrib_lattice

/-!
### Lattices derived from linear orders
-/

@[priority 100] -- see Note [lower instance priority]
instance lattice_of_linear_order {α : Type u} [o : linear_order α] :
  lattice α :=
{ sup          := max,
  le_sup_left  := le_max_left,
  le_sup_right := le_max_right,
  sup_le       := assume a b c, max_le,

  inf          := min,
  inf_le_left  := min_le_left,
  inf_le_right := min_le_right,
  le_inf       := assume a b c, le_min,
  ..o }

theorem sup_eq_max [linear_order α] {x y : α} : x ⊔ y = max x y := rfl
theorem inf_eq_min [linear_order α] {x y : α} : x ⊓ y = min x y := rfl

/-- A lattice with total order is a linear order.

See note [reducible non-instances]. -/
@[reducible] def lattice.to_linear_order (α : Type u) [lattice α] [decidable_eq α]
  [decidable_rel ((≤) : α → α → Prop)] [decidable_rel ((<) : α → α → Prop)]
  (h : ∀ x y : α, x ≤ y ∨ y ≤ x) :
  linear_order α :=
{ decidable_le := ‹_›, decidable_eq := ‹_›, decidable_lt := ‹_›,
  le_total := h,
  max := (⊔),
  max_def := by
  { funext x y, dunfold max_default,
    split_ifs with h', exacts [sup_of_le_left h', sup_of_le_right $ (h x y).resolve_right h'] },
  min := (⊓),
  min_def := by
  { funext x y, dunfold min_default,
    split_ifs with h', exacts [inf_of_le_left h', inf_of_le_right $ (h x y).resolve_left h'] },
  .. ‹lattice α› }

@[priority 100] -- see Note [lower instance priority]
instance distrib_lattice_of_linear_order {α : Type u} [o : linear_order α] :
  distrib_lattice α :=
{ le_sup_inf := assume a b c,
    match le_total b c with
    | or.inl h := inf_le_of_left_le $ sup_le_sup_left (le_inf (le_refl b) h) _
    | or.inr h := inf_le_of_right_le $ sup_le_sup_left (le_inf h (le_refl c)) _
    end,
  ..lattice_of_linear_order }

instance nat.distrib_lattice : distrib_lattice ℕ :=
by apply_instance

/-! ### Function lattices -/

namespace pi
variables {ι : Type*} {α' : ι → Type*}

instance [Π i, has_sup (α' i)] : has_sup (Π i, α' i) := ⟨λ f g i, f i ⊔ g i⟩

@[simp] lemma sup_apply [Π i, has_sup (α' i)] (f g : Π i, α' i) (i : ι) : (f ⊔ g) i = f i ⊔ g i :=
rfl

lemma sup_def [Π i, has_sup (α' i)] (f g : Π i, α' i) : f ⊔ g = λ i, f i ⊔ g i := rfl

instance [Π i, has_inf (α' i)] : has_inf (Π i, α' i) := ⟨λ f g i, f i ⊓ g i⟩

@[simp] lemma inf_apply [Π i, has_inf (α' i)] (f g : Π i, α' i) (i : ι) : (f ⊓ g) i = f i ⊓ g i :=
rfl

lemma inf_def [Π i, has_inf (α' i)] (f g : Π i, α' i) : f ⊓ g = λ i, f i ⊓ g i := rfl

instance [Π i, semilattice_sup (α' i)] : semilattice_sup (Π i, α' i) :=
by refine_struct { sup := (⊔), .. pi.partial_order }; tactic.pi_instance_derive_field

instance [Π i, semilattice_inf (α' i)] : semilattice_inf (Π i, α' i) :=
by refine_struct { inf := (⊓), .. pi.partial_order }; tactic.pi_instance_derive_field

instance [Π i, lattice (α' i)] : lattice (Π i, α' i) :=
{ .. pi.semilattice_sup, .. pi.semilattice_inf }

instance [Π i, distrib_lattice (α' i)] : distrib_lattice (Π i, α' i) :=
by refine_struct { .. pi.lattice }; tactic.pi_instance_derive_field

end pi

/-!
### Monotone functions and lattices
-/
namespace monotone

/-- Pointwise supremum of two monotone functions is a monotone function. -/
protected lemma sup [preorder α] [semilattice_sup β] {f g : α → β} (hf : monotone f)
  (hg : monotone g) : monotone (f ⊔ g) :=
λ x y h, sup_le_sup (hf h) (hg h)

/-- Pointwise infimum of two monotone functions is a monotone function. -/
protected lemma inf [preorder α] [semilattice_inf β] {f g : α → β} (hf : monotone f)
  (hg : monotone g) : monotone (f ⊓ g) :=
λ x y h, inf_le_inf (hf h) (hg h)

/-- Pointwise maximum of two monotone functions is a monotone function. -/
protected lemma max [preorder α] [linear_order β] {f g : α → β} (hf : monotone f)
  (hg : monotone g) : monotone (λ x, max (f x) (g x)) :=
hf.sup hg

/-- Pointwise minimum of two monotone functions is a monotone function. -/
protected lemma min [preorder α] [linear_order β] {f g : α → β} (hf : monotone f)
  (hg : monotone g) : monotone (λ x, min (f x) (g x)) :=
hf.inf hg

lemma le_map_sup [semilattice_sup α] [semilattice_sup β]
  {f : α → β} (h : monotone f) (x y : α) :
  f x ⊔ f y ≤ f (x ⊔ y) :=
sup_le (h le_sup_left) (h le_sup_right)

lemma map_sup [semilattice_sup α] [is_total α (≤)] [semilattice_sup β] {f : α → β}
  (hf : monotone f) (x y : α) :
  f (x ⊔ y) = f x ⊔ f y :=
(is_total.total x y).elim
  (λ h : x ≤ y, by simp only [h, hf h, sup_of_le_right])
  (λ h, by simp only [h, hf h, sup_of_le_left])

lemma map_inf_le [semilattice_inf α] [semilattice_inf β]
  {f : α → β} (h : monotone f) (x y : α) :
  f (x ⊓ y) ≤ f x ⊓ f y :=
le_inf (h inf_le_left) (h inf_le_right)

lemma map_inf [semilattice_inf α] [is_total α (≤)] [semilattice_inf β] {f : α → β}
  (hf : monotone f) (x y : α) :
  f (x ⊓ y) = f x ⊓ f y :=
@monotone.map_sup (order_dual α) _ _ _ _ _ hf.dual x y

end monotone

/-!
### Products of (semi-)lattices
-/

namespace prod
variables (α β)

instance [has_sup α] [has_sup β] : has_sup (α × β) := ⟨λp q, ⟨p.1 ⊔ q.1, p.2 ⊔ q.2⟩⟩
instance [has_inf α] [has_inf β] : has_inf (α × β) := ⟨λp q, ⟨p.1 ⊓ q.1, p.2 ⊓ q.2⟩⟩

instance [semilattice_sup α] [semilattice_sup β] : semilattice_sup (α × β) :=
{ sup_le := assume a b c h₁ h₂, ⟨sup_le h₁.1 h₂.1, sup_le h₁.2 h₂.2⟩,
  le_sup_left  := assume a b, ⟨le_sup_left, le_sup_left⟩,
  le_sup_right := assume a b, ⟨le_sup_right, le_sup_right⟩,
  .. prod.partial_order α β, .. prod.has_sup α β }

instance [semilattice_inf α] [semilattice_inf β] : semilattice_inf (α × β) :=
{ le_inf := assume a b c h₁ h₂, ⟨le_inf h₁.1 h₂.1, le_inf h₁.2 h₂.2⟩,
  inf_le_left  := assume a b, ⟨inf_le_left, inf_le_left⟩,
  inf_le_right := assume a b, ⟨inf_le_right, inf_le_right⟩,
  .. prod.partial_order α β, .. prod.has_inf α β }

instance [lattice α] [lattice β] : lattice (α × β) :=
{ .. prod.semilattice_inf α β, .. prod.semilattice_sup α β }

instance [distrib_lattice α] [distrib_lattice β] : distrib_lattice (α × β) :=
{ le_sup_inf := assume a b c, ⟨le_sup_inf, le_sup_inf⟩,
  .. prod.lattice α β }

end prod

/-!
### Subtypes of (semi-)lattices
-/

namespace subtype

/-- A subtype forms a `⊔`-semilattice if `⊔` preserves the property.
See note [reducible non-instances]. -/
@[reducible]
protected def semilattice_sup [semilattice_sup α] {P : α → Prop}
  (Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) : semilattice_sup {x : α // P x} :=
{ sup := λ x y, ⟨x.1 ⊔ y.1, Psup x.2 y.2⟩,
  le_sup_left := λ x y, @le_sup_left _ _ (x : α) y,
  le_sup_right := λ x y, @le_sup_right _ _ (x : α) y,
  sup_le := λ x y z h1 h2, @sup_le α _ _ _ _ h1 h2,
  ..subtype.partial_order P }

/-- A subtype forms a `⊓`-semilattice if `⊓` preserves the property.
See note [reducible non-instances]. -/
@[reducible]
protected def semilattice_inf [semilattice_inf α] {P : α → Prop}
  (Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) : semilattice_inf {x : α // P x} :=
{ inf := λ x y, ⟨x.1 ⊓ y.1, Pinf x.2 y.2⟩,
  inf_le_left := λ x y, @inf_le_left _ _ (x : α) y,
  inf_le_right := λ x y, @inf_le_right _ _ (x : α) y,
  le_inf := λ x y z h1 h2, @le_inf α _ _ _ _ h1 h2,
  ..subtype.partial_order P }

/-- A subtype forms a lattice if `⊔` and `⊓` preserve the property.
See note [reducible non-instances]. -/
@[reducible]
protected def lattice [lattice α] {P : α → Prop}
  (Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) (Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) :
  lattice {x : α // P x} :=
{ ..subtype.semilattice_inf Pinf, ..subtype.semilattice_sup Psup }

end subtype


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl

! This file was ported from Lean 3 source module algebra.order.monoid.to_mul_bot
! leanprover-community/mathlib commit ee0c179cd3c8a45aa5bffbf1b41d8dbede452865
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.WithZero
import Mathlib.Algebra.Order.Monoid.WithTop
import Mathlib.Algebra.Order.Monoid.TypeTags

/-!
Making an additive monoid multiplicative then adding a zero is the same as adding a bottom
element then making it multiplicative.
-/

universe u

variable {α : Type u}

namespace WithZero

variable [Add α]

/-- Making an additive monoid multiplicative then adding a zero is the same as adding a bottom
element then making it multiplicative. -/
def toMulBot : WithZero (Multiplicative α) ≃* Multiplicative (WithBot α) :=
  MulEquiv.refl _
#align with_zero.to_mul_bot WithZero.toMulBot

@[simp]
theorem toMulBot_zero : toMulBot (0 : WithZero (Multiplicative α)) = Multiplicative.ofAdd ⊥ :=
  rfl
#align with_zero.to_mul_bot_zero WithZero.toMulBot_zero

@[simp]
theorem toMulBot_coe (x : Multiplicative α) :
    toMulBot ↑x = Multiplicative.ofAdd (Multiplicative.toAdd x : WithBot α) :=
  rfl
#align with_zero.to_mul_bot_coe WithZero.toMulBot_coe

@[simp]
theorem toMulBot_symm_bot : toMulBot.symm (Multiplicative.ofAdd (⊥ : WithBot α)) = 0 :=
  rfl
#align with_zero.to_mul_bot_symm_bot WithZero.toMulBot_symm_bot

@[simp]
theorem toMulBot_coe_ofAdd (x : α) :
    toMulBot.symm (Multiplicative.ofAdd (x : WithBot α)) = Multiplicative.ofAdd x :=
  rfl
#align with_zero.to_mul_bot_coe_of_add WithZero.toMulBot_coe_ofAdd

variable [Preorder α] (a b : WithZero (Multiplicative α))

theorem toMulBot_strictMono : StrictMono (@toMulBot α _) := fun _ _ => id
#align with_zero.to_mul_bot_strict_mono WithZero.toMulBot_strictMono

@[simp]
theorem toMulBot_le : toMulBot a ≤ toMulBot b ↔ a ≤ b :=
  Iff.rfl
#align with_zero.to_mul_bot_le WithZero.toMulBot_le

@[simp]

end WithZero


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

-/

import .binary

universes u v w
hott_theory
set_option old_structure_cmd true
namespace hott
open hott.binary is_trunc

variable {A : Type _}

/- inf_semigroup -/

namespace algebra

@[hott, class] structure inf_semigroup (A : Type _) extends has_mul A :=
(mul_assoc : Πa b c, mul (mul a b) c = mul a (mul b c))

@[hott] def mul.assoc [s : inf_semigroup A] (a b c : A) : a * b * c = a * (b * c) :=
inf_semigroup.mul_assoc _ _ _

@[hott, class] structure comm_inf_semigroup (A : Type _) extends inf_semigroup A :=
(mul_comm : Πa b, mul a b = mul b a)

@[hott] def mul.comm [s : comm_inf_semigroup A] (a b : A) : a * b = b * a :=
comm_inf_semigroup.mul_comm _ _

@[hott] theorem mul.left_comm [s : comm_inf_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) :=
binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c

@[hott] theorem mul.right_comm [s : comm_inf_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b :=
binary.right_comm (@mul.comm A _) (@mul.assoc A _) a b c

@[hott, class] structure left_cancel_inf_semigroup (A : Type _) extends inf_semigroup A :=
(mul_left_cancel : Πa b c, mul a b = mul a c → b = c)

@[hott] def mul.left_cancel [s : left_cancel_inf_semigroup A] {a b c : A} :
  a * b = a * c → b = c :=
left_cancel_inf_semigroup.mul_left_cancel _ _ _

@[hott, class] structure right_cancel_inf_semigroup (A : Type _) extends inf_semigroup A :=
(mul_right_cancel : Πa b c, mul a b = mul c b → a = c)

@[hott] def mul.right_cancel [s : right_cancel_inf_semigroup A] {a b c : A} :
  a * b = c * b → a = c :=
right_cancel_inf_semigroup.mul_right_cancel _ _ _

/- additive inf_semigroup -/

@[hott, class] def add_inf_semigroup : Type _ → Type _ := inf_semigroup

@[hott, reducible, instance] def has_add_of_add_inf_semigroup
  (A : Type _) [H : add_inf_semigroup A] : has_add A :=
has_add.mk (@inf_semigroup.mul A H)

@[hott] def add.assoc [s : add_inf_semigroup A] (a b c : A) : a + b + c = a + (b + c) :=
@mul.assoc A s a b c

@[hott, class] def add_comm_inf_semigroup : Type _ → Type _ := comm_inf_semigroup

@[hott, reducible, instance] def add_inf_semigroup_of_add_comm_inf_semigroup (A : Type _)
  [H : add_comm_inf_semigroup A] : add_inf_semigroup A :=
@comm_inf_semigroup.to_inf_semigroup A H

@[hott] def add.comm [s : add_comm_inf_semigroup A] (a b : A) : a + b = b + a :=
@mul.comm A s a b

@[hott] theorem add.left_comm [s : add_comm_inf_semigroup A] (a b c : A) :
  a + (b + c) = b + (a + c) :=
binary.left_comm (@add.comm A _) (@add.assoc A _) a b c

@[hott] theorem add.right_comm [s : add_comm_inf_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
binary.right_comm (@add.comm A _) (@add.assoc A _) a b c

@[hott, class] def add_left_cancel_inf_semigroup : Type _ → Type _ := left_cancel_inf_semigroup

@[hott, reducible, instance] def add_inf_semigroup_of_add_left_cancel_inf_semigroup (A : Type _)
  [H : add_left_cancel_inf_semigroup A] : add_inf_semigroup A :=
@left_cancel_inf_semigroup.to_inf_semigroup A H

@[hott] def add.left_cancel [s : add_left_cancel_inf_semigroup A] {a b c : A} :
  a + b = a + c → b = c :=
@mul.left_cancel A s a b c

@[hott, class] def add_right_cancel_inf_semigroup : Type _ → Type _ := right_cancel_inf_semigroup

@[hott, reducible, instance] def add_inf_semigroup_of_add_right_cancel_inf_semigroup (A : Type _)
  [H : add_right_cancel_inf_semigroup A] : add_inf_semigroup A :=
@right_cancel_inf_semigroup.to_inf_semigroup A H

@[hott] def add.right_cancel [s : add_right_cancel_inf_semigroup A] {a b c : A} :
  a + b = c + b → a = c :=
@mul.right_cancel A s a b c

/- inf_monoid -/

@[hott, class] structure inf_monoid (A : Type _) extends inf_semigroup A, has_one A :=
(one_mul : Πa, mul one a = a) (mul_one : Πa, mul a one = a)

@[hott] def one_mul [s : inf_monoid A] (a : A) : 1 * a = a := inf_monoid.one_mul _

@[hott] def mul_one [s : inf_monoid A] (a : A) : a * 1 = a := inf_monoid.mul_one _

@[hott, class] structure comm_inf_monoid (A : Type _) extends inf_monoid A, comm_inf_semigroup A

/- additive inf_monoid -/

@[hott, class] def add_inf_monoid : Type _ → Type _ := inf_monoid

@[hott, reducible, instance] def add_inf_semigroup_of_add_inf_monoid (A : Type _)
  [H : add_inf_monoid A] : add_inf_semigroup A :=
@inf_monoid.to_inf_semigroup A H

@[hott, reducible, instance] def has_zero_of_add_inf_monoid (A : Type _)
  [H : add_inf_monoid A] : has_zero A :=
has_zero.mk (@inf_monoid.one A H)

@[hott] def zero_add [s : add_inf_monoid A] (a : A) : 0 + a = a := @inf_monoid.one_mul A s a

@[hott] def add_zero [s : add_inf_monoid A] (a : A) : a + 0 = a := @inf_monoid.mul_one A s a

@[hott, class] def add_comm_inf_monoid : Type _ → Type _ := comm_inf_monoid

@[hott, reducible, instance] def add_inf_monoid_of_add_comm_inf_monoid (A : Type _)
  [H : add_comm_inf_monoid A] : add_inf_monoid A :=
@comm_inf_monoid.to_inf_monoid A H

@[hott, reducible, instance] def add_comm_inf_semigroup_of_add_comm_inf_monoid (A : Type _)
  [H : add_comm_inf_monoid A] : add_comm_inf_semigroup A :=
@comm_inf_monoid.to_comm_inf_semigroup A H

/- group -/

@[hott, class] structure inf_group (A : Type _) extends inf_monoid A, has_inv A :=
(mul_left_inv : Πa, mul (inv a) a = one)

-- Note: with more work, we could derive the axiom one_mul

section inf_group

variable [s : inf_group A]
include s

@[hott] def mul.left_inv (a : A) : a⁻¹ * a = 1 := inf_group.mul_left_inv _

@[hott] def inv_mul_cancel_left (a b : A) : a⁻¹ * (a * b) = b :=
by rwr [←mul.assoc, mul.left_inv, one_mul]

@[hott] def inv_mul_cancel_right (a b : A) : a * b⁻¹ * b = a :=
by rwr [mul.assoc, mul.left_inv, mul_one]

@[hott] def inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b :=
by rwr [←mul_one a⁻¹, ←H, inv_mul_cancel_left]

@[hott] theorem one_inv : (1 : A)⁻¹ = 1 := inv_eq_of_mul_eq_one (one_mul 1)

@[hott] def inv_inv (a : A) : (a⁻¹)⁻¹ = a := inv_eq_of_mul_eq_one (mul.left_inv a)

@[hott] theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b :=
by rwr [←inv_inv a, H, inv_inv b]

@[hott] theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b :=
iff.intro (assume H, inv.inj H) (assume H, ap _ H)

@[hott] theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 :=
by refine iff.trans _ (inv_eq_inv_iff_eq a 1); rwr [one_inv]

@[hott] theorem inv_eq_one {a : A} (H : a = 1) : a⁻¹ = 1 :=
iff.mpr (inv_eq_one_iff_eq_one a) H

@[hott] theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 :=
iff.mp (inv_eq_one_iff_eq_one _)

@[hott] theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ :=
by rwr [H, inv_inv]

@[hott] theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ :=
iff.intro eq_inv_of_eq_inv eq_inv_of_eq_inv

@[hott] theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ :=
begin apply eq_inv_of_eq_inv, symmetry, exact inv_eq_of_mul_eq_one H end

@[hott] def mul.right_inv (a : A) : a * a⁻¹ = 1 :=
calc
  a * a⁻¹ = (a⁻¹)⁻¹ * a⁻¹ : by rwr inv_inv
      ... = 1             : mul.left_inv _

@[hott] theorem mul_inv_cancel_left (a b : A) : a * (a⁻¹ * b) = b :=
calc
  a * (a⁻¹ * b) = a * a⁻¹ * b : by rwr mul.assoc
    ... = 1 * b               : by rwr mul.right_inv
    ... = b                   : by rwr one_mul

@[hott] def mul_inv_cancel_right (a b : A) : a * b * b⁻¹ = a :=
calc
  a * b * b⁻¹ = a * (b * b⁻¹) : by rwr mul.assoc
    ... = a * 1 : by rwr mul.right_inv
    ... = a : by rwr mul_one

@[hott] theorem mul_inv (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
inv_eq_of_mul_eq_one
  (calc
    a * b * (b⁻¹ * a⁻¹) = a * (b * (b⁻¹ * a⁻¹)) : by rwr mul.assoc
      ... = a * a⁻¹                             : by rwr mul_inv_cancel_left
      ... = 1                                   : by rwr mul.right_inv)

@[hott] theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b :=
calc
  a = a * b⁻¹ * b : by rwr inv_mul_cancel_right
    ... = 1 * b   : by rwr H
    ... = b       : by rwr one_mul

@[hott] theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ :=
by rwr [←H, mul_inv_cancel_right]

@[hott] theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c :=
by rwr [←H, inv_mul_cancel_left]

@[hott] theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c :=
by rwr [H, inv_mul_cancel_left]

@[hott] theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c :=
by rwr [H, mul_inv_cancel_right]

@[hott] theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c :=
by rwr [←inv_inv c]; exact eq_mul_inv_of_mul_eq H

@[hott] theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c :=
by rwr [←inv_inv b]; exact eq_inv_mul_of_mul_eq H

@[hott] theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c :=
by rwr [←inv_inv a]; exact inv_mul_eq_of_eq_mul H

@[hott] theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c :=
by rwr [←inv_inv b]; exact mul_inv_eq_of_eq_mul H

@[hott] theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c :=
iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul

@[hott] theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ :=
iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv

@[hott] def mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c :=
by rwr [←inv_mul_cancel_left a b, H, inv_mul_cancel_left]

@[hott] def mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c :=
by rwr [←mul_inv_cancel_right a b, H, mul_inv_cancel_right]

@[hott] theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 :=
by rwr [←inv_eq_of_mul_eq_one H, mul.left_inv]

@[hott] theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 :=
iff.intro mul_eq_one_of_mul_eq_one mul_eq_one_of_mul_eq_one

-- @[hott] def conj_by (g a : A) := g * a * g⁻¹
-- @[hott] def is_conjugate (a b : A) := Σ x, conj_by x b = a

-- local infixl ` ~ ` := is_conjugate
-- local infixr ` ∘c `:55 := conj_by

-- @[hott] lemma conj_compose (f g a : A) : f ∘c g ∘c a = f*g ∘c a :=
--     calc f ∘c g ∘c a = f * (g * a * g⁻¹) * f⁻¹ : rfl
--     ... = f * (g * a) * g⁻¹ * f⁻¹ : by rwr [←mul.assoc]
--     ... = f * g * a * g⁻¹ * f⁻¹ : by rwr [←mul.assoc]
--     ... = f * g * a * (g⁻¹ * f⁻¹) : by rwr mul.assoc
--     ... = f * g * a * (f * g)⁻¹ : by rwr mul_inv

-- @[hott] lemma conj_id (a : A) : 1 ∘c a = a :=
--     calc 1 * a * 1⁻¹ = a * 1⁻¹ : by rwr one_mul
--     ... = a * 1 : by rwr one_inv
--     ... = a : by rwr mul_one

-- @[hott] lemma conj_one (g : A) : g ∘c 1 = 1 :=
--     calc g * 1 * g⁻¹ = g * g⁻¹ : by rwr mul_one
--     ... = 1 : by rwr mul.right_inv

-- @[hott] lemma conj_inv_cancel (g : A) : Π a, g⁻¹ ∘c g ∘c a = a :=
--     assume a, calc
--     g⁻¹ ∘c g ∘c a = g⁻¹*g ∘c a : by rwr conj_compose
--     ... = 1 ∘c a : by rwr mul.left_inv
--     ... = a : by rwr conj_id

-- @[hott] lemma conj_inv (g : A) : Π a, (g ∘c a)⁻¹ = g ∘c a⁻¹ :=
--   λa, calc
--   (g * a * g⁻¹)⁻¹ = g⁻¹⁻¹ * (g * a)⁻¹   : by rwr mul_inv
--               ... = g⁻¹⁻¹ * (a⁻¹ * g⁻¹) : by rwr mul_inv
--               ... = g⁻¹⁻¹ * a⁻¹ * g⁻¹   : by rwr mul.assoc
--               ... = g * a⁻¹ * g⁻¹       : by rwr inv_inv

-- @[hott] lemma is_conj.refl (a : A) : a ~ a := sigma.mk 1 (conj_id a)

-- @[hott] lemma is_conj.symm (a b : A) : a ~ b → b ~ a :=
--     assume Pab, obtain x (Pconj : x ∘c b = a), from Pab,
--     have Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a,   begin congruence, assumption end,
--     sigma.mk x⁻¹ (inverse (conj_inv_cancel x b ▸ Pxinv))

-- @[hott] lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c :=
--     assume Pab, assume Pbc,
--     obtain x (Px : x ∘c b = a), from Pab,
--     obtain y (Py : y ∘c c = b), from Pbc,
--     sigma.mk (x*y) (calc
--     x*y ∘c c = x ∘c y ∘c c : conj_compose
--     ... = x ∘c b : Py
--     ... = a : Px)

@[hott, instance] def inf_group.to_left_cancel_inf_semigroup : left_cancel_inf_semigroup A :=
{ mul_left_cancel := @mul_left_cancel A s, ..s }

@[hott, instance] def inf_group.to_right_cancel_inf_semigroup : right_cancel_inf_semigroup A :=
{ mul_right_cancel := @mul_right_cancel A s, ..s }

@[hott] def one_unique {a : A} (H : Πb, a * b = b) : a = 1 :=
(mul_one _)⁻¹ ⬝ H 1

end inf_group

@[hott, class] structure ab_inf_group (A : Type _) extends inf_group A, comm_inf_monoid A

/- additive inf_group -/

@[hott, class] def add_inf_group : Type _ → Type _ := inf_group

@[hott, reducible, instance] def add_inf_semigroup_of_add_inf_group (A : Type _)
  [H : add_inf_group A] : add_inf_monoid A :=
@inf_group.to_inf_monoid A H

@[hott, reducible, instance] def has_neg_of_add_inf_group (A : Type _)
  [H : add_inf_group A] : has_neg A :=
has_neg.mk (@inf_group.inv A H)

section add_inf_group

variables [s : add_inf_group A]
include s

@[hott] def add.left_inv (a : A) : -a + a = 0 := @inf_group.mul_left_inv A s a

@[hott] def neg_add_cancel_left (a b : A) : -a + (a + b) = b :=
by rwr [←add.assoc, add.left_inv, zero_add]

@[hott] def neg_add_cancel_right (a b : A) : a + -b + b = a :=
by rwr [add.assoc, add.left_inv, add_zero]

@[hott] def neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b :=
by rwr [←add_zero (-a), ←H, neg_add_cancel_left]

@[hott] def neg_zero : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0)

@[hott] def neg_neg (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a)

@[hott] theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b :=
by rwr [←neg_eq_of_add_eq_zero H, neg_neg]

@[hott] theorem neg.inj {a b : A} (H : -a = -b) : a = b :=
calc
  a = -(-a) : by rwr neg_neg
... = -(-b) : by rwr H
... = b     : by rwr neg_neg

@[hott] theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b :=
iff.intro (assume H, neg.inj H) (assume H, ap _ H)

@[hott] theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b :=
  iff.mp (neg_eq_neg_iff_eq _ _)

@[hott] theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 :=
inv_eq_one_iff_eq_one a

@[hott] theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 :=
  iff.mp (neg_eq_zero_iff_eq_zero _)

@[hott] theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a :=
eq_inv_of_eq_inv H

@[hott] theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a :=
iff.intro eq_neg_of_eq_neg eq_neg_of_eq_neg

@[hott] def add.right_inv (a : A) : a + -a = 0 :=
calc
  a + -a = -(-a) + -a : by rwr neg_neg
    ... = 0 : by rwr add.left_inv

@[hott] def add_neg_cancel_left (a b : A) : a + (-a + b) = b :=
by rwr [←add.assoc, add.right_inv, zero_add]

@[hott] def add_neg_cancel_right (a b : A) : a + b + -b = a :=
by rwr [add.assoc, add.right_inv, add_zero]

@[hott] theorem neg_add_rev (a b : A) : -(a + b) = -b + -a :=
neg_eq_of_add_eq_zero
  begin
    rwr [add.assoc, add_neg_cancel_left, add.right_inv]
  end

-- TODO: delete these in favor of sub rules?
@[hott] theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c :=
eq_mul_inv_of_mul_eq H

@[hott] theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c :=
eq_inv_mul_of_mul_eq H

@[hott] theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c :=
inv_mul_eq_of_eq_mul H

@[hott] theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c :=
mul_inv_eq_of_eq_mul H

@[hott] theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c :=
eq_mul_of_mul_inv_eq H

@[hott] theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c :=
eq_mul_of_inv_mul_eq H

@[hott] theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c :=
mul_eq_of_eq_inv_mul H

@[hott] theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c :=
mul_eq_of_eq_mul_inv H

@[hott] theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c :=
iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add

@[hott] theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b :=
iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg

@[hott] theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c :=
calc b = -a + (a + b) : (neg_add_cancel_left _ _)⁻¹
   ... = -a + (a + c) : by rwr H
   ... = c : by rwr neg_add_cancel_left

@[hott] theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c :=
calc a = (a + b) + -b : (add_neg_cancel_right _ _)⁻¹
   ... = (c + b) + -b : by rwr H
   ... = c : by rwr add_neg_cancel_right

@[hott, reducible, instance] def add_inf_group.to_add_left_cancel_inf_semigroup :
  add_left_cancel_inf_semigroup A :=
@inf_group.to_left_cancel_inf_semigroup A s

@[hott, reducible, instance] def add_inf_group.to_add_right_cancel_inf_semigroup :
  add_right_cancel_inf_semigroup A :=
@inf_group.to_right_cancel_inf_semigroup A s

@[hott] theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) :=
by rwr [neg_add_rev, neg_neg]

/- sub -/

-- TODO: derive corresponding facts for div in a field
@[hott, reducible] protected def algebra.sub (a b : A) : A := a + -b

@[hott, instance] def add_inf_group_has_sub : has_sub A :=
has_sub.mk algebra.sub

@[hott] def sub_eq_add_neg (a b : A) : a - b = a + -b := rfl

@[hott] def sub_self (a : A) : a - a = 0 := add.right_inv _

@[hott] theorem sub_add_cancel (a b : A) : a - b + b = a := neg_add_cancel_right _ _

@[hott] theorem add_sub_cancel (a b : A) : a + b - b = a := add_neg_cancel_right _ _

@[hott] theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b :=
calc
  a = (a - b) + b : by rwr sub_add_cancel
    ... = 0 + b : by rwr H
    ... = b : by rwr zero_add

@[hott] theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 :=
iff.intro (λH, by rwr [H, sub_self]) (assume H, eq_of_sub_eq_zero H)

@[hott] theorem zero_sub (a : A) : 0 - a = -a := zero_add _

@[hott] theorem sub_zero (a : A) : a - 0 = a :=
by rwr [sub_eq_add_neg, neg_zero, add_zero]

@[hott] theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b :=
by change a + -(-b) = a + b; rwr neg_neg

@[hott] theorem neg_sub (a b : A) : -(a - b) = b - a :=
neg_eq_of_add_eq_zero
  (calc
    a - b + (b - a) = a - b + b - a : (add.assoc _ _ _)⁻¹
      ... = a - a                   : by rwr sub_add_cancel
      ... = 0                       : by rwr sub_self)

@[hott] theorem add_sub (a b c : A) : a + (b - c) = a + b - c := (add.assoc _ _ _)⁻¹

@[hott] theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b :=
calc
  a - (b + c) = a + (-c - b) : by rwr [sub_eq_add_neg, neg_add_rev]
          ... = a - c - b    : (add.assoc _ _ _)⁻¹

@[hott] theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b :=
iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H)

@[hott] theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b :=
iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H)

@[hott] theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d :=
calc
  a = b ↔ a - b = 0 : eq_iff_sub_eq_zero _ _
    ... ↔ c - d = 0 : by rwr H
    ... ↔ c = d     : iff.symm (eq_iff_sub_eq_zero c d)

@[hott] theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c :=
eq_add_neg_of_add_eq H

@[hott] theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c :=
add_neg_eq_of_eq_add H

@[hott] theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c :=
eq_add_of_add_neg_eq H

@[hott] theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
add_eq_of_eq_add_neg H

@[hott] def zero_unique {a : A} (H : Πb, a + b = b) : a = 0 :=
(add_zero _)⁻¹ ⬝ H 0

end add_inf_group

@[hott, class] def add_ab_inf_group : Type _ → Type _ := ab_inf_group

@[hott, reducible, instance] def add_inf_group_of_add_ab_inf_group (A : Type _)
  [H : add_ab_inf_group A] : add_inf_group A :=
@ab_inf_group.to_inf_group A H

@[hott, reducible, instance] def add_comm_inf_monoid_of_add_ab_inf_group (A : Type _)
  [H : add_ab_inf_group A] : add_comm_inf_monoid A :=
@ab_inf_group.to_comm_inf_monoid A H

section add_ab_inf_group
variable [s : add_ab_inf_group A]
include s

@[hott] theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c :=
by rwr add.comm; apply sub_add_eq_sub_sub_swap

@[hott] theorem neg_add_eq_sub (a b : A) : -a + b = b - a := add.comm _ _

@[hott] theorem neg_add (a b : A) : -(a + b) = -a + -b := add.comm (-b) (-a) ▸ neg_add_rev a b

@[hott] theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b := add.right_comm _ _ _

@[hott] theorem sub_sub (a b c : A) : a - b - c = a - (b + c) :=
by change a + -b + -c = _; rwr [add.assoc, ←neg_add]

@[hott] theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b :=
by rwr [sub_add_eq_sub_sub, (add.comm c a), add_sub_cancel]

@[hott] theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c :=
by apply eq_sub_of_add_eq; rwr add.comm; exact H

@[hott] theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c :=
by apply sub_eq_of_eq_add; rwr add.comm; exact H

@[hott] theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c :=
by rwr add.comm; apply eq_add_of_sub_eq; exact H

@[hott] theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c :=
by rwr add.comm; apply add_eq_of_eq_sub; exact H

@[hott] theorem sub_sub_self (a b : A) : a - (a - b) = b :=
by rwr [sub_eq_add_neg, neg_sub, add.comm, sub_add_cancel]

@[hott] theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) :=
by rwr [sub_add_eq_sub_sub, ←sub_add_eq_add_sub a c b, add_sub]

@[hott] theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) :=
by rwr [add_sub, sub_add_cancel] ⬝ add.comm _ _

@[hott] theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
by rwr [neg_sub, sub_neg_eq_add, neg_add_eq_sub]
end add_ab_inf_group

@[hott] def inf_group_of_add_inf_group (A : Type _) [G : add_inf_group A] : inf_group A :=
{ mul             := has_add.add,
  mul_assoc       := add.assoc,
  one             := has_zero.zero _,
  one_mul         := zero_add,
  mul_one         := add_zero,
  inv             := has_neg.neg,
  mul_left_inv    := add.left_inv }

@[hott] theorem add.comm4 [s : add_comm_inf_semigroup A] :
  Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
comm4 add.comm add.assoc

@[hott] def add1 [s : has_add A] [s' : has_one A] (a : A) : A := a + 1

@[hott] theorem add_comm_three [s : add_comm_inf_semigroup A] (a b c : A) : a + b + c = c + b + a :=
by rwr [add.comm a b, add.comm (b + a) c, add.assoc]

@[hott] theorem add_comm_four [s : add_comm_inf_semigroup A] (a b : A) :
  a + a + (b + b) = (a + b) + (a + b) :=
add.comm4 _ _ _ _

@[hott] theorem add_comm_middle [s : add_comm_inf_semigroup A] (a b c : A) :
  a + b + c = a + c + b :=
by rwr [add.assoc, add.comm b, ←add.assoc]

-- @[hott] theorem bit0_add_bit0 [s : add_comm_inf_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
--   add_comm_four _ _

-- @[hott] theorem bit0_add_bit0_helper [s : add_comm_inf_semigroup A] (a b t : A) (H : a + b = t) :
--         bit0 a + bit0 b = bit0 t :=
--   by rwr -H; apply bit0_add_bit0

-- @[hott] theorem bit1_add_bit0 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
--         bit1 a + bit0 b = bit1 (a + b) :=
--   begin
--     rwr [↑bit0, ↑bit1, add_comm_middle], congruence, apply add_comm_four
--   end

-- @[hott] theorem bit1_add_bit0_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t : A)
--         (H : a + b = t) : bit1 a + bit0 b = bit1 t :=
--   by rwr -H; apply bit1_add_bit0

-- @[hott] theorem bit0_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
--         bit0 a + bit1 b = bit1 (a + b) :=
--   by rwr [{bit0 a + bit1 b}add.comm,{a + b}add.comm]; exact bit1_add_bit0 b a

-- @[hott] theorem bit0_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t : A)
--         (H : a + b = t) : bit0 a + bit1 b = bit1 t :=
--   by rwr -H; apply bit0_add_bit1

-- @[hott] theorem bit1_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
--         bit1 a + bit1 b = bit0 (add1 (a + b)) :=
--   begin
--     rwr ↑[bit0, bit1, add1, add.assoc],
--     rwr [*add.assoc, {_ + (b + 1)}add.comm, {_ + (b + 1 + _)}add.comm,
--       {_ + (b + 1 + _ + _)}add.comm, *add.assoc, {1 + a}add.comm, -{b + (a + 1)}add.assoc,
--       {b + a}add.comm, *add.assoc]
--   end

-- @[hott] theorem bit1_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t s: A)
--         (H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s :=
--   begin rwr [←H2, ←H], apply bit1_add_bit1 end

-- @[hott] theorem bin_add_zero [s : add_inf_monoid A] (a : A) : a + zero = a := add_zero _

-- @[hott] theorem bin_zero_add [s : add_inf_monoid A] (a : A) : zero + a = a := zero_add _

-- @[hott] theorem one_add_bit0 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) : one + bit0 a = bit1 a :=
--   begin rwr ↑[bit0, bit1], rwr add.comm end

-- @[hott] theorem bit0_add_one [s : has_add A] [s' : has_one A] (a : A) : bit0 a + one = bit1 a :=
--   rfl

-- @[hott] theorem bit1_add_one [s : has_add A] [s' : has_one A] (a : A) : bit1 a + one = add1 (bit1 a) :=
--   rfl

-- @[hott] theorem bit1_add_one_helper [s : has_add A] [s' : has_one A] (a t : A) (H : add1 (bit1 a) = t) :
--         bit1 a + one = t :=
--   by rwr -H

-- @[hott] theorem one_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) :
--         one + bit1 a = add1 (bit1 a) := add.comm _ _

-- @[hott] theorem one_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a t : A)
--         (H : add1 (bit1 a) = t) : one + bit1 a = t :=
--   by rwr -H; apply one_add_bit1

-- @[hott] theorem add1_bit0 [s : has_add A] [s' : has_one A] (a : A) : add1 (bit0 a) = bit1 a :=
--   rfl

-- @[hott] theorem add1_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) :
--         add1 (bit1 a) = bit0 (add1 a) :=
--   begin
--     rwr ↑[add1, bit1, bit0],
--     rwr [add.assoc, add_comm_four]
--   end

-- @[hott] theorem add1_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a t : A) (H : add1 a = t) :
--         add1 (bit1 a) = bit0 t :=
--   by rwr -H; apply add1_bit1

-- @[hott] theorem add1_one [s : has_add A] [s' : has_one A] : add1 (one : A) = bit0 one :=
--   rfl

-- @[hott] theorem add1_zero [s : add_inf_monoid A] [s' : has_one A] : add1 (zero : A) = one :=
--   begin
--     rwr [↑add1, zero_add]
--   end

-- @[hott] theorem one_add_one [s : has_add A] [s' : has_one A] : (one : A) + one = bit0 one :=
--   rfl

-- @[hott] theorem subst_into_sum [s : has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
--         (prt : tl + tr = t) : l + r = t :=
--    by rwr [prl, prr, prt]

-- @[hott] theorem neg_zero_helper [s : add_inf_group A] (a : A) (H : a = 0) : - a = 0 :=
--   by rwr [H, neg_zero]

end algebra
end hott