/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Violeta Hernández Palacios, Grayson Burton, Floris van Doorn
-/
import data.set.intervals.ord_connected

/-!
# The covering relation

This file defines the covering relation in an order. `b` is said to cover `a` if `a < b` and there
is no element in between. We say that `b` weakly covers `a` if `a ≤ b` and there is no element
between `a` and `b`. In a partial order this is equivalent to `a ⋖ b ∨ a = b`, in a preorder this
is equivalent to `a ⋖ b ∨ (a ≤ b ∧ b ≤ a)`

## Notation

* `a ⋖ b` means that `b` covers `a`.
* `a ⩿ b` means that `b` weakly covers `a`.
-/

open set order_dual

variables {α β : Type*}

section weakly_covers

section preorder
variables [preorder α] [preorder β] {a b c: α}

/-- `wcovby a b` means that `a = b` or `b` covers `a`.
This means that `a ≤ b` and there is no element in between.
-/
def wcovby (a b : α) : Prop := a ≤ b ∧ ∀ ⦃c⦄, a < c → ¬ c < b

infix ` ⩿ `:50 := wcovby

lemma wcovby.le (h : a ⩿ b) : a ≤ b := h.1

lemma wcovby.refl (a : α) : a ⩿ a := ⟨le_rfl, λ c hc, hc.not_lt⟩
lemma wcovby.rfl : a ⩿ a := wcovby.refl a

protected lemma eq.wcovby (h : a = b) : a ⩿ b := h ▸ wcovby.rfl

lemma wcovby_of_le_of_le (h1 : a ≤ b) (h2 : b ≤ a) : a ⩿ b :=
⟨h1, λ c hac hcb, (hac.trans hcb).not_le h2⟩

alias wcovby_of_le_of_le ← has_le.le.wcovby_of_le

lemma wcovby.wcovby_iff_le (hab : a ⩿ b) : b ⩿ a ↔ b ≤ a :=
⟨λ h, h.le, λ h, h.wcovby_of_le hab.le⟩

lemma wcovby_of_eq_or_eq (hab : a ≤ b) (h : ∀ c, a ≤ c → c ≤ b → c = a ∨ c = b) : a ⩿ b :=
⟨hab, λ c ha hb, (h c ha.le hb.le).elim ha.ne' hb.ne⟩

/-- If `a ≤ b`, then `b` does not cover `a` iff there's an element in between. -/
lemma not_wcovby_iff (h : a ≤ b) : ¬ a ⩿ b ↔ ∃ c, a < c ∧ c < b :=
by simp_rw [wcovby, h, true_and, not_forall, exists_prop, not_not]

instance wcovby.is_refl : is_refl α (⩿) := ⟨wcovby.refl⟩

lemma wcovby.Ioo_eq (h : a ⩿ b) : Ioo a b = ∅ :=
eq_empty_iff_forall_not_mem.2 $ λ x hx, h.2 hx.1 hx.2

lemma wcovby.of_image (f : α ↪o β) (h : f a ⩿ f b) : a ⩿ b :=
⟨f.le_iff_le.mp h.le, λ c hac hcb, h.2 (f.lt_iff_lt.mpr hac) (f.lt_iff_lt.mpr hcb)⟩

lemma wcovby.image (f : α ↪o β) (hab : a ⩿ b) (h : (range f).ord_connected) : f a ⩿ f b :=
begin
  refine ⟨f.monotone hab.le, λ c ha hb, _⟩,
  obtain ⟨c, rfl⟩ := h.out (mem_range_self _) (mem_range_self _) ⟨ha.le, hb.le⟩,
  rw f.lt_iff_lt at ha hb,
  exact hab.2 ha hb,
end

lemma set.ord_connected.apply_wcovby_apply_iff (f : α ↪o β) (h : (range f).ord_connected) :
  f a ⩿ f b ↔ a ⩿ b :=
⟨λ h2, h2.of_image f, λ hab, hab.image f h⟩

@[simp] lemma apply_wcovby_apply_iff {E : Type*} [order_iso_class E α β] (e : E) :
  e a ⩿ e b ↔ a ⩿ b :=
(ord_connected_range (e : α ≃o β)).apply_wcovby_apply_iff ((e : α ≃o β) : α ↪o β)

@[simp] lemma to_dual_wcovby_to_dual_iff : to_dual b ⩿ to_dual a ↔ a ⩿ b :=
and_congr_right' $ forall_congr $ λ c, forall_swap

@[simp] lemma of_dual_wcovby_of_dual_iff {a b : αᵒᵈ} :
  of_dual a ⩿ of_dual b ↔ b ⩿ a :=
and_congr_right' $ forall_congr $ λ c, forall_swap

alias to_dual_wcovby_to_dual_iff ↔ _ wcovby.to_dual
alias of_dual_wcovby_of_dual_iff ↔ _ wcovby.of_dual

end preorder

section partial_order
variables [partial_order α] {a b c : α}

lemma wcovby.eq_or_eq (h : a ⩿ b) (h2 : a ≤ c) (h3 : c ≤ b) : c = a ∨ c = b :=
begin
  rcases h2.eq_or_lt with h2|h2, { exact or.inl h2.symm },
  rcases h3.eq_or_lt with h3|h3, { exact or.inr h3 },
  exact (h.2 h2 h3).elim
end

lemma wcovby.le_and_le_iff (h : a ⩿ b) : a ≤ c ∧ c ≤ b ↔ c = a ∨ c = b :=
begin
  refine ⟨λ h2, h.eq_or_eq h2.1 h2.2, _⟩, rintro (rfl|rfl), exacts [⟨le_rfl, h.le⟩, ⟨h.le, le_rfl⟩]
end

lemma wcovby.Icc_eq (h : a ⩿ b) : Icc a b = {a, b} :=
by { ext c, exact h.le_and_le_iff }

lemma wcovby.Ico_subset (h : a ⩿ b) : Ico a b ⊆ {a} :=
by rw [← Icc_diff_right, h.Icc_eq, diff_singleton_subset_iff, pair_comm]

lemma wcovby.Ioc_subset (h : a ⩿ b) : Ioc a b ⊆ {b} :=
by rw [← Icc_diff_left, h.Icc_eq, diff_singleton_subset_iff]

end partial_order

end weakly_covers

section has_lt
variables [has_lt α] {a b : α}

/-- `covby a b` means that `b` covers `a`: `a < b` and there is no element in between. -/
def covby (a b : α) : Prop := a < b ∧ ∀ ⦃c⦄, a < c → ¬ c < b

infix ` ⋖ `:50 := covby

lemma covby.lt (h : a ⋖ b) : a < b := h.1

/-- If `a < b`, then `b` does not cover `a` iff there's an element in between. -/
lemma not_covby_iff (h : a < b) : ¬a ⋖ b ↔ ∃ c, a < c ∧ c < b :=
by simp_rw [covby, h, true_and, not_forall, exists_prop, not_not]

alias not_covby_iff ↔ exists_lt_lt_of_not_covby _
alias exists_lt_lt_of_not_covby ← has_lt.lt.exists_lt_lt

/-- In a dense order, nothing covers anything. -/
lemma not_covby [densely_ordered α] : ¬ a ⋖ b :=
λ h, let ⟨c, hc⟩ := exists_between h.1 in h.2 hc.1 hc.2

lemma densely_ordered_iff_forall_not_covby : densely_ordered α ↔ ∀ a b : α, ¬ a ⋖ b :=
⟨λ h a b, @not_covby _ _ _ _ h, λ h, ⟨λ a b hab, exists_lt_lt_of_not_covby hab $ h _ _⟩⟩

@[simp] lemma to_dual_covby_to_dual_iff : to_dual b ⋖ to_dual a ↔ a ⋖ b :=
and_congr_right' $ forall_congr $ λ c, forall_swap

@[simp] lemma of_dual_covby_of_dual_iff {a b : αᵒᵈ} : of_dual a ⋖ of_dual b ↔ b ⋖ a :=
and_congr_right' $ forall_congr $ λ c, forall_swap

alias to_dual_covby_to_dual_iff ↔ _ covby.to_dual
alias of_dual_covby_of_dual_iff ↔ _ covby.of_dual

end has_lt

section preorder
variables [preorder α] [preorder β] {a b : α}

lemma covby.le (h : a ⋖ b) : a ≤ b := h.1.le
protected lemma covby.ne (h : a ⋖ b) : a ≠ b := h.lt.ne
lemma covby.ne' (h : a ⋖ b) : b ≠ a := h.lt.ne'

protected lemma covby.wcovby (h : a ⋖ b) : a ⩿ b := ⟨h.le, h.2⟩
lemma wcovby.covby_of_not_le (h : a ⩿ b) (h2 : ¬ b ≤ a) : a ⋖ b := ⟨h.le.lt_of_not_le h2, h.2⟩
lemma wcovby.covby_of_lt (h : a ⩿ b) (h2 : a < b) : a ⋖ b := ⟨h2, h.2⟩

lemma covby_iff_wcovby_and_lt : a ⋖ b ↔ a ⩿ b ∧ a < b :=
⟨λ h, ⟨h.wcovby, h.lt⟩, λ h, h.1.covby_of_lt h.2⟩

lemma covby_iff_wcovby_and_not_le : a ⋖ b ↔ a ⩿ b ∧ ¬ b ≤ a :=
⟨λ h, ⟨h.wcovby, h.lt.not_le⟩, λ h, h.1.covby_of_not_le h.2⟩

lemma wcovby_iff_covby_or_le_and_le : a ⩿ b ↔ a ⋖ b ∨ (a ≤ b ∧ b ≤ a) :=
⟨λ h, or_iff_not_imp_right.mpr $ λ h', h.covby_of_not_le $ λ hba, h' ⟨h.le, hba⟩,
  λ h', h'.elim (λ h, h.wcovby) (λ h, h.1.wcovby_of_le h.2)⟩

instance : is_nonstrict_strict_order α (⩿) (⋖) :=
⟨λ a b, covby_iff_wcovby_and_not_le.trans $ and_congr_right $ λ h, h.wcovby_iff_le.not.symm⟩

instance covby.is_irrefl : is_irrefl α (⋖) := ⟨λ a ha, ha.ne rfl⟩

lemma covby.Ioo_eq (h : a ⋖ b) : Ioo a b = ∅ :=
h.wcovby.Ioo_eq

lemma covby.of_image (f : α ↪o β) (h : f a ⋖ f b) : a ⋖ b :=
⟨f.lt_iff_lt.mp h.lt, λ c hac hcb, h.2 (f.lt_iff_lt.mpr hac) (f.lt_iff_lt.mpr hcb)⟩

lemma covby.image (f : α ↪o β) (hab : a ⋖ b) (h : (range f).ord_connected) : f a ⋖ f b :=
(hab.wcovby.image f h).covby_of_lt $ f.strict_mono hab.lt

lemma set.ord_connected.apply_covby_apply_iff (f : α ↪o β) (h : (range f).ord_connected) :
  f a ⋖ f b ↔ a ⋖ b :=
⟨covby.of_image f, λ hab, hab.image f h⟩

@[simp] lemma apply_covby_apply_iff {E : Type*} [order_iso_class E α β] (e : E) :
  e a ⋖ e b ↔ a ⋖ b :=
(ord_connected_range (e : α ≃o β)).apply_covby_apply_iff ((e : α ≃o β) : α ↪o β)

end preorder

section partial_order
variables [partial_order α] {a b : α}

lemma wcovby.covby_of_ne (h : a ⩿ b) (h2 : a ≠ b) : a ⋖ b := ⟨h.le.lt_of_ne h2, h.2⟩

lemma covby_iff_wcovby_and_ne : a ⋖ b ↔ a ⩿ b ∧ a ≠ b :=
⟨λ h, ⟨h.wcovby, h.ne⟩, λ h, h.1.covby_of_ne h.2⟩

lemma wcovby_iff_covby_or_eq : a ⩿ b ↔ a ⋖ b ∨ a = b :=
by rw [le_antisymm_iff, wcovby_iff_covby_or_le_and_le]

lemma covby.Ico_eq (h : a ⋖ b) : Ico a b = {a} :=
by rw [←Ioo_union_left h.lt, h.Ioo_eq, empty_union]

lemma covby.Ioc_eq (h : a ⋖ b) : Ioc a b = {b} :=
by rw [←Ioo_union_right h.lt, h.Ioo_eq, empty_union]

lemma covby.Icc_eq (h : a ⋖ b) : Icc a b = {a, b} :=
h.wcovby.Icc_eq

end partial_order

section linear_order
variables [linear_order α] {a b c : α}

lemma covby.Ioi_eq (h : a ⋖ b) : Ioi a = Ici b :=
by rw [← Ioo_union_Ici_eq_Ioi h.lt, h.Ioo_eq, empty_union]

lemma covby.Iio_eq (h : a ⋖ b) : Iio b = Iic a :=
by rw [← Iic_union_Ioo_eq_Iio h.lt, h.Ioo_eq, union_empty]

lemma wcovby.le_of_lt (hab : a ⩿ b) (hcb : c < b) : c ≤ a := not_lt.1 $ λ hac, hab.2 hac hcb
lemma wcovby.ge_of_gt (hab : a ⩿ b) (hac : a < c) : b ≤ c := not_lt.1 $ hab.2 hac
lemma covby.le_of_lt (hab : a ⋖ b) : c < b → c ≤ a := hab.wcovby.le_of_lt
lemma covby.ge_of_gt (hab : a ⋖ b) : a < c → b ≤ c := hab.wcovby.ge_of_gt

lemma covby.unique_left (ha : a ⋖ c) (hb : b ⋖ c) : a = b :=
(hb.le_of_lt ha.lt).antisymm $ ha.le_of_lt hb.lt

lemma covby.unique_right (hb : a ⋖ b) (hc : a ⋖ c) : b = c :=
(hb.ge_of_gt hc.lt).antisymm $ hc.ge_of_gt hb.lt

end linear_order

namespace set

lemma wcovby_insert (x : α) (s : set α) : s ⩿ insert x s :=
begin
  refine wcovby_of_eq_or_eq (subset_insert x s) (λ t hst h2t, _),
  by_cases h : x ∈ t,
  { exact or.inr (subset_antisymm h2t $ insert_subset.mpr ⟨h, hst⟩) },
  { refine or.inl (subset_antisymm _ hst),
    rwa [← diff_singleton_eq_self h, diff_singleton_subset_iff] }
end

lemma covby_insert {x : α} {s : set α} (hx : x ∉ s) : s ⋖ insert x s :=
(wcovby_insert x s).covby_of_lt $ ssubset_insert hx

end set

namespace prod
variables [partial_order α] [partial_order β] {a a₁ a₂ : α} {b b₁ b₂ : β} {x y : α × β}

@[simp] lemma swap_wcovby_swap : x.swap ⩿ y.swap ↔ x ⩿ y :=
apply_wcovby_apply_iff (order_iso.prod_comm : α × β ≃o β × α)

@[simp] lemma swap_covby_swap : x.swap ⋖ y.swap ↔ x ⋖ y :=
apply_covby_apply_iff (order_iso.prod_comm : α × β ≃o β × α)

lemma fst_eq_or_snd_eq_of_wcovby : x ⩿ y → x.1 = y.1 ∨ x.2 = y.2 :=
begin
  refine λ h, of_not_not (λ hab, _),
  push_neg at hab,
  exact h.2 (mk_lt_mk.2 $ or.inl ⟨hab.1.lt_of_le h.1.1, le_rfl⟩)
    (mk_lt_mk.2 $ or.inr ⟨le_rfl, hab.2.lt_of_le h.1.2⟩),
end

lemma _root_.wcovby.fst (h : x ⩿ y) : x.1 ⩿ y.1 :=
⟨h.1.1, λ c h₁ h₂, h.2 (mk_lt_mk_iff_left.2 h₁) ⟨⟨h₂.le, h.1.2⟩, λ hc, h₂.not_le hc.1⟩⟩

lemma _root_.wcovby.snd (h : x ⩿ y) : x.2 ⩿ y.2 :=
⟨h.1.2, λ c h₁ h₂, h.2 (mk_lt_mk_iff_right.2 h₁) ⟨⟨h.1.1, h₂.le⟩, λ hc, h₂.not_le hc.2⟩⟩

lemma mk_wcovby_mk_iff_left : (a₁, b) ⩿ (a₂, b) ↔ a₁ ⩿ a₂ :=
begin
  refine ⟨wcovby.fst, and.imp mk_le_mk_iff_left.2 $ λ h c h₁ h₂, _⟩,
  have : c.2 = b:= h₂.le.2.antisymm h₁.le.2,
  rw [←@prod.mk.eta _ _ c, this, mk_lt_mk_iff_left] at h₁ h₂,
  exact h h₁ h₂,
end

lemma mk_wcovby_mk_iff_right : (a, b₁) ⩿ (a, b₂) ↔ b₁ ⩿ b₂ :=
swap_wcovby_swap.trans mk_wcovby_mk_iff_left

lemma mk_covby_mk_iff_left : (a₁, b) ⋖ (a₂, b) ↔ a₁ ⋖ a₂ :=
by simp_rw [covby_iff_wcovby_and_lt, mk_wcovby_mk_iff_left, mk_lt_mk_iff_left]

lemma mk_covby_mk_iff_right : (a, b₁) ⋖ (a, b₂) ↔ b₁ ⋖ b₂ :=
by simp_rw [covby_iff_wcovby_and_lt, mk_wcovby_mk_iff_right, mk_lt_mk_iff_right]

lemma mk_wcovby_mk_iff : (a₁, b₁) ⩿ (a₂, b₂) ↔ a₁ ⩿ a₂ ∧ b₁ = b₂ ∨ b₁ ⩿ b₂ ∧ a₁ = a₂ :=
begin
  refine ⟨λ h, _, _⟩,
  { obtain rfl | rfl : a₁ = a₂ ∨ b₁ = b₂ := fst_eq_or_snd_eq_of_wcovby h,
    { exact or.inr ⟨mk_wcovby_mk_iff_right.1 h, rfl⟩ },
    { exact or.inl ⟨mk_wcovby_mk_iff_left.1 h, rfl⟩ } },
  { rintro (⟨h, rfl⟩ | ⟨h, rfl⟩),
    { exact mk_wcovby_mk_iff_left.2 h },
    { exact mk_wcovby_mk_iff_right.2 h } }
end

lemma mk_covby_mk_iff : (a₁, b₁) ⋖ (a₂, b₂) ↔ a₁ ⋖ a₂ ∧ b₁ = b₂ ∨ b₁ ⋖ b₂ ∧ a₁ = a₂ :=
begin
  refine ⟨λ h, _, _⟩,
  { obtain rfl | rfl : a₁ = a₂ ∨ b₁ = b₂ := fst_eq_or_snd_eq_of_wcovby h.wcovby,
    { exact or.inr ⟨mk_covby_mk_iff_right.1 h, rfl⟩ },
    { exact or.inl ⟨mk_covby_mk_iff_left.1 h, rfl⟩ } },
  { rintro (⟨h, rfl⟩ | ⟨h, rfl⟩),
    { exact mk_covby_mk_iff_left.2 h },
    { exact mk_covby_mk_iff_right.2 h } }
end

lemma wcovby_iff : x ⩿ y ↔ x.1 ⩿ y.1 ∧ x.2 = y.2 ∨ x.2 ⩿ y.2 ∧ x.1 = y.1 :=
by { cases x, cases y, exact mk_wcovby_mk_iff }

lemma covby_iff : x ⋖ y ↔ x.1 ⋖ y.1 ∧ x.2 = y.2 ∨ x.2 ⋖ y.2 ∧ x.1 = y.1 :=
by { cases x, cases y, exact mk_covby_mk_iff }

end prod


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johan Commelin

! This file was ported from Lean 3 source module algebra.group.with_one.defs
! leanprover-community/mathlib commit 995b47e555f1b6297c7cf16855f1023e355219fb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.WithBot
import Mathlib.Algebra.Ring.Defs
import Mathlib.Tactic.Lift

/-!
# Adjoining a zero/one to semigroups and related algebraic structures

This file contains different results about adjoining an element to an algebraic structure which then
behaves like a zero or a one. An example is adjoining a one to a semigroup to obtain a monoid. That
this provides an example of an adjunction is proved in `Algebra.Category.MonCat.Adjunctions`.

Another result says that adjoining to a group an element `zero` gives a `GroupWithZero`. For more
information about these structures (which are not that standard in informal mathematics, see
`Algebra.GroupWithZero.Basic`)

## Porting notes

In Lean 3, we use `id` here and there to get correct types of proofs. This is required because
`with_one` and `with_zero` are marked as `irreducible` at the end of `algebra.group.with_one.defs`,
so proofs that use `option α` instead of `with_one α` no longer typecheck. In Lean 4, both types are
plain `def`s, so we don't need these `id`s.
-/

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

/-- Add an extra element `1` to a type -/
@[to_additive "Add an extra element `0` to a type"]
def WithOne (α) :=
  Option α
#align with_one WithOne
#align with_zero WithZero

namespace WithOne

instance [Repr α] : Repr (WithZero α) :=
  ⟨fun o _ =>
    match o with
    | none => "0"
    | some a => "↑" ++ repr a⟩

@[to_additive]
instance [Repr α] : Repr (WithOne α) :=
  ⟨fun o _ =>
    match o with
    | none => "1"
    | some a => "↑" ++ repr a⟩

@[to_additive]
instance monad : Monad WithOne :=
  instMonadOption

@[to_additive]
instance one : One (WithOne α) :=
  ⟨none⟩
#align with_one.has_one WithOne.one
#align with_zero.has_zero WithZero.zero

@[to_additive]
instance mul [Mul α] : Mul (WithOne α) :=
  ⟨Option.liftOrGet (· * ·)⟩
#align with_one.has_mul WithOne.mul
#align with_zero.has_add WithZero.add

@[to_additive]
instance inv [Inv α] : Inv (WithOne α) :=
  ⟨fun a => Option.map Inv.inv a⟩
#align with_one.has_inv WithOne.inv
#align with_zero.has_neg WithZero.neg

@[to_additive]
instance involutiveInv [InvolutiveInv α] : InvolutiveInv (WithOne α) :=
  { WithOne.inv with
    inv_inv := fun a =>
      (Option.map_map _ _ _).trans <| by simp_rw [inv_comp_inv, Option.map_id, id] }

@[to_additive]
instance invOneClass [Inv α] : InvOneClass (WithOne α) :=
  { WithOne.one, WithOne.inv with inv_one := rfl }

@[to_additive]
instance inhabited : Inhabited (WithOne α) :=
  ⟨1⟩

@[to_additive]
instance nontrivial [Nonempty α] : Nontrivial (WithOne α) :=
  Option.nontrivial

-- porting note: this new declaration is here to make `((a : α): WithOne α)` have type `WithOne α`;
-- otherwise the coercion kicks in and it becomes `Option.some a : WithOne α` which
-- becomes `Option.some a : Option α`.
/-- The canonical map from `α` into `WithOne α` -/
@[to_additive (attr := coe) "The canonical map from `α` into `WithZero α`"]
def coe : α → WithOne α :=
  Option.some

@[to_additive]
instance coeTC : CoeTC α (WithOne α) :=
  ⟨coe⟩

/-- Recursor for `WithOne` using the preferred forms `1` and `↑a`. -/
@[to_additive (attr := elab_as_elim)
  "Recursor for `WithZero` using the preferred forms `0` and `↑a`."]
def recOneCoe {C : WithOne α → Sort _} (h₁ : C 1) (h₂ : ∀ a : α, C a) : ∀ n : WithOne α, C n
  | Option.none => h₁
  | Option.some x => h₂ x
#align with_one.rec_one_coe WithOne.recOneCoe
#align with_zero.rec_zero_coe WithZero.recZeroCoe

-- porting note: in Lean 3 the to-additivised declaration
-- would automatically get this; right now in Lean 4...I don't
-- know if it does or not, and I don't know how to check, so
-- I'll add it manually just to be sure.
attribute [elab_as_elim] WithZero.recZeroCoe

/-- Deconstruct a `x : WithOne α` to the underlying value in `α`, given a proof that `x ≠ 1`. -/
@[to_additive unzero
      "Deconstruct a `x : WithZero α` to the underlying value in `α`, given a proof that `x ≠ 0`."]
def unone {x : WithOne α} (hx : x ≠ 1) : α :=
  WithBot.unbot x hx
#align with_one.unone WithOne.unone
#align with_zero.unzero WithZero.unzero

@[to_additive (attr := simp) unzero_coe]
theorem unone_coe {x : α} (hx : (x : WithOne α) ≠ 1) : unone hx = x :=
  rfl
#align with_one.unone_coe WithOne.unone_coe
#align with_zero.unzero_coe WithZero.unzero_coe

@[to_additive (attr := simp) coe_unzero]
theorem coe_unone {x : WithOne α} (hx : x ≠ 1) : ↑(unone hx) = x :=
  WithBot.coe_unbot x hx
#align with_one.coe_unone WithOne.coe_unone
#align with_zero.coe_unzero WithZero.coe_unzero

-- porting note: in Lean 4 the `some_eq_coe` lemmas present in the lean 3 version
-- of this file are syntactic tautologies
#noalign with_one.some_eq_coe
#noalign with_zero.some_eq_coe

@[to_additive (attr := simp)]
theorem coe_ne_one {a : α} : (a : WithOne α) ≠ (1 : WithOne α) :=
  Option.some_ne_none a
#align with_one.coe_ne_one WithOne.coe_ne_one
#align with_zero.coe_ne_zero WithZero.coe_ne_zero

@[to_additive (attr := simp)]
theorem one_ne_coe {a : α} : (1 : WithOne α) ≠ a :=
  coe_ne_one.symm
#align with_one.one_ne_coe WithOne.one_ne_coe
#align with_zero.zero_ne_coe WithZero.zero_ne_coe

@[to_additive]
theorem ne_one_iff_exists {x : WithOne α} : x ≠ 1 ↔ ∃ a : α, ↑a = x :=
  Option.ne_none_iff_exists
#align with_one.ne_one_iff_exists WithOne.ne_one_iff_exists
#align with_zero.ne_zero_iff_exists WithZero.ne_zero_iff_exists

@[to_additive]
instance canLift : CanLift (WithOne α) α (↑) fun a => a ≠ 1 where
  prf _ := ne_one_iff_exists.1
#align with_one.can_lift WithOne.canLift
#align with_zero.can_lift WithZero.canLift

@[to_additive (attr := simp, norm_cast)]
theorem coe_inj {a b : α} : (a : WithOne α) = b ↔ a = b :=
  Option.some_inj
#align with_one.coe_inj WithOne.coe_inj
#align with_zero.coe_inj WithZero.coe_inj

@[to_additive (attr := elab_as_elim)]
protected theorem cases_on {P : WithOne α → Prop} : ∀ x : WithOne α, P 1 → (∀ a : α, P a) → P x :=
  Option.casesOn
#align with_one.cases_on WithOne.cases_on
#align with_zero.cases_on WithZero.cases_on

-- port note: I don't know if `elab_as_elim` is being added to the additivised declaration.
attribute [elab_as_elim] WithZero.cases_on

@[to_additive]
instance mulOneClass [Mul α] : MulOneClass (WithOne α) where
  mul := (· * ·)
  one := 1
  one_mul := (Option.liftOrGet_isLeftId _).1
  mul_one := (Option.liftOrGet_isRightId _).1

@[to_additive]
instance monoid [Semigroup α] : Monoid (WithOne α) :=
  { WithOne.mulOneClass with mul_assoc := (Option.liftOrGet_isAssociative _).1 }

@[to_additive]
instance commMonoid [CommSemigroup α] : CommMonoid (WithOne α) :=
  { WithOne.monoid with mul_comm := (Option.liftOrGet_isCommutative _).1 }

@[to_additive (attr := simp, norm_cast)]
theorem coe_mul [Mul α] (a b : α) : ((a * b : α) : WithOne α) = a * b :=
  rfl
#align with_one.coe_mul WithOne.coe_mul
#align with_zero.coe_add WithZero.coe_add

@[to_additive (attr := simp, norm_cast)]
theorem coe_inv [Inv α] (a : α) : ((a⁻¹ : α) : WithOne α) = (a : WithOne α)⁻¹ :=
  rfl
#align with_one.coe_inv WithOne.coe_inv
#align with_zero.coe_neg WithZero.coe_neg

end WithOne

namespace WithZero

instance one [one : One α] : One (WithZero α) :=
  { one with }

@[simp, norm_cast]
theorem coe_one [One α] : ((1 : α) : WithZero α) = 1 :=
  rfl
#align with_zero.coe_one WithZero.coe_one

instance mulZeroClass [Mul α] : MulZeroClass (WithZero α) :=
  { WithZero.zero with
    mul := Option.map₂ (· * ·),
    zero_mul := Option.map₂_none_left (· * ·),
    mul_zero := Option.map₂_none_right (· * ·) }

@[simp, norm_cast]
theorem coe_mul {α : Type u} [Mul α] {a b : α} : ((a * b : α) : WithZero α) = a * b :=
  rfl
#align with_zero.coe_mul WithZero.coe_mul

instance noZeroDivisors [Mul α] : NoZeroDivisors (WithZero α) :=
  ⟨Option.map₂_eq_none_iff.1⟩

instance semigroupWithZero [Semigroup α] : SemigroupWithZero (WithZero α) :=
  { WithZero.mulZeroClass with
    mul_assoc := fun _ _ _ => Option.map₂_assoc mul_assoc }

instance commSemigroup [CommSemigroup α] : CommSemigroup (WithZero α) :=
  { WithZero.semigroupWithZero with
    mul_comm := fun _ _ => Option.map₂_comm mul_comm }

instance mulZeroOneClass [MulOneClass α] : MulZeroOneClass (WithZero α) :=
  { WithZero.mulZeroClass, WithZero.one with
    one_mul := Option.map₂_left_identity one_mul,
    mul_one := Option.map₂_right_identity mul_one }

instance pow [One α] [Pow α ℕ] : Pow (WithZero α) ℕ :=
  ⟨fun x n =>
    match x, n with
    | none, 0 => 1
    | none, _ + 1 => 0
    | some x, n => ↑(x ^ n)⟩

@[simp, norm_cast]
theorem coe_pow [One α] [Pow α ℕ] {a : α} (n : ℕ) :
    ↑(a ^ n : α) = ((a : WithZero α) ^ n : WithZero α) :=
  rfl
#align with_zero.coe_pow WithZero.coe_pow

instance monoidWithZero [Monoid α] : MonoidWithZero (WithZero α) :=
  { WithZero.mulZeroOneClass, WithZero.semigroupWithZero with
    npow := fun n x => x ^ n,
    npow_zero := fun x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| pow_zero x,
    npow_succ := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| pow_succ x n }

instance commMonoidWithZero [CommMonoid α] : CommMonoidWithZero (WithZero α) :=
  { WithZero.monoidWithZero, WithZero.commSemigroup with }

/-- Given an inverse operation on `α` there is an inverse operation
  on `WithZero α` sending `0` to `0`. -/
instance inv [Inv α] : Inv (WithZero α) :=
  ⟨fun a => Option.map Inv.inv a⟩

@[simp, norm_cast]
theorem coe_inv [Inv α] (a : α) : ((a⁻¹ : α) : WithZero α) = (↑a)⁻¹ :=
  rfl
#align with_zero.coe_inv WithZero.coe_inv

@[simp]
theorem inv_zero [Inv α] : (0 : WithZero α)⁻¹ = 0 :=
  rfl
#align with_zero.inv_zero WithZero.inv_zero

instance involutiveInv [InvolutiveInv α] : InvolutiveInv (WithZero α) :=
  { WithZero.inv with
    inv_inv := fun a =>
      (Option.map_map _ _ _).trans <| by simp_rw [inv_comp_inv, Option.map_id, id] }

instance invOneClass [InvOneClass α] : InvOneClass (WithZero α) :=
  { WithZero.one, WithZero.inv with inv_one := show ((1⁻¹ : α) : WithZero α) = 1 by simp }

instance div [Div α] : Div (WithZero α) :=
  ⟨Option.map₂ (· / ·)⟩

@[norm_cast]
theorem coe_div [Div α] (a b : α) : ↑(a / b : α) = (a / b : WithZero α) :=
  rfl
#align with_zero.coe_div WithZero.coe_div

instance [One α] [Pow α ℤ] : Pow (WithZero α) ℤ :=
  ⟨fun x n =>
    match x, n with
    | none, Int.ofNat 0 => 1
    | none, Int.ofNat (Nat.succ _) => 0
    | none, Int.negSucc _ => 0
    | some x, n => ↑(x ^ n)⟩

@[simp, norm_cast]
theorem coe_zpow [DivInvMonoid α] {a : α} (n : ℤ) : ↑(a ^ n : α) = ((↑a : WithZero α) ^ n) :=
  rfl
#align with_zero.coe_zpow WithZero.coe_zpow

instance divInvMonoid [DivInvMonoid α] : DivInvMonoid (WithZero α) :=
  { WithZero.div, WithZero.inv, WithZero.monoidWithZero with
    div_eq_mul_inv := fun a b =>
      match a, b with
      | none, _ => rfl
      | some _, none => rfl
      | some a, some b => congr_arg some (div_eq_mul_inv a b),
    zpow := fun n x => x ^ n,
    zpow_zero' := fun x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| zpow_zero x,
    zpow_succ' := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| DivInvMonoid.zpow_succ' n x,
    zpow_neg' := fun n x =>
      match x with
      | none => rfl
      | some x => congr_arg some <| DivInvMonoid.zpow_neg' n x }

instance divInvOneMonoid [DivInvOneMonoid α] : DivInvOneMonoid (WithZero α) :=
  { WithZero.divInvMonoid, WithZero.invOneClass with }

instance divisionMonoid [DivisionMonoid α] : DivisionMonoid (WithZero α) :=
  { WithZero.divInvMonoid, WithZero.involutiveInv with
    mul_inv_rev := fun a b =>
      match a, b with
      | none, none => rfl
      | none, some b => rfl
      | some a, none => rfl
      | some a, some b => congr_arg some <| mul_inv_rev _ _,
    inv_eq_of_mul := fun a b ↦
      match a, b with
      | none, none => fun _ ↦ rfl
      | none, some b => fun _ ↦ by contradiction
      | some a, none => fun _ ↦ by contradiction
      | some a, some b => fun h ↦
        congr_arg some <| inv_eq_of_mul_eq_one_right <| Option.some_injective _ h }

instance divisionCommMonoid [DivisionCommMonoid α] : DivisionCommMonoid (WithZero α) :=
  { WithZero.divisionMonoid, WithZero.commSemigroup with }

section Group

variable [Group α]

/-- if `G` is a group then `WithZero G` is a group with zero. -/
instance groupWithZero : GroupWithZero (WithZero α) :=
  { WithZero.monoidWithZero, WithZero.divInvMonoid, WithZero.nontrivial with
    inv_zero := inv_zero,
    mul_inv_cancel := fun a ha ↦ by
      lift a to α using ha
      norm_cast
      apply mul_right_inv }

end Group

instance commGroupWithZero [CommGroup α] : CommGroupWithZero (WithZero α) :=
  { WithZero.groupWithZero, WithZero.commMonoidWithZero with }

instance addMonoidWithOne [AddMonoidWithOne α] : AddMonoidWithOne (WithZero α) :=
  { WithZero.addMonoid, WithZero.one with
    natCast := fun n => if n = 0 then 0 else (n.cast : α),
    natCast_zero := rfl,
    natCast_succ := fun n => by
      cases n with
      | zero => show (((1 : ℕ) : α) : WithZero α) = 0 + 1; · rw [Nat.cast_one, coe_one, zero_add]
      | succ n =>
          show (((n + 2 : ℕ) : α) : WithZero α) = ((n + 1 : ℕ) : α) + 1
          rw [Nat.cast_succ, coe_add, coe_one]
      }

instance semiring [Semiring α] : Semiring (WithZero α) :=
  { WithZero.addMonoidWithOne, WithZero.addCommMonoid, WithZero.mulZeroClass,
    WithZero.monoidWithZero with
    left_distrib := fun a b c => by
      cases' a with a; · rfl
      cases' b with b <;> cases' c with c <;> try rfl
      exact congr_arg some (left_distrib _ _ _),
    right_distrib := fun a b c => by
      cases' c with c
      · change (a + b) * 0 = a * 0 + b * 0
        simp
      cases' a with a <;> cases' b with b <;> try rfl
      exact congr_arg some (right_distrib _ _ _) }

end WithZero


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.set.finite group_theory.coset

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

/-- Typeclass for types with a scalar multiplication operation, denoted `•` (`\bu`) -/
class has_scalar (α : Type u) (γ : Type v) := (smul : α → γ → γ)

infixr ` • `:73 := has_scalar.smul

/-- Typeclass for multiplictive actions by monoids. This generalizes group actions. -/
class mul_action (α : Type u) (β : Type v) [monoid α] extends has_scalar α β :=
(one_smul : ∀ b : β, (1 : α) • b = b)
(mul_smul : ∀ (x y : α) (b : β), (x * y) • b = x • y • b)

section
variables [monoid α] [mul_action α β]

theorem mul_smul (a₁ a₂ : α) (b : β) : (a₁ * a₂) • b = a₁ • a₂ • b := mul_action.mul_smul _ _ _

variable (α)
@[simp] theorem one_smul (b : β) : (1 : α) • b = b := mul_action.one_smul α _

end

namespace mul_action

variables (α) [monoid α] [mul_action α β]

def orbit (b : β) := set.range (λ x : α, x • b)

variable {α}

@[simp] lemma mem_orbit_iff {b₁ b₂ : β} : b₂ ∈ orbit α b₁ ↔ ∃ x : α, x • b₁ = b₂ :=
iff.rfl

@[simp] lemma mem_orbit (b : β) (x : α) : x • b ∈ orbit α b :=
⟨x, rfl⟩

@[simp] lemma mem_orbit_self (b : β) : b ∈ orbit α b :=
⟨1, by simp [mul_action.one_smul]⟩

instance orbit_fintype (b : β) [fintype α] [decidable_eq β] :
  fintype (orbit α b) := set.fintype_range _

variable (α)

def stabilizer (b : β) : set α :=
{x : α | x • b = b}

variable {α}

@[simp] lemma mem_stabilizer_iff {b : β} {x : α} :
  x ∈ stabilizer α b ↔ x • b = b := iff.rfl

variables (α) (β)

def fixed_points : set β := {b : β | ∀ x, x ∈ stabilizer α b}

variables {α} (β)

@[simp] lemma mem_fixed_points {b : β} :
  b ∈ fixed_points α β ↔ ∀ x : α, x • b = b := iff.rfl

lemma mem_fixed_points' {b : β} : b ∈ fixed_points α β ↔
  (∀ b', b' ∈ orbit α b → b' = b) :=
⟨λ h b h₁, let ⟨x, hx⟩ := mem_orbit_iff.1 h₁ in hx ▸ h x,
λ h b, mem_stabilizer_iff.2 (h _ (mem_orbit _ _))⟩

def comp_hom [monoid γ] (g : γ → α) [is_monoid_hom g] :
  mul_action γ β :=
{ smul := λ x b, (g x) • b,
  one_smul := by simp [is_monoid_hom.map_one g, mul_action.one_smul],
  mul_smul := by simp [is_monoid_hom.map_mul g, mul_action.mul_smul] }

end mul_action

namespace mul_action
variables [group α] [mul_action α β]

section
open mul_action quotient_group

variables (α) (β)

def to_perm (g : α) : equiv.perm β :=
{ to_fun := (•) g,
  inv_fun := (•) g⁻¹,
  left_inv := λ a, by rw [← mul_action.mul_smul, inv_mul_self, mul_action.one_smul],
  right_inv := λ a, by rw [← mul_action.mul_smul, mul_inv_self, mul_action.one_smul] }

variables {α} {β}

instance : is_group_hom (to_perm α β) :=
{ mul := λ x y, equiv.ext _ _ (λ a, mul_action.mul_smul x y a) }

lemma bijective (g : α) : function.bijective (λ b : β, g • b) :=
(to_perm α β g).bijective

lemma orbit_eq_iff {a b : β} :
   orbit α a = orbit α b ↔ a ∈ orbit α b:=
⟨λ h, h ▸ mem_orbit_self _,
λ ⟨x, (hx : x • b = a)⟩, set.ext (λ c, ⟨λ ⟨y, (hy : y • a = c)⟩, ⟨y * x,
  show (y * x) • b = c, by rwa [mul_action.mul_smul, hx]⟩,
  λ ⟨y, (hy : y • b = c)⟩, ⟨y * x⁻¹,
    show (y * x⁻¹) • a = c, by
      conv {to_rhs, rw [← hy, ← mul_one y, ← inv_mul_self x, ← mul_assoc,
        mul_action.mul_smul, hx]}⟩⟩)⟩

instance (b : β) : is_subgroup (stabilizer α b) :=
{ one_mem := mul_action.one_smul _ _,
  mul_mem := λ x y (hx : x • b = b) (hy : y • b = b),
    show (x * y) • b = b, by rw mul_action.mul_smul; simp *,
  inv_mem := λ x (hx : x • b = b), show x⁻¹ • b = b,
    by rw [← hx, ← mul_action.mul_smul, inv_mul_self, mul_action.one_smul, hx] }

variables (α) (β)

def orbit_rel : setoid β :=
{ r := λ a b, a ∈ orbit α b,
  iseqv := ⟨mem_orbit_self, λ a b, by simp [orbit_eq_iff.symm, eq_comm],
    λ a b, by simp [orbit_eq_iff.symm, eq_comm] {contextual := tt}⟩ }

variables {β}

open quotient_group

noncomputable def orbit_equiv_quotient_stabilizer (b : β) :
  orbit α b ≃ quotient (stabilizer α b) :=
equiv.symm (@equiv.of_bijective _ _
  (λ x : quotient (stabilizer α b), quotient.lift_on' x
    (λ x, (⟨x • b, mem_orbit _ _⟩ : orbit α b))
    (λ g h (H : _ = _), subtype.eq $ (mul_action.bijective (g⁻¹)).1
      $ show g⁻¹ • (g • b) = g⁻¹ • (h • b),
      by rw [← mul_action.mul_smul, ← mul_action.mul_smul,
        H, inv_mul_self, mul_action.one_smul]))
⟨λ g h, quotient.induction_on₂' g h (λ g h H, quotient.sound' $
  have H : g • b = h • b := subtype.mk.inj H,
  show (g⁻¹ * h) • b = b,
  by rw [mul_action.mul_smul, ← H, ← mul_action.mul_smul, inv_mul_self, mul_action.one_smul]),
  λ ⟨b, ⟨g, hgb⟩⟩, ⟨g, subtype.eq hgb⟩⟩)

end

open quotient_group mul_action is_subgroup

def mul_left_cosets (H : set α) [is_subgroup H]
  (x : α) (y : quotient H) : quotient H :=
quotient.lift_on' y (λ y, quotient_group.mk ((x : α) * y))
  (λ a b (hab : _ ∈ H), quotient_group.eq.2
    (by rwa [mul_inv_rev, ← mul_assoc, mul_assoc (a⁻¹), inv_mul_self, mul_one]))

instance (H : set α) [is_subgroup H] : mul_action α (quotient H) :=
{ smul := mul_left_cosets H,
  one_smul := λ a, quotient.induction_on' a (λ a, quotient_group.eq.2
    (by simp [is_submonoid.one_mem])),
  mul_smul := λ x y a, quotient.induction_on' a (λ a, quotient_group.eq.2
    (by simp [mul_inv_rev, is_submonoid.one_mem, mul_assoc])) }

instance mul_left_cosets_comp_subtype_val (H I : set α) [is_subgroup H] [is_subgroup I] :
  mul_action I (quotient H) :=
mul_action.comp_hom (quotient H) (subtype.val : I → α)

end mul_action

/-- Typeclass for multiplicative actions on additive structures. This generalizes group modules. -/
class distrib_mul_action (α : Type u) (β : Type v) [monoid α] [add_monoid β] extends mul_action α β :=
(smul_add : ∀(r : α) (x y : β), r • (x + y) = r • x + r • y)
(smul_zero {} : ∀(r : α), r • (0 : β) = 0)

section
variables [monoid α] [add_monoid β] [distrib_mul_action α β]

theorem smul_add (a : α) (b₁ b₂ : β) : a • (b₁ + b₂) = a • b₁ + a • b₂ :=
distrib_mul_action.smul_add _ _ _

@[simp] theorem smul_zero (a : α) : a • (0 : β) = 0 :=
distrib_mul_action.smul_zero _

end


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

! This file was ported from Lean 3 source module data.fintype.prod
! leanprover-community/mathlib commit 509de852e1de55e1efa8eacfa11df0823f26f226
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Card
import Mathlib.Data.Finset.Prod

/-!
# fintype instance for the product of two fintypes.

-/

open Function

open Nat

universe u v

variable {α β γ : Type _}

open Finset Function

namespace Set

variable {s t : Set α}

theorem toFinset_prod (s : Set α) (t : Set β) [Fintype s] [Fintype t] [Fintype (s ×ˢ t)] :
    (s ×ˢ t).toFinset = s.toFinset ×ᶠ t.toFinset := by
  ext
  simp
#align set.to_finset_prod Set.toFinset_prod

theorem toFinset_off_diag {s : Set α} [DecidableEq α] [Fintype s] [Fintype s.offDiag] :
    s.offDiag.toFinset = s.toFinset.offDiag :=
  Finset.ext <| by simp
#align set.to_finset_off_diag Set.toFinset_off_diag

end Set

instance (α β : Type _) [Fintype α] [Fintype β] : Fintype (α × β) :=
  ⟨univ ×ᶠ univ, fun ⟨a, b⟩ => by simp⟩

@[simp]
theorem Finset.univ_product_univ {α β : Type _} [Fintype α] [Fintype β] :
    (univ : Finset α) ×ᶠ (univ : Finset β) = univ :=
  rfl
#align finset.univ_product_univ Finset.univ_product_univ

@[simp]
theorem Fintype.card_prod (α β : Type _) [Fintype α] [Fintype β] :
    Fintype.card (α × β) = Fintype.card α * Fintype.card β :=
  card_product _ _
#align fintype.card_prod Fintype.card_prod

section

open Classical

@[simp]
theorem infinite_prod : Infinite (α × β) ↔ Infinite α ∧ Nonempty β ∨ Nonempty α ∧ Infinite β := by
  refine'
    ⟨fun H => _, fun H =>
      H.elim (and_imp.2 <| @Prod.infinite_of_left α β) (and_imp.2 <| @Prod.infinite_of_right α β)⟩
  rw [and_comm]; contrapose! H; intro H'
  rcases Infinite.nonempty (α × β) with ⟨a, b⟩
  haveI := fintypeOfNotInfinite (H.1 ⟨b⟩); haveI := fintypeOfNotInfinite (H.2 ⟨a⟩)
  exact H'.false
#align infinite_prod infinite_prod

instance Pi.infinite_of_left {ι : Sort _} {π : ι → Sort _} [∀ i, Nontrivial <| π i] [Infinite ι] :
    Infinite (∀ i : ι, π i) := by
  choose m n hm using fun i => exists_pair_ne (π i)
  refine' Infinite.of_injective (fun i => update m i (n i)) fun x y h => of_not_not fun hne => _
  simp_rw [update_eq_iff, update_noteq hne] at h
  exact (hm x h.1.symm).elim
#align pi.infinite_of_left Pi.infinite_of_left

/-- If at least one `π i` is infinite and the rest nonempty, the pi type of all `π` is infinite. -/
theorem Pi.infinite_of_exists_right {ι : Type _} {π : ι → Type _} (i : ι) [Infinite <| π i]
    [∀ i, Nonempty <| π i] : Infinite (∀ i : ι, π i) :=
  let ⟨m⟩ := @Pi.Nonempty ι π _
  Infinite.of_injective _ (update_injective m i)
#align pi.infinite_of_exists_right Pi.infinite_of_exists_right

/-- See `Pi.infinite_of_exists_right` for the case that only one `π i` is infinite. -/
instance Pi.infinite_of_right {ι : Sort _} {π : ι → Sort _} [∀ i, Infinite <| π i] [Nonempty ι] :
    Infinite (∀ i : ι, π i) :=
  Pi.infinite_of_exists_right (Classical.arbitrary ι)
#align pi.infinite_of_right Pi.infinite_of_right

/-- Non-dependent version of `Pi.infinite_of_left`. -/
instance Function.infinite_of_left {ι π : Sort _} [Nontrivial π] [Infinite ι] : Infinite (ι → π) :=
  Pi.infinite_of_left
#align function.infinite_of_left Function.infinite_of_left

/-- Non-dependent version of `Pi.infinite_of_exists_right` and `Pi.infinite_of_right`. -/
instance Function.infinite_of_right {ι π : Sort _} [Infinite π] [Nonempty ι] : Infinite (ι → π) :=
  Pi.infinite_of_right
#align function.infinite_of_right Function.infinite_of_right

end


import field_theory.finite.basic
import data.bitvec.basic
import algebra.group_with_zero
import tactic.omega

open_locale big_operators

/-
bool
-/

attribute [simp] bool.to_nat

/-
int
-/

namespace int

lemma abs_le_of_dvd {i j : int} (h : i ∣ j) (h' : 0 < j) : abs i ≤ j :=
int.le_of_dvd h' ((abs_dvd _ _).mpr h)

theorem modeq_iff_sub_mod_eq_zero {i j m : ℤ} : i ≡ j [ZMOD m] ↔ (i - j) % m = 0 :=
by rw [int.modeq_iff_dvd, ←neg_sub, dvd_neg, int.dvd_iff_mod_eq_zero]

theorem modeq_zero_iff {i m : ℤ} : i ≡ 0 [ZMOD m] ↔ i % m = 0 :=
by rw [modeq_iff_sub_mod_eq_zero, sub_zero]

end int

/-
For casts from `nat` to `int`, `push_neg` does not always do the right thing on
large numbers. This is a more restricted version.
-/

mk_simp_attribute int_cast_simps "rules for pushing integer casts downwards"

attribute [int_cast_simps] int.coe_nat_zero int.coe_nat_one int.coe_nat_bit0 int.coe_nat_bit1
  int.coe_nat_add int.coe_nat_pow
  int.cast_add int.cast_mul int.cast_sub int.cast_bit0 int.cast_bit1 int.cast_zero int.cast_one

meta def simp_int_casts : tactic unit := `[ simp only with int_cast_simps ]

/-
option
-/

namespace option

def agrees {α : Type*} : option α → α → Prop
| (some a) b := a = b
| none     _ := true

def fn_extends {α β : Type*} (f : α → β) (f' : α → option β) : Prop :=
∀ x, (f' x).agrees (f x)

theorem eq_of_fn_extends {α β : Type*} {f : α → β} {f' : α → option β}
  (h : fn_extends f f') {a : α} {b : β} (h' : f' a = some b) : f a = b :=
by { symmetry, have := h a, rwa h' at this }

end option

/-
vector
-/

namespace vector

variables {α : Type*}

theorem reverse_cons {n : ℕ} (a : α) (v : vector α n) :
  reverse (cons a v) = append (reverse v) (cons a nil) :=
by { apply to_list_injective, simp [reverse] }

theorem append_nil {n : ℕ} (v : vector α n) :
  append v nil = v :=
by { apply to_list_injective, simp }

end vector

/-
fin
-/

namespace fin

theorem eq_cast_succ_or_eq_last {n : ℕ} (i : fin (n + 1)) :
  (∃ j, i = cast_succ j) ∨ i = last n :=
begin
  cases (lt_or_eq_of_le (le_last i)) with h h,
  { use ⟨i.1, h⟩, ext, refl },
  right, exact h
end

lemma exists_fin_cast_succ {n : ℕ} {P : fin (n + 1) → Prop} :
  (∃ i, P i) ↔ ((∃ i : fin n, P i.cast_succ) ∨ P (fin.last n)) :=
begin
  split,
  { rintros ⟨i, hi⟩,
    rcases eq_cast_succ_or_eq_last i with ⟨j, rfl⟩ | rfl,
    { left, use j, assumption },
    right, assumption },
  rintros (⟨i, h⟩ | h); exact exists.intro _ h
end

@[simp] def rev {n : ℕ} : fin n → fin n
| ⟨i, h⟩ := ⟨n - i.succ, by omega⟩

@[simp] theorem rev_rev {n : ℕ} (i : fin n) : rev (rev i) = i :=
by { cases i with i h, unfold rev, ext, dsimp, omega }

@[simp] theorem coe_rev {n : ℕ} (i : fin n) : (i.rev : ℕ) = n - i.succ :=
by { cases i with i h, refl }

@[simp] theorem rev_zero {n : ℕ} : (0 : fin (n + 1)).rev = last n :=
by refl

@[simp] theorem rev_last {n : ℕ} : (last n).rev = 0 :=
by { rw [←rev_zero, rev_rev] }

theorem cast_succ_add_one_rev {n : ℕ} {i : fin n} :
  (cast_succ i + 1).rev + 1 = (cast_succ i).rev :=
begin
  cases i with i' h',
  ext,
  simp [coe_add, coe_rev, coe_one'],
  rw [@nat.mod_eq_of_lt (i' + 1), nat.mod_eq_of_lt]; omega
end

theorem cast_succ_rev {n : ℕ} (i : fin n) :
  i.rev.cast_succ = i.succ.rev :=
by { cases i with i' h', ext, simp }

theorem rev_cast_succ {n : ℕ} (i : fin n) :
  i.cast_succ.rev = i.rev.succ :=
by conv { to_lhs, rw [← rev_rev i, cast_succ_rev, rev_rev] }

theorem rev_lt_rev_iff {n : ℕ} (i j : fin n) : rev i < rev j ↔ j < i :=
begin
  cases i with i ih, cases j with j jh, rw [rev, rev],
  transitivity,
  apply tsub_lt_tsub_iff_left_of_le (nat.succ_le_of_lt ih),
  exact ⟨nat.lt_of_succ_lt_succ, nat.succ_lt_succ⟩
end

theorem rev_le_rev_iff {n : ℕ} (i j : fin n) : rev i ≤ rev j ↔ j ≤ i :=
begin
  cases i with i ih, cases j with j jh, rw [rev, rev],
  transitivity,
  apply tsub_le_tsub_iff_left (nat.succ_le_of_lt jh),
  apply nat.succ_le_succ_iff
end

theorem add_one_le_of_lt {n : ℕ} {i j : fin (n + 1)} (h : i < j) : i + 1 ≤ j :=
begin
  cases i with i hi,
  cases j with j hj,
  simp [fin.le_def, fin.coe_add, fin.coe_one'],
  rw nat.mod_eq_of_lt,
  { apply nat.succ_le_of_lt h },
  apply lt_of_le_of_lt (nat.succ_le_of_lt h) hj
end

theorem eq_zero_of_le_zero {n : ℕ} {i : fin (n + 1)} (h : i ≤ 0) : i = 0 :=
by { cases i, ext, apply nat.eq_zero_of_le_zero h }

theorem of_le_succ {n : ℕ} {i : fin (n + 1)} {j : fin n} (h : i ≤ j.succ) :
  i ≤ j.cast_succ ∨ i = j.succ :=
begin
  cases i, cases j,
  simp [fin.succ] at *,
  exact nat.of_le_succ h
end

theorem le_of_lt_succ {n : ℕ} {i : fin (n + 1)} {j : fin n} (h : i < j.succ) : i ≤ j.cast_succ :=
by { cases i, cases j, exact nat.le_of_lt_succ h}

theorem cast_succ_lt_succ_iff {n : ℕ} (i j : fin n) :
  i.cast_succ < j.succ ↔ i.cast_succ ≤ j.cast_succ :=
by { cases i, cases j, apply nat.lt_succ_iff }

@[simp] theorem cast_succ_le_cast_succ_iff {n : ℕ} (i j : fin n) :
  i.cast_succ ≤ j.cast_succ ↔ i ≤ j :=
by { cases i, cases j, refl }

theorem one_eq_succ_zero {n : ℕ} : (1 : fin (n + 2)) = fin.succ 0 := rfl

theorem le_zero_iff {n : ℕ} (i : fin (n + 1)) : i ≤ 0 ↔ i = 0 :=
by { rw [fin.ext_iff, fin.le_def], cases i, apply le_zero_iff }

lemma last_zero : fin.last 0 = 0 :=
by { ext, refl }

/-- This lemma is useful for rewriting `fin (n + 1)` as `fin (m + j + 1)`,
    given `i : fin (n + 1)` and `m = ↑i`. -/
lemma exists_eq_add {n : ℕ} (i : fin (n + 1)) : ∃ m j, m = ↑i ∧ n = m + j :=
begin
  cases nat.exists_eq_add_of_le (nat.le_of_lt_succ i.2) with j hj,
  use [↑i, j, rfl, hj]
end

def cast_offset {n : ℕ} (m : ℕ) (i : fin n) : fin (m + n) :=
⟨m + ↑i, add_lt_add_left i.is_lt _⟩

def cast_offset' {n : ℕ} (m : ℕ) (j : fin (n + 1)) : fin (m + n + 1) :=
@cast_offset (n + 1) m j

theorem cast_succ_cast_offset {n m : ℕ} (i : fin n) :
  fin.cast_offset m i.cast_succ = (fin.cast_offset m i).cast_succ :=
by { cases i, refl }

theorem succ_cast_offset {n m : ℕ} (i : fin n) :
  fin.cast_offset m i.succ = (fin.cast_offset m i).succ :=
by {cases i, refl }

section

variable {n : ℕ}

def range (i : fin (n + 1)) : finset (fin n) :=
finset.univ.filter (λ j, j.cast_succ < i)

@[simp] theorem mem_range (i : fin n) (j : fin (n + 1)) : i ∈ range j ↔ i.cast_succ < j :=
by simp [range]

@[simp] theorem range_zero : range (0 : fin (n + 1)) = ∅ :=
by { ext i, simp [range, fin.zero_le] }

@[simp] theorem range_one : range (1 : fin (n + 2)) = {(0 : fin (n + 1))} :=
begin
  ext i,
  rw [mem_range, finset.mem_singleton, one_eq_succ_zero, cast_succ_lt_succ_iff,
       cast_succ_le_cast_succ_iff, le_zero_iff]
end

theorem range_succ (i : fin n) : range i.succ = insert i (range i.cast_succ) :=
begin
  ext j,
  rw [mem_range, finset.mem_insert, mem_range, cast_succ_lt_succ_iff, le_iff_lt_or_eq,
       cast_succ_inj, or.comm]
end

theorem range_last : range (fin.last n) = finset.univ :=
by { ext i, simp [mem_range, cast_succ_lt_last] }

@[simp] theorem not_mem_range_self (i : fin n) : i ∉ range i.cast_succ :=
by { rw mem_range, apply lt_irrefl }

@[simp] theorem self_mem_range_succ (i: fin n) : i ∈ range (i.succ) :=
by { rw mem_range, apply cast_succ_lt_succ }

@[simp] theorem range_subset {i j : fin (n + 1)} : range i ⊆ range j ↔ i ≤ j :=
begin
  rw [finset.subset_iff], split,
  { intro h,
    by_cases h' : i = 0, { rw h', apply zero_le },
    have : i.pred h' ∈ range i,
    { rw mem_range, conv {to_rhs, rw ←succ_pred i h'},
      rw cast_succ_lt_succ_iff },
    specialize h this,
    rwa [mem_range, cast_succ_lt_iff_succ_le, succ_pred i h'] at h },
  intros h k,
  rw [mem_range, mem_range],
  intro h',
  exact lt_of_lt_of_le h' h
end

section

variables {β : Type*} [comm_monoid β]

lemma prod_range_zero (f : fin n → β) :
 (∏ k in range 0, f k) = 1 :=
by rw [range_zero, finset.prod_empty]

lemma sum_range_zero {β : Type*} [add_comm_monoid β] (f : fin n → β) :
 (∑ k in range 0, f k) = 0 :=
by rw [range_zero, finset.sum_empty]

@[to_additive]
lemma prod_range_one (f : fin (n + 1) → β) :
  (∏ k in range 1, f k) = f 0 :=
by { rw [range_one], rw finset.prod_singleton }

@[to_additive]
lemma prod_range_succ (f : fin n → β) (i : fin n) :
  (∏ x in range i.succ, f x) = f i * (∏ x in range i.cast_succ, f x) :=
by rw [range_succ, finset.prod_insert (not_mem_range_self i)]

lemma prod_range_succ' (f : fin (n + 1) → β) (i : fin (n + 1)) :
  (∏ k in range i.succ, f k) = (∏ k in range i, f k.succ) * f 0 :=
begin
  apply fin.induction_on i,
  { rw [prod_range_succ, cast_succ_zero, prod_range_zero, prod_range_zero, mul_comm] },
  intros i' ih,
  rw [prod_range_succ (λ k, f (k.succ)), mul_assoc, ←ih, succ_cast_succ, prod_range_succ]
end

lemma sum_range_succ'  {β : Type*} [add_comm_monoid β] (f : fin (n + 1) → β) (i : fin (n + 1)) :
  (∑ k in range i.succ, f k) = (∑ k in range i, f k.succ) + f 0 :=
begin
  apply fin.induction_on i,
  { rw [sum_range_succ, cast_succ_zero, sum_range_zero, sum_range_zero, add_comm] },
  intros i' ih,
  rw [sum_range_succ (λ k, f (k.succ)), add_assoc, ←ih, succ_cast_succ, sum_range_succ]
end

end

/- currently not used, but maybe useful?

theorem add_one_eq_of_lt_last {n : ℕ} {i : fin (n + 1)} (h : i < last n) :
  i + 1 = ⟨i.1 + 1, nat.succ_lt_succ h⟩ :=
begin
  cases i with i' h', ext,
  simp [fin.coe_add, fin.coe_one'],
  apply nat.mod_eq_of_lt,
  apply nat.succ_lt_succ,
  apply h
end

theorem lt_of_add_one_le {n : ℕ} {i j : fin (n + 1)} (h : i < last n) (h' : i + 1 ≤ j) :
  i < j :=
begin
  cases i with i hi,
  cases j with j hj,
  simp [fin.le_def, fin.coe_add, fin.coe_one'],
  rw add_one_eq_of_lt_last h at h',
  apply nat.lt_of_succ_le h'
end

theorem add_one_rev_lt_last {n : ℕ} {i : fin (n + 1)} (h : i < fin.last n) :
  (i + 1).rev < fin.last n :=
begin
  rw [add_one_eq_of_lt_last h, rev, lt_def],
  dsimp [fin.last],
  rw nat.succ_sub_succ,
  apply nat.sub_lt,
  { apply lt_of_le_of_lt (nat.zero_le _) h },
  apply nat.zero_lt_succ
end
-/

end

end fin

/-
bitvec
-/

namespace bitvec

variables {n : ℕ} (b : bitvec n)

/-- bitvec's `to_nat` has bit 0 as msb, but the Cairo convention is the reverse. -/
def to_natr : ℕ := bitvec.to_nat b.reverse

def to_biased_16 : ℤ := (b.to_natr : int) - 2^15

theorem to_natr_lt : b.to_natr < 2^n := to_nat_lt _

theorem to_nat_le : b.to_nat ≤ 2^n - 1 :=
begin
  apply le_tsub_of_add_le_right,
  apply nat.succ_le_of_lt,
  apply to_nat_lt
end

theorem to_natr_le : b.to_natr ≤ 2^n - 1 := to_nat_le _

theorem to_nat_inj {n : ℕ} {b1 b2 : bitvec n} (h : b1.to_nat = b2.to_nat) : b1 = b2 :=
by rw [←of_nat_to_nat b1, h, of_nat_to_nat b2]

theorem to_natr_inj {n : ℕ} {b1 b2 : bitvec n} (h : b1.to_natr = b2.to_natr) : b1 = b2 :=
begin
  suffices : b1.reverse.reverse = b2.reverse.reverse,
    by rwa [vector.reverse_reverse, vector.reverse_reverse] at this,
  rw to_nat_inj h,
end

def of_natr (n k : ℕ) : bitvec n := (bitvec.of_nat n k).reverse

theorem to_natr_of_natr {k n : ℕ} : (bitvec.of_natr k n).to_natr = n % 2 ^ k :=
by rw [of_natr, to_natr, vector.reverse_reverse, to_nat_of_nat]

theorem singleton_to_nat (u : bool) : bitvec.to_nat (u ::ᵥ vector.nil) = u.to_nat :=
by simp [bitvec.to_nat, bits_to_nat, add_lsb]

end bitvec

/-
Casting nat and int to a ring with positive characteristic.
-/

namespace nat

variables {R : Type*} [ring R]

theorem cast_inj_of_lt_char' {a b : ℕ} (hlt : a ≤ b) (h : b < ring_char R)
  (h : (a : R) = (b : R)) : a = b :=
begin
  suffices : b - a = 0,
  { apply le_antisymm hlt, rwa ←nat.sub_eq_zero_iff_le },
  have h1 : ((b - a : ℕ) : R) = 0,
  { rw [nat.cast_sub hlt, h, sub_self] },
  rw [ring_char.spec] at h1,
  suffices : ¬ b - a > 0, linarith,
  assume : b - a > 0,
  have : ring_char R ≤ b - a, from nat.le_of_dvd this h1,
  have : b - a ≤ b, from tsub_le_self,
  linarith
end

theorem cast_inj_of_lt_char {a b : ℕ} (ha : a < ring_char R) (hb : b < ring_char R)
  (h : (a : R) = (b : R)) : a = b :=
begin
  wlog h' : a ≤ b,
  exact cast_inj_of_lt_char' h' hb h
end

end nat

namespace int

theorem cast_ne_zero_of_abs_lt_char {R : Type*} [ring R]
    {x : ℤ} (h0 : abs x ≠ 0) (h1 : abs x < ring_char R) :
  (x : R) ≠ 0 :=
begin
  have h3 : (abs x).to_nat < ring_char R,
  { rwa [←int.to_nat_of_nonneg (abs_nonneg x), int.coe_nat_lt_coe_nat_iff] at h1 },
  intro h, apply h0,
  suffices : (abs x).to_nat = 0,
  { rw [←int.to_nat_of_nonneg (abs_nonneg x), this], refl },
  apply nat.cast_inj_of_lt_char h3 (lt_of_le_of_lt (nat.zero_le _) h3),
  have : ((abs x).to_nat : R) = (((abs x).to_nat : ℤ) : R), by simp [-int.to_nat_of_nonneg],
  apply eq.trans this,
  rw [int.to_nat_of_nonneg (abs_nonneg x)],
  cases (le_or_gt 0 x) with h4 h4,
  { rw [abs_of_nonneg h4, h, nat.cast_zero] },
  rw abs_of_neg h4, simp [h]
end

lemma cast_inj_of_lt_char {R : Type*} [ring R] {i j : ℤ} {p : ℕ}
  (charR : char_p R p) (h : (i : R) = (j : R)) (h' : abs (j - i) < p) : i = j :=
begin
  symmetry,
  apply eq_of_sub_eq_zero,
  rw ←abs_eq_zero,
  by_contradiction nez,
  apply not_le_of_lt h',
  apply int.le_of_dvd,
  apply lt_of_le_of_ne (abs_nonneg _) (ne.symm nez),
  rw dvd_abs,
  have: (↑(j - i) : R) = 0, by simp [h],
  exact (char_p.int_cast_eq_zero_iff R p _).mp this
end

lemma cast_eq_zero_of_lt_char (R : Type*) [ring R] {i : ℤ} (p : ℕ)
  [charR : char_p R p] (h : (i : R) = 0) (h' : abs i < p) : i = 0 :=
begin
  have := @int.cast_inj_of_lt_char _ _  i 0 p charR,
  simp at this,
  apply this; assumption
end

end int

/-
Ring theory.
-/

open finset polynomial

section

variables {R : Type*} [comm_semiring R]

@[simp] lemma eval_multiset_prod (m : multiset (polynomial R)) (z : R) :
  eval z m.prod = (m.map (eval z)).prod :=
(@multiset.prod_hom _ R _ _ m _ _ (eval_ring_hom z)).symm

lemma nat_degree_add (p q : polynomial R) :
  nat_degree (p + q) ≤ max (nat_degree p) (nat_degree q) :=
begin
  by_cases hp : p = 0, { simp [hp] },
  by_cases hq : q = 0, { simp [hq] },
  by_cases hpq : p + q = 0, { simp [hpq] },
  have := degree_add_le p q,
  rw [degree_eq_nat_degree hp, degree_eq_nat_degree hq, degree_eq_nat_degree hpq] at this,
  simp only [with_bot.coe_le_coe, le_max_iff] at this ⊢,
  exact this
end

end

section

variables {R : Type*} [comm_ring R] [is_domain R]

private lemma multiset_prod_X_sub_C_aux (m : multiset R) :
  (m.map (λ r, X - C r)).prod ≠ 0 ∧ (m.map (λ r, X - C r)).prod.nat_degree = m.card :=
begin
  apply multiset.induction_on m, { simp },
  intros a m ih,
  have h : X - C a ≠ 0 := X_sub_C_ne_zero a,
  rw [multiset.map_cons, multiset.prod_cons, multiset.card_cons],
  split, { exact mul_ne_zero h ih.1 },
  rw [nat_degree_mul h ih.1, ih.2], simp [add_comm]
end

lemma multiset_prod_X_sub_C_ne_zero (m : multiset R) :
  (m.map (λ r, X - C r)).prod ≠ 0
:= (multiset_prod_X_sub_C_aux m).1

lemma nat_degree_multiset_prod_X_sub_C (m : multiset R) :
  (m.map (λ r, X - C r)).prod.nat_degree = m.card
:= (multiset_prod_X_sub_C_aux m).2

lemma degree_multiset_prod_X_sub_C_ne_zero (m : multiset R) :
  (m.map (λ r, X - C r)).prod.degree = m.card :=
by { rw [degree_eq_nat_degree (multiset_prod_X_sub_C_ne_zero m),
           (nat_degree_multiset_prod_X_sub_C m)] }

lemma multiset_prod_X_sub_C_roots (m : multiset R) : (m.map (λ r, X - C r)).prod.roots = m :=
begin
  have h' : (0 : polynomial R) ∉ multiset.map (λ (r : R), X - C r) m,
  { rw [multiset.mem_map], rintros ⟨r, _, h''⟩, apply X_sub_C_ne_zero _ h'' },
  rw [roots_multiset_prod _ h', multiset.bind, multiset.join], simp
end

end


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

import Aesop

set_option aesop.check.all true

-- Tests the builtin split rules.

@[aesop norm unfold]
def id' (n : Nat) : Nat :=
  match n with
  | .zero => .zero
  | .succ n => .succ n

-- First, the rule for splitting targets.
example : id' n = n := by
  aesop

-- Second, the rule for splitting hypotheses. We introduce a custom equality to
-- make sure that in the following example, Aesop doesn't just substitute the
-- hypothesis during norm simp.
inductive MyEq (x : α) : α → Prop
  | rfl : MyEq x x

@[aesop unsafe]
def MyEq.elim : MyEq x y → x = y
  | rfl => by rfl

example (h : MyEq n (id' m)) : n = m := by
  aesop


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.logic init.data.ordering.basic
universes u v

/-!
# Unbundled algebra classes

These classes and the `@[algebra]` attribute are part of an incomplete refactor described
[here on the github Wiki](https://github.com/leanprover/lean/wiki/Refactoring-structures#encoding-the-algebraic-hierarchy-1).

By themselves, these classes are not good replacements for the `monoid` / `group` etc structures
provided by mathlib, as they are not discoverable by `simp` unlike the current lemmas due to there
being little to index on. The Wiki page linked above describes an algebraic normalizer, but it is not
implemented.
-/

@[algebra] class is_symm_op (α : Type u) (β : out_param (Type v)) (op : α → α → β) : Prop :=
(symm_op : ∀ a b, op a b = op b a)

@[algebra] class is_commutative (α : Type u) (op : α → α → α) : Prop :=
(comm : ∀ a b, op a b = op b a)

@[priority 100]
instance is_symm_op_of_is_commutative (α : Type u) (op : α → α → α) [is_commutative α op] :
  is_symm_op α α op :=
{symm_op := is_commutative.comm}

@[algebra] class is_associative (α : Type u) (op : α → α → α) : Prop :=
(assoc : ∀ a b c, op (op a b) c = op a (op b c))

@[algebra] class is_left_id (α : Type u) (op : α → α → α) (o : out_param α) : Prop :=
(left_id : ∀ a, op o a = a)

@[algebra] class is_right_id (α : Type u) (op : α → α → α) (o : out_param α) : Prop :=
(right_id : ∀ a, op a o = a)

@[algebra] class is_left_null (α : Type u) (op : α → α → α) (o : out_param α) : Prop :=
(left_null : ∀ a, op o a = o)

@[algebra] class is_right_null (α : Type u) (op : α → α → α) (o : out_param α) : Prop :=
(right_null : ∀ a, op a o = o)

@[algebra] class is_left_cancel (α : Type u) (op : α → α → α) : Prop :=
(left_cancel : ∀ a b c, op a b = op a c → b = c)

@[algebra] class is_right_cancel (α : Type u) (op : α → α → α) : Prop :=
(right_cancel : ∀ a b c, op a b = op c b → a = c)

@[algebra] class is_idempotent (α : Type u) (op : α → α → α) : Prop :=
(idempotent : ∀ a, op a a = a)

@[algebra] class is_left_distrib (α : Type u) (op₁ : α → α → α) (op₂ : out_param $ α → α → α) : Prop :=
(left_distrib : ∀ a b c, op₁ a (op₂ b c) = op₂ (op₁ a b) (op₁ a c))

@[algebra] class is_right_distrib (α : Type u) (op₁ : α → α → α) (op₂ : out_param $ α → α → α) : Prop :=
(right_distrib : ∀ a b c, op₁ (op₂ a b) c = op₂ (op₁ a c) (op₁ b c))

@[algebra] class is_left_inv (α : Type u) (op : α → α → α) (inv : out_param $ α → α) (o : out_param α) : Prop :=
(left_inv : ∀ a, op (inv a) a = o)

@[algebra] class is_right_inv (α : Type u) (op : α → α → α) (inv : out_param $ α → α) (o : out_param α) : Prop :=
(right_inv : ∀ a, op a (inv a) = o)

@[algebra] class is_cond_left_inv (α : Type u) (op : α → α → α) (inv : out_param $ α → α) (o : out_param α) (p : out_param $ α → Prop) : Prop :=
(left_inv : ∀ a, p a → op (inv a) a = o)

@[algebra] class is_cond_right_inv (α : Type u) (op : α → α → α) (inv : out_param $ α → α) (o : out_param α) (p : out_param $ α → Prop) : Prop :=
(right_inv : ∀ a, p a → op a (inv a) = o)

@[algebra] class is_distinct (α : Type u) (a : α) (b : α) : Prop :=
(distinct : a ≠ b)

/-*Let $\alpha \in u$, $\beta \in v$, $f$ and $g$ be maps,  $f$ map $\alpha \to \beta$ ,
$g$ map $\alpha \to \beta$, which can implies $\forall \alpha$, $g(f(\alpha))$ $=$ $\alpha$. *-/

-- The following type class doesn't seem very useful, a regular simp lemma should work for this.
class is_inv (α : Type u) (β : Type v) (f : α → β) (g : out β → α) : Prop :=
(inv : ∀ a, g (f a) = a)

/-*Let $\alpha \in u$, $f$ be map, $f$ map $\alpha \to \alpha$, which can implies $\forall \alpha$, $g(f(\alpha))$ $=$ $\alpha$.  *-/
-- The following one can also be handled using a regular simp lemma
class is_idempotent (α : Type u) (f : α → α) : Prop :=
(idempotent : ∀ a, f (f a) = f a)
-/

/-- `is_irrefl X r` means the binary relation `r` on `X` is irreflexive (that is, `r x x` never
holds). -/
@[algebra] class is_irrefl (α : Type u) (r : α → α → Prop) : Prop :=
(irrefl : ∀ a, ¬ r a a)

/-- `is_refl X r` means the binary relation `r` on `X` is reflexive. -/
@[algebra] class is_refl (α : Type u) (r : α → α → Prop) : Prop :=
(refl : ∀ a, r a a)

/-- `is_symm X r` means the binary relation `r` on `X` is symmetric. -/
@[algebra] class is_symm (α : Type u) (r : α → α → Prop) : Prop :=
(symm : ∀ a b, r a b → r b a)

/-- The opposite of a symmetric relation is symmetric. -/
@[priority 100] instance is_symm_op_of_is_symm (α : Type u) (r : α → α → Prop) [is_symm α r] :
  is_symm_op α Prop r :=
{symm_op := λ a b, propext $ iff.intro (is_symm.symm a b) (is_symm.symm b a)}

/-- `is_asymm X r` means that the binary relation `r` on `X` is asymmetric, that is,
`r a b → ¬ r b a`. -/
@[algebra] class is_asymm (α : Type u) (r : α → α → Prop) : Prop :=
(asymm : ∀ a b, r a b → ¬ r b a)

/-- `is_antisymm X r` means the binary relation `r` on `X` is antisymmetric. -/
@[algebra] class is_antisymm (α : Type u) (r : α → α → Prop) : Prop :=
(antisymm : ∀ a b, r a b → r b a → a = b)

/-- `is_trans X r` means the binary relation `r` on `X` is transitive. -/
@[algebra] class is_trans (α : Type u) (r : α → α → Prop) : Prop :=
(trans  : ∀ a b c, r a b → r b c → r a c)

/-- `is_total X r` means that the binary relation `r` on `X` is total, that is, that for any
`x y : X` we have `r x y` or `r y x`.-/
@[algebra] class is_total (α : Type u) (r : α → α → Prop) : Prop :=
(total : ∀ a b, r a b ∨ r b a)

/-- `is_preorder X r` means that the binary relation `r` on `X` is a pre-order, that is, reflexive
and transitive. -/
@[algebra] class is_preorder (α : Type u) (r : α → α → Prop) extends
  is_refl α r, is_trans α r : Prop.

/-- `is_total_preorder X r` means that the binary relation `r` on `X` is total and a preorder. -/
@[algebra] class is_total_preorder (α : Type u) (r : α → α → Prop) extends
  is_trans α r, is_total α r : Prop.

/-- Every total pre-order is a pre-order. -/
instance is_total_preorder_is_preorder (α : Type u) (r : α → α → Prop) [s : is_total_preorder α r] :
  is_preorder α r :=
{trans := s.trans,
 refl  := λ a, or.elim (@is_total.total _ r _ a a) id id}

@[algebra] class is_partial_order (α : Type u) (r : α → α → Prop) extends
  is_preorder α r, is_antisymm α r : Prop.

@[algebra] class is_linear_order (α : Type u) (r : α → α → Prop) extends
  is_partial_order α r, is_total α r : Prop.

@[algebra] class is_equiv (α : Type u) (r : α → α → Prop) extends
  is_preorder α r, is_symm α r : Prop.

@[algebra] class is_per (α : Type u) (r : α → α → Prop) extends is_symm α r, is_trans α r : Prop.

@[algebra] class is_strict_order (α : Type u) (r : α → α → Prop) extends
  is_irrefl α r, is_trans α r : Prop.

@[algebra] class is_incomp_trans (α : Type u) (lt : α → α → Prop) : Prop :=
(incomp_trans : ∀ a b c, (¬ lt a b ∧ ¬ lt b a) → (¬ lt b c ∧ ¬ lt c b) → (¬ lt a c ∧ ¬ lt c a))

@[algebra] class is_strict_weak_order (α : Type u) (lt : α → α → Prop) extends
  is_strict_order α lt, is_incomp_trans α lt : Prop.

@[algebra] class is_trichotomous (α : Type u) (lt : α → α → Prop) : Prop :=
(trichotomous : ∀ a b, lt a b ∨ a = b ∨ lt b a)

@[algebra] class is_strict_total_order (α : Type u) (lt : α → α → Prop)
  extends is_trichotomous α lt, is_strict_weak_order α lt : Prop.

instance eq_is_equiv (α : Type u) : is_equiv α (=) :=
{symm := @eq.symm _, trans := @eq.trans _, refl := eq.refl}

section
variables {α : Type u} {r : α → α → Prop}
local infix `≺`:50 := r
/-*Let $a$ $/subset$ $/alpha$, implies $\nega$ $\prec$ $a$. *-/
lemma irrefl [is_irrefl α r] (a : α) : ¬ a ≺ a :=
is_irrefl.irrefl a
/-*Let $a$ $/subset$ $/alpha$, implies $a$ $\prec$ $a$. *-/
lemma refl [is_refl α r] (a : α) : a ≺ a :=
is_refl.refl a
/-*Let $a$, $b$ and $c$ $/subset$ $/alpha$, $a$ $\prec$ $b$ and $b$ $\prec$ $c$,which implies $a$ $\prec$ $c$. *-/
lemma trans [is_trans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c :=
is_trans.trans _ _ _
/-*Let $a$, $b$ $/subset$ $/alpha$ and $a$ $\prec$ $b$, implies $b$ $\prec$ $a$. *-/
lemma symm [is_symm α r] {a b : α} : a ≺ b → b ≺ a :=
is_symm.symm _ _
/-*Let $a$,$b$ $/subset$ $/alpha$, $a$ $\prec$ $b$ and $b$ $\prec$ $a$, implies $a$ $=$ $b$. *-/
lemma antisymm [is_antisymm α r] {a b : α} : a ≺ b → b ≺ a → a = b :=
is_antisymm.antisymm _ _
/-*Let $a$,$b$ $/subset$ $/alpha$ and $a$ $\prec$ $b$, implies $\negb$ $\prec$ $a$. *-/
lemma asymm [is_asymm α r] {a b : α} : a ≺ b → ¬ b ≺ a :=
is_asymm.asymm _ _
/-*Let $\forall$ $a$,$b$ $\in$ $\alpha$,$a$ $\prec$ $b$ $\vee$ $a$ $=$ $b$ $\vee$ $b$ $\prec$ $a$. *-/
lemma trichotomous [is_trichotomous α r] : ∀ (a b : α), a ≺ b ∨ a = b ∨ b ≺ a :=
is_trichotomous.trichotomous
/-*Let $a$, $b$ and $c$ $/subset$ $/alpha$,$\nega$ $\vee$ $b$ $\wedge$ $\negb$ $\vee$ $a$ and
$\negb$ $\vee$ $c$ $\wedge$ $\negc$ $\vee$ $b$, implies $\nega$ $\vee$ $c$ $\wedge$ $\negc$ $\vee$ $a$ *-/
lemma incomp_trans [is_incomp_trans α r] {a b c : α} : (¬ a ≺ b ∧ ¬ b ≺ a) → (¬ b ≺ c ∧ ¬ c ≺ b) → (¬ a ≺ c ∧ ¬ c ≺ a) :=
is_incomp_trans.incomp_trans _ _ _

@[priority 90]
instance is_asymm_of_is_trans_of_is_irrefl [is_trans α r] [is_irrefl α r] : is_asymm α r :=
⟨λ a b h₁ h₂, absurd (trans h₁ h₂) (irrefl a)⟩

section explicit_relation_variants
variable (r)

@[elab_simple]
lemma irrefl_of [is_irrefl α r] (a : α) : ¬ a ≺ a := irrefl a

@[elab_simple]
lemma refl_of [is_refl α r] (a : α) : a ≺ a := refl a

@[elab_simple]
lemma trans_of [is_trans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c := trans

@[elab_simple]
lemma symm_of [is_symm α r] {a b : α} : a ≺ b → b ≺ a := symm

@[elab_simple]
lemma asymm_of [is_asymm α r] {a b : α} : a ≺ b → ¬ b ≺ a := asymm

@[elab_simple]
lemma total_of [is_total α r] (a b : α) : a ≺ b ∨ b ≺ a :=
is_total.total _ _

@[elab_simple]
lemma trichotomous_of [is_trichotomous α r] : ∀ (a b : α), a ≺ b ∨ a = b ∨ b ≺ a := trichotomous

@[elab_simple]
lemma incomp_trans_of [is_incomp_trans α r] {a b c : α} : (¬ a ≺ b ∧ ¬ b ≺ a) → (¬ b ≺ c ∧ ¬ c ≺ b) → (¬ a ≺ c ∧ ¬ c ≺ a) := incomp_trans

end explicit_relation_variants

end

namespace strict_weak_order
section
parameters {α : Type u} {r : α → α → Prop}
local infix `≺`:50 := r

def equiv (a b : α) : Prop :=
¬ a ≺ b ∧ ¬ b ≺ a

parameter [is_strict_weak_order α r]

local infix ` ≈ `:50 := equiv
/-*$a$ is eauivalent to $a$. *-/
lemma erefl (a : α) : a ≈ a :=
⟨irrefl a, irrefl a⟩
/-*$a$ is eauivalent to $b$ implies $b$ is eauivalent to $a$. *-/
lemma esymm {a b : α} : a ≈ b → b ≈ a :=
λ ⟨h₁, h₂⟩, ⟨h₂, h₁⟩
/-*$a$ is eauivalent to $b$ and $b$ is eauivalent to $c$ implies $a$ is eauivalent to $c$. *-/
lemma etrans {a b c : α} : a ≈ b → b ≈ c → a ≈ c :=
incomp_trans
/-*$a$ is eauivalent to $b$ implies $\nega$ $\vee$ $b$. *-/
lemma not_lt_of_equiv {a b : α} : a ≈ b → ¬ a ≺ b :=
λ h, h.1
/-*$a$ is eauivalent to $b$ implies  $\negb$ $\vee$ $a$. *-/
lemma not_lt_of_equiv' {a b : α} : a ≈ b → ¬ b ≺ a :=
λ h, h.2

instance is_equiv : is_equiv α equiv :=
{refl := erefl, trans := @etrans, symm := @esymm}
end

/- Notation for the equivalence relation induced by lt -/
notation a ` ≈[`:50 lt `]` b:50 := @equiv _ lt a b
end strict_weak_order
/-**-/
lemma is_strict_weak_order_of_is_total_preorder {α : Type u} {le : α → α → Prop} {lt : α → α → Prop} [decidable_rel le] [s : is_total_preorder α le]
                                                (h : ∀ a b, lt a b ↔ ¬ le b a) : is_strict_weak_order α lt :=
{
 trans        :=
  λ a b c hab hbc,
    have nba : ¬ le b a, from iff.mp (h _ _) hab,
    have ncb : ¬ le c b, from iff.mp (h _ _) hbc,
    have hab : le a b,   from or.resolve_left (total_of le b a) nba,
    have nca : ¬ le c a, from λ hca : le c a,
       have hcb : le c b, from trans_of le hca hab,
       absurd hcb ncb,
    iff.mpr (h _ _) nca,

 irrefl       := λ a hlt, absurd (refl_of le a) (iff.mp (h _ _) hlt),

 incomp_trans := λ a b c ⟨nab, nba⟩ ⟨nbc, ncb⟩,
    have hba : le b a, from decidable.of_not_not (iff.mp (not_iff_not_of_iff (h _ _)) nab),
    have hab : le a b, from decidable.of_not_not (iff.mp (not_iff_not_of_iff (h _ _)) nba),
    have hcb : le c b, from decidable.of_not_not (iff.mp (not_iff_not_of_iff (h _ _)) nbc),
    have hbc : le b c, from decidable.of_not_not (iff.mp (not_iff_not_of_iff (h _ _)) ncb),
    have hac : le a c, from trans_of le hab hbc,
    have hca : le c a, from trans_of le hcb hba,
    and.intro
      (λ n, absurd hca (iff.mp (h _ _) n))
      (λ n, absurd hac (iff.mp (h _ _) n))
}
/-*$\forall$ $a$,$b$ and $c$ $\in$ $\alpha$, $a$ lt $b$ can imply $\neg$ ($b$ lt $c$）$\wedge$ $\neg$ ($c$ lt $b$）,
which implies $a$ lt $b$. *-/
lemma lt_of_lt_of_incomp {α : Type u} {lt : α → α → Prop} [is_strict_weak_order α lt] [decidable_rel lt]
                         : ∀ {a b c}, lt a b → (¬ lt b c ∧ ¬ lt c b) → lt a c :=
λ a b c hab ⟨nbc, ncb⟩,
  have nca : ¬ lt c a, from λ hca, absurd (trans_of lt hca hab) ncb,
  decidable.by_contradiction $
    λ nac : ¬ lt a c,
      have ¬ lt a b ∧ ¬ lt b a, from incomp_trans_of lt ⟨nac, nca⟩ ⟨ncb, nbc⟩,
      absurd hab this.1
/-*$\forall$ $a$,$b$ and $c$ $\in$ $\alpha$, $\neg$ ($a$ lt $b$）$\wedge$ $\neg$ ($b$ lt $a$） can imply $b$ lt $c$,
which implies $a$ lt $c$. *-/
lemma lt_of_incomp_of_lt {α : Type u} {lt : α → α → Prop} [is_strict_weak_order α lt] [decidable_rel lt]
                         : ∀ {a b c}, (¬ lt a b ∧ ¬ lt b a) → lt b c → lt a c :=
λ a b c ⟨nab, nba⟩ hbc,
  have nca : ¬ lt c a, from λ hca, absurd (trans_of lt hbc hca) nba,
  decidable.by_contradiction $
    λ nac : ¬ lt a c,
      have ¬ lt b c ∧ ¬ lt c b, from incomp_trans_of lt ⟨nba, nab⟩ ⟨nac, nca⟩,
      absurd hbc this.1
/-*$\neg$ ($a$ lt $b$）$\wedge$ $\neg$ ($b$ lt $a$） implies $a$ $=$ $b$. *-/
lemma eq_of_incomp {α : Type u} {lt : α → α → Prop} [is_trichotomous α lt] {a b} : (¬ lt a b ∧ ¬ lt b a) → a = b :=
λ ⟨nab, nba⟩,
  match trichotomous_of lt a b with
  | or.inl hab          := absurd hab nab
  | or.inr (or.inl hab) := hab
  | or.inr (or.inr hba) := absurd hba nba
  end
/-*$a$ is eauivalent to ($b$ lt $b$）implies $a$ $=$ $b$. *-/
lemma eq_of_eqv_lt {α : Type u} {lt : α → α → Prop} [is_trichotomous α lt] {a b} : a ≈[lt] b → a = b :=
eq_of_incomp
/-*$\neg$ ($a$ lt $b$）$\wedge$ $\neg$ ($b$ lt $a$）is eauivalent to $a$ $=$ $b$. *-/
lemma incomp_iff_eq {α : Type u} {lt : α → α → Prop} [is_trichotomous α lt] [is_irrefl α lt] (a b) : (¬ lt a b ∧ ¬ lt b a) ↔ a = b :=
iff.intro eq_of_incomp (λ hab, eq.subst hab (and.intro (irrefl_of lt a) (irrefl_of lt a)))
/-*$a$ is eauivalent to ($b$ lt $b$）is eauivalent to $a$ $=$ $b$. *-/
lemma eqv_lt_iff_eq {α : Type u} {lt : α → α → Prop} [is_trichotomous α lt] [is_irrefl α lt] (a b) : a ≈[lt] b ↔ a = b :=
incomp_iff_eq a b
/-*$a$ lt $b$ implies $\neg$($b$ lt $a$). *-/
lemma not_lt_of_lt {α : Type u} {lt : α → α → Prop} [is_strict_order α lt] {a b} : lt a b → ¬ lt b a :=
λ h₁ h₂, absurd (trans_of lt h₁ h₂) (irrefl_of lt _)


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

! This file was ported from Lean 3 source module ring_theory.non_zero_divisors
! leanprover-community/mathlib commit 1126441d6bccf98c81214a0780c73d499f6721fe
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Submonoid.Operations
import Mathlib.GroupTheory.Submonoid.Membership

/-!
# Non-zero divisors

In this file we define the submonoid `nonZeroDivisors` of a `MonoidWithZero`.

## Notations

This file declares the notation `R⁰` for the submonoid of non-zero-divisors of `R`,
in the locale `nonZeroDivisors`.

Use the statement `open nonZeroDivisors` to access this notation in your own code.

-/

section nonZeroDivisors

/-- The submonoid of non-zero-divisors of a `MonoidWithZero` `R`. -/
def nonZeroDivisors (R : Type _) [MonoidWithZero R] : Submonoid R where
  carrier := { x | ∀ z, z * x = 0 → z = 0 }
  one_mem' _ hz := by rwa [mul_one] at hz
  mul_mem' hx₁ hx₂ _ hz := by
    rw [← mul_assoc] at hz
    exact hx₁ _ (hx₂ _ hz)
#align non_zero_divisors nonZeroDivisors

/-- The notation for the submonoid of non-zerodivisors. -/
scoped[nonZeroDivisors] notation:9000 R "⁰" => nonZeroDivisors R

open nonZeroDivisors

variable {M M' M₁ R R' F : Type _} [MonoidWithZero M] [MonoidWithZero M'] [CommMonoidWithZero M₁]
  [Ring R] [CommRing R']

theorem mem_nonZeroDivisors_iff {r : M} : r ∈ M⁰ ↔ ∀ x, x * r = 0 → x = 0 := Iff.rfl
#align mem_non_zero_divisors_iff mem_nonZeroDivisors_iff

theorem mul_right_mem_nonZeroDivisors_eq_zero_iff {x r : M} (hr : r ∈ M⁰) : x * r = 0 ↔ x = 0 :=
  ⟨hr _, by simp (config := { contextual := true })⟩
#align mul_right_mem_non_zero_divisors_eq_zero_iff mul_right_mem_nonZeroDivisors_eq_zero_iff
@[simp]
theorem mul_right_coe_nonZeroDivisors_eq_zero_iff {x : M} {c : M⁰} : x * c = 0 ↔ x = 0 :=
  mul_right_mem_nonZeroDivisors_eq_zero_iff c.prop
#align mul_right_coe_non_zero_divisors_eq_zero_iff mul_right_coe_nonZeroDivisors_eq_zero_iff

theorem mul_left_mem_nonZeroDivisors_eq_zero_iff {r x : M₁} (hr : r ∈ M₁⁰) : r * x = 0 ↔ x = 0 := by
  rw [mul_comm, mul_right_mem_nonZeroDivisors_eq_zero_iff hr]
#align mul_left_mem_non_zero_divisors_eq_zero_iff mul_left_mem_nonZeroDivisors_eq_zero_iff

@[simp]
theorem mul_left_coe_nonZeroDivisors_eq_zero_iff {c : M₁⁰} {x : M₁} : (c : M₁) * x = 0 ↔ x = 0 :=
  mul_left_mem_nonZeroDivisors_eq_zero_iff c.prop
#align mul_left_coe_non_zero_divisors_eq_zero_iff mul_left_coe_nonZeroDivisors_eq_zero_iff

theorem mul_cancel_right_mem_nonZeroDivisors {x y r : R} (hr : r ∈ R⁰) : x * r = y * r ↔ x = y :=
  by
  refine ⟨fun h ↦ ?_, congrArg (· * r)⟩
  rw [← sub_eq_zero, ← mul_right_mem_nonZeroDivisors_eq_zero_iff hr, sub_mul, h, sub_self]
#align mul_cancel_right_mem_non_zero_divisor mul_cancel_right_mem_nonZeroDivisors

theorem mul_cancel_right_coe_nonZeroDivisors {x y : R} {c : R⁰} : x * c = y * c ↔ x = y :=
  mul_cancel_right_mem_nonZeroDivisors c.prop
#align mul_cancel_right_coe_non_zero_divisor mul_cancel_right_coe_nonZeroDivisors

@[simp]
theorem mul_cancel_left_mem_nonZeroDivisors {x y r : R'} (hr : r ∈ R'⁰) : r * x = r * y ↔ x = y :=
  by simp_rw [mul_comm r, mul_cancel_right_mem_nonZeroDivisors hr]
#align mul_cancel_left_mem_non_zero_divisor mul_cancel_left_mem_nonZeroDivisors

theorem mul_cancel_left_coe_nonZeroDivisors {x y : R'} {c : R'⁰} : (c : R') * x = c * y ↔ x = y :=
  mul_cancel_left_mem_nonZeroDivisors c.prop
#align mul_cancel_left_coe_non_zero_divisor mul_cancel_left_coe_nonZeroDivisors

theorem nonZeroDivisors.ne_zero [Nontrivial M] {x} (hx : x ∈ M⁰) : x ≠ 0 := fun h ↦
  one_ne_zero (hx _ <| (one_mul _).trans h)
#align non_zero_divisors.ne_zero nonZeroDivisors.ne_zero

theorem nonZeroDivisors.coe_ne_zero [Nontrivial M] (x : M⁰) : (x : M) ≠ 0 :=
  nonZeroDivisors.ne_zero x.2
#align non_zero_divisors.coe_ne_zero nonZeroDivisors.coe_ne_zero

theorem mul_mem_nonZeroDivisors {a b : M₁} : a * b ∈ M₁⁰ ↔ a ∈ M₁⁰ ∧ b ∈ M₁⁰ := by
  constructor
  · intro h
    constructor <;> intro x h' <;> apply h
    · rw [← mul_assoc, h', zero_mul]
    · rw [mul_comm a b, ← mul_assoc, h', zero_mul]
  · rintro ⟨ha, hb⟩ x hx
    apply ha
    apply hb
    rw [mul_assoc, hx]
#align mul_mem_non_zero_divisors mul_mem_nonZeroDivisors

theorem isUnit_of_mem_nonZeroDivisors {G₀ : Type _} [GroupWithZero G₀] {x : G₀}
    (hx : x ∈ nonZeroDivisors G₀) : IsUnit x :=
  ⟨⟨x, x⁻¹, mul_inv_cancel (nonZeroDivisors.ne_zero hx),
    inv_mul_cancel (nonZeroDivisors.ne_zero hx)⟩, rfl⟩
#align is_unit_of_mem_non_zero_divisors isUnit_of_mem_nonZeroDivisors

theorem eq_zero_of_ne_zero_of_mul_right_eq_zero [NoZeroDivisors M] {x y : M} (hnx : x ≠ 0)
    (hxy : y * x = 0) : y = 0 :=
  Or.resolve_right (eq_zero_or_eq_zero_of_mul_eq_zero hxy) hnx
#align eq_zero_of_ne_zero_of_mul_right_eq_zero eq_zero_of_ne_zero_of_mul_right_eq_zero

theorem eq_zero_of_ne_zero_of_mul_left_eq_zero [NoZeroDivisors M] {x y : M} (hnx : x ≠ 0)
    (hxy : x * y = 0) : y = 0 :=
  Or.resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero hxy) hnx
#align eq_zero_of_ne_zero_of_mul_left_eq_zero eq_zero_of_ne_zero_of_mul_left_eq_zero

theorem mem_nonZeroDivisors_of_ne_zero [NoZeroDivisors M] {x : M} (hx : x ≠ 0) : x ∈ M⁰ := fun _ ↦
  eq_zero_of_ne_zero_of_mul_right_eq_zero hx
#align mem_non_zero_divisors_of_ne_zero mem_nonZeroDivisors_of_ne_zero

theorem mem_nonZeroDivisors_iff_ne_zero [NoZeroDivisors M] [Nontrivial M] {x : M} :
    x ∈ M⁰ ↔ x ≠ 0 := ⟨nonZeroDivisors.ne_zero, mem_nonZeroDivisors_of_ne_zero⟩
#align mem_non_zero_divisors_iff_ne_zero mem_nonZeroDivisors_iff_ne_zero

theorem map_ne_zero_of_mem_nonZeroDivisors [Nontrivial M] [ZeroHomClass F M M'] (g : F)
    (hg : Function.Injective (g : M → M')) {x : M} (h : x ∈ M⁰) : g x ≠ 0 := fun h0 ↦
  one_ne_zero (h 1 ((one_mul x).symm ▸ hg (h0.trans (map_zero g).symm)))
#align map_ne_zero_of_mem_non_zero_divisors map_ne_zero_of_mem_nonZeroDivisors

theorem map_mem_nonZeroDivisors [Nontrivial M] [NoZeroDivisors M'] [ZeroHomClass F M M'] (g : F)
    (hg : Function.Injective g) {x : M} (h : x ∈ M⁰) : g x ∈ M'⁰ := fun _ hz ↦
  eq_zero_of_ne_zero_of_mul_right_eq_zero (map_ne_zero_of_mem_nonZeroDivisors g hg h) hz
#align map_mem_non_zero_divisors map_mem_nonZeroDivisors

theorem le_nonZeroDivisors_of_noZeroDivisors [NoZeroDivisors M] {S : Submonoid M}
    (hS : (0 : M) ∉ S) : S ≤ M⁰ := fun _ hx _ hy ↦
  Or.recOn (eq_zero_or_eq_zero_of_mul_eq_zero hy) (fun h ↦ h) fun h ↦
    absurd (h ▸ hx : (0 : M) ∈ S) hS
#align le_non_zero_divisors_of_no_zero_divisors le_nonZeroDivisors_of_noZeroDivisors

theorem powers_le_nonZeroDivisors_of_noZeroDivisors [NoZeroDivisors M] {a : M} (ha : a ≠ 0) :
    Submonoid.powers a ≤ M⁰ :=
  le_nonZeroDivisors_of_noZeroDivisors fun h ↦ absurd (h.recOn fun _ hn ↦ pow_eq_zero hn) ha
#align powers_le_non_zero_divisors_of_no_zero_divisors powers_le_nonZeroDivisors_of_noZeroDivisors

theorem map_le_nonZeroDivisors_of_injective [NoZeroDivisors M'] [MonoidWithZeroHomClass F M M']
    (f : F) (hf : Function.Injective f) {S : Submonoid M} (hS : S ≤ M⁰) : S.map f ≤ M'⁰ := by
  cases subsingleton_or_nontrivial M
  · simp [Subsingleton.elim S ⊥]
  · exact le_nonZeroDivisors_of_noZeroDivisors fun h ↦
      let ⟨x, hx, hx0⟩ := h
      zero_ne_one (hS (hf (hx0.trans (map_zero f).symm) ▸ hx : 0 ∈ S) 1 (mul_zero 1)).symm
#align map_le_non_zero_divisors_of_injective map_le_nonZeroDivisors_of_injective

theorem nonZeroDivisors_le_comap_nonZeroDivisors_of_injective [NoZeroDivisors M']
    [MonoidWithZeroHomClass F M M'] (f : F) (hf : Function.Injective f) : M⁰ ≤ M'⁰.comap f :=
  Submonoid.le_comap_of_map_le _ (map_le_nonZeroDivisors_of_injective _ hf le_rfl)
#align non_zero_divisors_le_comap_non_zero_divisors_of_injective
  nonZeroDivisors_le_comap_nonZeroDivisors_of_injective

theorem prod_zero_iff_exists_zero [NoZeroDivisors M₁] [Nontrivial M₁] {s : Multiset M₁} :
    s.prod = 0 ↔ ∃ (r : M₁) (_ : r ∈ s), r = 0 := by
  constructor; swap
  · rintro ⟨r, hrs, rfl⟩
    exact Multiset.prod_eq_zero hrs
  induction' s using Multiset.induction_on with a s ih
  · intro habs
    simp at habs
  · rw [Multiset.prod_cons]
    intro hprod
    replace hprod := eq_zero_or_eq_zero_of_mul_eq_zero hprod
    cases' hprod with ha hb
    · exact ⟨a, Multiset.mem_cons_self a s, ha⟩
    · apply (ih hb).imp _
      rintro b ⟨hb₁, hb₂⟩
      exact ⟨Multiset.mem_cons_of_mem hb₁, hb₂⟩
#align prod_zero_iff_exists_zero prod_zero_iff_exists_zero

end nonZeroDivisors


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

! This file was ported from Lean 3 source module group_theory.group_action.opposite
! leanprover-community/mathlib commit 4330aae21f538b862f8aead371cfb6ee556398f1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Opposite
import Mathbin.GroupTheory.GroupAction.Defs

/-!
# Scalar actions on and by `Mᵐᵒᵖ`

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

This file defines the actions on the opposite type `has_smul R Mᵐᵒᵖ`, and actions by the opposite
type, `has_smul Rᵐᵒᵖ M`.

Note that `mul_opposite.has_smul` is provided in an earlier file as it is needed to provide the
`add_monoid.nsmul` and `add_comm_group.gsmul` fields.
-/

variable (α : Type _)

/-! ### Actions _on_ the opposite type

Actions on the opposite type just act on the underlying type.
-/

namespace MulOpposite

@[to_additive]
instance (R : Type _) [Monoid R] [MulAction R α] : MulAction R αᵐᵒᵖ :=
  {
    MulOpposite.hasSmul α
      R with
    one_smul := fun x => unop_injective <| one_smul R (unop x)
    mul_smul := fun r₁ r₂ x => unop_injective <| mul_smul r₁ r₂ (unop x) }

instance (R : Type _) [Monoid R] [AddMonoid α] [DistribMulAction R α] : DistribMulAction R αᵐᵒᵖ :=
  {
    MulOpposite.mulAction α
      R with
    smul_add := fun r x₁ x₂ => unop_injective <| smul_add r (unop x₁) (unop x₂)
    smul_zero := fun r => unop_injective <| smul_zero r }

instance (R : Type _) [Monoid R] [Monoid α] [MulDistribMulAction R α] :
    MulDistribMulAction R αᵐᵒᵖ :=
  {
    MulOpposite.mulAction α
      R with
    smul_mul := fun r x₁ x₂ => unop_injective <| smul_mul' r (unop x₂) (unop x₁)
    smul_one := fun r => unop_injective <| smul_one r }

@[to_additive]
instance {M N} [SMul M N] [SMul M α] [SMul N α] [IsScalarTower M N α] : IsScalarTower M N αᵐᵒᵖ :=
  ⟨fun x y z => unop_injective <| smul_assoc _ _ _⟩

@[to_additive]
instance {M N} [SMul M α] [SMul N α] [SMulCommClass M N α] : SMulCommClass M N αᵐᵒᵖ :=
  ⟨fun x y z => unop_injective <| smul_comm _ _ _⟩

@[to_additive]
instance (R : Type _) [SMul R α] [SMul Rᵐᵒᵖ α] [IsCentralScalar R α] : IsCentralScalar R αᵐᵒᵖ :=
  ⟨fun r m => unop_injective <| op_smul_eq_smul _ _⟩

#print MulOpposite.op_smul_eq_op_smul_op /-
theorem op_smul_eq_op_smul_op {R : Type _} [SMul R α] [SMul Rᵐᵒᵖ α] [IsCentralScalar R α] (r : R)
    (a : α) : op (r • a) = op r • op a :=
  (op_smul_eq_smul r (op a)).symm
#align mul_opposite.op_smul_eq_op_smul_op MulOpposite.op_smul_eq_op_smul_op
-/

#print MulOpposite.unop_smul_eq_unop_smul_unop /-
theorem unop_smul_eq_unop_smul_unop {R : Type _} [SMul R α] [SMul Rᵐᵒᵖ α] [IsCentralScalar R α]
    (r : Rᵐᵒᵖ) (a : αᵐᵒᵖ) : unop (r • a) = unop r • unop a :=
  (unop_smul_eq_smul r (unop a)).symm
#align mul_opposite.unop_smul_eq_unop_smul_unop MulOpposite.unop_smul_eq_unop_smul_unop
-/

end MulOpposite

/-! ### Actions _by_ the opposite type (right actions)

In `has_mul.to_has_smul` in another file, we define the left action `a₁ • a₂ = a₁ * a₂`. For the
multiplicative opposite, we define `mul_opposite.op a₁ • a₂ = a₂ * a₁`, with the multiplication
reversed.
-/

open MulOpposite

#print Mul.toHasOppositeSMul /-
/-- Like `has_mul.to_has_smul`, but multiplies on the right.

See also `monoid.to_opposite_mul_action` and `monoid_with_zero.to_opposite_mul_action_with_zero`. -/
@[to_additive
      "Like `has_add.to_has_vadd`, but adds on the right.\n\nSee also `add_monoid.to_opposite_add_action`."]
instance Mul.toHasOppositeSMul [Mul α] : SMul αᵐᵒᵖ α :=
  ⟨fun c x => x * c.unop⟩
#align has_mul.to_has_opposite_smul Mul.toHasOppositeSMul
#align has_add.to_has_opposite_vadd Add.toHasOppositeVAdd
-/

#print op_smul_eq_mul /-
@[to_additive]
theorem op_smul_eq_mul [Mul α] {a a' : α} : op a • a' = a' * a :=
  rfl
#align op_smul_eq_mul op_smul_eq_mul
#align op_vadd_eq_add op_vadd_eq_add
-/

#print MulOpposite.smul_eq_mul_unop /-
@[simp, to_additive]
theorem MulOpposite.smul_eq_mul_unop [Mul α] {a : αᵐᵒᵖ} {a' : α} : a • a' = a' * a.unop :=
  rfl
#align mul_opposite.smul_eq_mul_unop MulOpposite.smul_eq_mul_unop
#align add_opposite.vadd_eq_add_unop AddOpposite.vadd_eq_add_unop
-/

/- warning: mul_action.opposite_regular.is_pretransitive -> MulAction.OppositeRegular.isPretransitive is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G], MulAction.IsPretransitive.{u1, u1} (MulOpposite.{u1} G) G (Mul.toHasOppositeSMul.{u1} G (MulOneClass.toHasMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1)))))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G], MulAction.IsPretransitive.{u1, u1} (MulOpposite.{u1} G) G (Mul.toHasOppositeSMul.{u1} G (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1)))))
Case conversion may be inaccurate. Consider using '#align mul_action.opposite_regular.is_pretransitive MulAction.OppositeRegular.isPretransitiveₓ'. -/
/-- The right regular action of a group on itself is transitive. -/
@[to_additive "The right regular action of an additive group on itself is transitive."]
instance MulAction.OppositeRegular.isPretransitive {G : Type _} [Group G] :
    MulAction.IsPretransitive Gᵐᵒᵖ G :=
  ⟨fun x y => ⟨op (x⁻¹ * y), mul_inv_cancel_left _ _⟩⟩
#align mul_action.opposite_regular.is_pretransitive MulAction.OppositeRegular.isPretransitive
#align add_action.opposite_regular.is_pretransitive AddAction.OppositeRegular.isPretransitive

/- warning: semigroup.opposite_smul_comm_class -> Semigroup.opposite_smulCommClass is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : Semigroup.{u1} α], SMulCommClass.{u1, u1, u1} (MulOpposite.{u1} α) α α (Mul.toHasOppositeSMul.{u1} α (Semigroup.toHasMul.{u1} α _inst_1)) (Mul.toSMul.{u1} α (Semigroup.toHasMul.{u1} α _inst_1))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : Semigroup.{u1} α], SMulCommClass.{u1, u1, u1} (MulOpposite.{u1} α) α α (Mul.toHasOppositeSMul.{u1} α (Semigroup.toMul.{u1} α _inst_1)) (Mul.toSMul.{u1} α (Semigroup.toMul.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align semigroup.opposite_smul_comm_class Semigroup.opposite_smulCommClassₓ'. -/
@[to_additive]
instance Semigroup.opposite_smulCommClass [Semigroup α] : SMulCommClass αᵐᵒᵖ α α
    where smul_comm x y z := mul_assoc _ _ _
#align semigroup.opposite_smul_comm_class Semigroup.opposite_smulCommClass
#align add_semigroup.opposite_vadd_comm_class AddSemigroup.opposite_vaddCommClass

/- warning: semigroup.opposite_smul_comm_class' -> Semigroup.opposite_smulCommClass' is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : Semigroup.{u1} α], SMulCommClass.{u1, u1, u1} α (MulOpposite.{u1} α) α (Mul.toSMul.{u1} α (Semigroup.toHasMul.{u1} α _inst_1)) (Mul.toHasOppositeSMul.{u1} α (Semigroup.toHasMul.{u1} α _inst_1))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : Semigroup.{u1} α], SMulCommClass.{u1, u1, u1} α (MulOpposite.{u1} α) α (Mul.toSMul.{u1} α (Semigroup.toMul.{u1} α _inst_1)) (Mul.toHasOppositeSMul.{u1} α (Semigroup.toMul.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align semigroup.opposite_smul_comm_class' Semigroup.opposite_smulCommClass'ₓ'. -/
@[to_additive]
instance Semigroup.opposite_smulCommClass' [Semigroup α] : SMulCommClass α αᵐᵒᵖ α :=
  SMulCommClass.symm _ _ _
#align semigroup.opposite_smul_comm_class' Semigroup.opposite_smulCommClass'
#align add_semigroup.opposite_vadd_comm_class' AddSemigroup.opposite_vaddCommClass'

/- warning: comm_semigroup.is_central_scalar -> CommSemigroup.isCentralScalar is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : CommSemigroup.{u1} α], IsCentralScalar.{u1, u1} α α (Mul.toSMul.{u1} α (Semigroup.toHasMul.{u1} α (CommSemigroup.toSemigroup.{u1} α _inst_1))) (Mul.toHasOppositeSMul.{u1} α (Semigroup.toHasMul.{u1} α (CommSemigroup.toSemigroup.{u1} α _inst_1)))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : CommSemigroup.{u1} α], IsCentralScalar.{u1, u1} α α (Mul.toSMul.{u1} α (Semigroup.toMul.{u1} α (CommSemigroup.toSemigroup.{u1} α _inst_1))) (Mul.toHasOppositeSMul.{u1} α (Semigroup.toMul.{u1} α (CommSemigroup.toSemigroup.{u1} α _inst_1)))
Case conversion may be inaccurate. Consider using '#align comm_semigroup.is_central_scalar CommSemigroup.isCentralScalarₓ'. -/
@[to_additive]
instance CommSemigroup.isCentralScalar [CommSemigroup α] : IsCentralScalar α α :=
  ⟨fun r m => mul_comm _ _⟩
#align comm_semigroup.is_central_scalar CommSemigroup.isCentralScalar
#align add_comm_semigroup.is_central_scalar AddCommSemigroup.isCentralVAdd

#print Monoid.toOppositeMulAction /-
/-- Like `monoid.to_mul_action`, but multiplies on the right. -/
@[to_additive "Like `add_monoid.to_add_action`, but adds on the right."]
instance Monoid.toOppositeMulAction [Monoid α] : MulAction αᵐᵒᵖ α
    where
  smul := (· • ·)
  one_smul := mul_one
  mul_smul x y r := (mul_assoc _ _ _).symm
#align monoid.to_opposite_mul_action Monoid.toOppositeMulAction
#align add_monoid.to_opposite_add_action AddMonoid.toOppositeAddAction
-/

#print IsScalarTower.opposite_mid /-
@[to_additive]
instance IsScalarTower.opposite_mid {M N} [Mul N] [SMul M N] [SMulCommClass M N N] :
    IsScalarTower M Nᵐᵒᵖ N :=
  ⟨fun x y z => mul_smul_comm _ _ _⟩
#align is_scalar_tower.opposite_mid IsScalarTower.opposite_mid
#align vadd_assoc_class.opposite_mid VAddAssocClass.opposite_mid
-/

#print SMulCommClass.opposite_mid /-
@[to_additive]
instance SMulCommClass.opposite_mid {M N} [Mul N] [SMul M N] [IsScalarTower M N N] :
    SMulCommClass M Nᵐᵒᵖ N :=
  ⟨fun x y z => by
    induction y using MulOpposite.rec'
    simp [smul_mul_assoc]⟩
#align smul_comm_class.opposite_mid SMulCommClass.opposite_mid
#align vadd_comm_class.opposite_mid VAddCommClass.opposite_mid
-/

-- The above instance does not create an unwanted diamond, the two paths to
-- `mul_action αᵐᵒᵖ αᵐᵒᵖ` are defeq.
example [Monoid α] : Monoid.toMulAction αᵐᵒᵖ = MulOpposite.mulAction α αᵐᵒᵖ :=
  rfl

/- warning: left_cancel_monoid.to_has_faithful_opposite_scalar -> LeftCancelMonoid.toFaithfulSMul_opposite is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : LeftCancelMonoid.{u1} α], FaithfulSMul.{u1, u1} (MulOpposite.{u1} α) α (Mul.toHasOppositeSMul.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (LeftCancelMonoid.toMonoid.{u1} α _inst_1))))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : LeftCancelMonoid.{u1} α], FaithfulSMul.{u1, u1} (MulOpposite.{u1} α) α (Mul.toHasOppositeSMul.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (LeftCancelMonoid.toMonoid.{u1} α _inst_1))))
Case conversion may be inaccurate. Consider using '#align left_cancel_monoid.to_has_faithful_opposite_scalar LeftCancelMonoid.toFaithfulSMul_oppositeₓ'. -/
/-- `monoid.to_opposite_mul_action` is faithful on cancellative monoids. -/
@[to_additive "`add_monoid.to_opposite_add_action` is faithful on cancellative monoids."]
instance LeftCancelMonoid.toFaithfulSMul_opposite [LeftCancelMonoid α] : FaithfulSMul αᵐᵒᵖ α :=
  ⟨fun x y h => unop_injective <| mul_left_cancel (h 1)⟩
#align left_cancel_monoid.to_has_faithful_opposite_scalar LeftCancelMonoid.toFaithfulSMul_opposite
#align add_left_cancel_monoid.to_has_faithful_opposite_scalar AddLeftCancelMonoid.toFaithfulVAdd_opposite

/- warning: cancel_monoid_with_zero.to_has_faithful_opposite_scalar -> CancelMonoidWithZero.toFaithfulSMul_opposite is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : CancelMonoidWithZero.{u1} α] [_inst_2 : Nontrivial.{u1} α], FaithfulSMul.{u1, u1} (MulOpposite.{u1} α) α (Mul.toHasOppositeSMul.{u1} α (MulZeroClass.toHasMul.{u1} α (MulZeroOneClass.toMulZeroClass.{u1} α (MonoidWithZero.toMulZeroOneClass.{u1} α (CancelMonoidWithZero.toMonoidWithZero.{u1} α _inst_1)))))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : CancelMonoidWithZero.{u1} α] [_inst_2 : Nontrivial.{u1} α], FaithfulSMul.{u1, u1} (MulOpposite.{u1} α) α (Mul.toHasOppositeSMul.{u1} α (MulZeroClass.toMul.{u1} α (MulZeroOneClass.toMulZeroClass.{u1} α (MonoidWithZero.toMulZeroOneClass.{u1} α (CancelMonoidWithZero.toMonoidWithZero.{u1} α _inst_1)))))
Case conversion may be inaccurate. Consider using '#align cancel_monoid_with_zero.to_has_faithful_opposite_scalar CancelMonoidWithZero.toFaithfulSMul_oppositeₓ'. -/
/-- `monoid.to_opposite_mul_action` is faithful on nontrivial cancellative monoids with zero. -/
instance CancelMonoidWithZero.toFaithfulSMul_opposite [CancelMonoidWithZero α] [Nontrivial α] :
    FaithfulSMul αᵐᵒᵖ α :=
  ⟨fun x y h => unop_injective <| mul_left_cancel₀ one_ne_zero (h 1)⟩
#align cancel_monoid_with_zero.to_has_faithful_opposite_scalar CancelMonoidWithZero.toFaithfulSMul_opposite