/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.applicative
import Mathlib.control.traversable.basic
import Mathlib.PostPort

universes u l v u_1

namespace Mathlib

/-!
# Free constructions

## Main definitions

* `free_magma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `magma.free_semigroup α`: free semigroup over magma `α`.
* `free_semigroup α`: free semigroup over alphabet `α`, defined as a synonym for `α × list α`
  (i.e. nonempty lists), with traversable instance and decidable equality.
* `free_semigroup_free_magma α`: isomorphism between `magma.free_semigroup (free_magma α)` and
  `free_semigroup α`.
-/

/-- Free magma over a given alphabet. -/
inductive free_magma (α : Type u) where
| of : α → free_magma α
| mul : free_magma α → free_magma α → free_magma α

/-- Free nonabelian additive magma over a given alphabet. -/
inductive free_add_magma (α : Type u) where
| of : α → free_add_magma α
| add : free_add_magma α → free_add_magma α → free_add_magma α

namespace free_magma

protected instance Mathlib.free_add_magma.inhabited {α : Type u} [Inhabited α] :
    Inhabited (free_add_magma α) :=
  { default := free_add_magma.of Inhabited.default }

protected instance Mathlib.free_add_magma.has_add {α : Type u} : Add (free_add_magma α) :=
  { add := free_add_magma.add }

@[simp] theorem Mathlib.free_add_magma.add_eq {α : Type u} (x : free_add_magma α)
    (y : free_add_magma α) : free_add_magma.add x y = x + y :=
  rfl

/-- Recursor for `free_magma` using `x * y` instead of `free_magma.mul x y`. -/
def Mathlib.free_add_magma.rec_on' {α : Type u} {C : free_add_magma α → Sort l}
    (x : free_add_magma α) (ih1 : (x : α) → C (free_add_magma.of x))
    (ih2 : (x y : free_add_magma α) → C x → C y → C (x + y)) : C x :=
  free_add_magma.rec_on x ih1 ih2

end free_magma

/-- Lifts a function `α → β` to a magma homomorphism `free_magma α → β` given a magma `β`. -/
def free_magma.lift {α : Type u} {β : Type v} [Mul β] (f : α → β) : free_magma α → β := sorry

/-- Lifts a function `α → β` to an additive magma homomorphism `free_add_magma α → β` given
an additive magma `β`. -/
def free_add_magma.lift {α : Type u} {β : Type v} [Add β] (f : α → β) : free_add_magma α → β :=
  sorry

namespace free_magma

@[simp] theorem Mathlib.free_add_magma.lift_of {α : Type u} {β : Type v} [Add β] (f : α → β)
    (x : α) : free_add_magma.lift f (free_add_magma.of x) = f x :=
  rfl

@[simp] theorem lift_mul {α : Type u} {β : Type v} [Mul β] (f : α → β) (x : free_magma α)
    (y : free_magma α) : lift f (x * y) = lift f x * lift f y :=
  rfl

theorem lift_unique {α : Type u} {β : Type v} [Mul β] (f : free_magma α → β)
    (hf : ∀ (x y : free_magma α), f (x * y) = f x * f y) : f = lift (f ∘ of) :=
  sorry

end free_magma

/-- The unique magma homomorphism `free_magma α → free_magma β` that sends
each `of x` to `of (f x)`. -/
def free_magma.map {α : Type u} {β : Type v} (f : α → β) : free_magma α → free_magma β := sorry

/-- The unique additive magma homomorphism `free_add_magma α → free_add_magma β` that sends
each `of x` to `of (f x)`. -/
def free_add_magma.map {α : Type u} {β : Type v} (f : α → β) :
    free_add_magma α → free_add_magma β :=
  sorry

namespace free_magma

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

@[simp] theorem Mathlib.free_add_magma.map_add {α : Type u} {β : Type v} (f : α → β)
    (x : free_add_magma α) (y : free_add_magma α) :
    free_add_magma.map f (x + y) = free_add_magma.map f x + free_add_magma.map f y :=
  rfl

protected instance Mathlib.free_add_magma.monad : Monad free_add_magma := sorry

/-- Recursor on `free_magma` using `pure` instead of `of`. -/
protected def Mathlib.free_add_magma.rec_on'' {α : Type u} {C : free_add_magma α → Sort l}
    (x : free_add_magma α) (ih1 : (x : α) → C (pure x))
    (ih2 : (x y : free_add_magma α) → C x → C y → C (x + y)) : C x :=
  free_add_magma.rec_on' x ih1 ih2

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

@[simp] theorem Mathlib.free_add_magma.map_add' {α : Type u} {β : Type u} (f : α → β)
    (x : free_add_magma α) (y : free_add_magma α) : f <$> (x + y) = f <$> x + f <$> y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.pure_bind {α : Type u} {β : Type u}
    (f : α → free_add_magma β) (x : α) : pure x >>= f = f x :=
  rfl

@[simp] theorem mul_bind {α : Type u} {β : Type u} (f : α → free_magma β) (x : free_magma α)
    (y : free_magma α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  rfl

@[simp] theorem Mathlib.free_add_magma.pure_seq {α : Type u} {β : Type u} {f : α → β}
    {x : free_add_magma α} : pure f <*> x = f <$> x :=
  rfl

@[simp] theorem mul_seq {α : Type u} {β : Type u} {f : free_magma (α → β)} {g : free_magma (α → β)}
    {x : free_magma α} : f * g <*> x = (f <*> x) * (g <*> x) :=
  rfl

protected instance Mathlib.free_add_magma.is_lawful_monad : is_lawful_monad free_add_magma := sorry

end free_magma

/-- `free_magma` is traversable. -/
protected def free_magma.traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u}
    (F : α → m β) : free_magma α → m (free_magma β) :=
  sorry

/-- `free_add_magma` is traversable. -/
protected def free_add_magma.traverse {m : Type u → Type u} [Applicative m] {α : Type u}
    {β : Type u} (F : α → m β) : free_add_magma α → m (free_add_magma β) :=
  sorry

namespace free_magma

protected instance Mathlib.free_add_magma.traversable : traversable free_add_magma :=
  traversable.mk free_add_magma.traverse

@[simp] theorem Mathlib.free_add_magma.traverse_pure {α : Type u} {β : Type u} {m : Type u → Type u}
    [Applicative m] (F : α → m β) (x : α) : traverse F (pure x) = pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_pure' {α : Type u} {β : Type u}
    {m : Type u → Type u} [Applicative m] (F : α → m β) :
    traverse F ∘ pure = fun (x : α) => pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_add {α : Type u} {β : Type u} {m : Type u → Type u}
    [Applicative m] (F : α → m β) (x : free_add_magma α) (y : free_add_magma α) :
    traverse F (x + y) = Add.add <$> traverse F x <*> traverse F y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_add' {α : Type u} {β : Type u} {m : Type u → Type u}
    [Applicative m] (F : α → m β) :
    function.comp (traverse F) ∘ Add.add =
        fun (x y : free_add_magma α) => Add.add <$> traverse F x <*> traverse F y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_eq {α : Type u} {β : Type u} {m : Type u → Type u}
    [Applicative m] (F : α → m β) (x : free_add_magma α) :
    free_add_magma.traverse F x = traverse F x :=
  rfl

@[simp] theorem mul_map_seq {α : Type u} (x : free_magma α) (y : free_magma α) :
    Mul.mul <$> x <*> y = x * y :=
  rfl

protected instance Mathlib.free_add_magma.is_lawful_traversable :
    is_lawful_traversable free_add_magma :=
  is_lawful_traversable.mk sorry sorry sorry sorry

end free_magma

/-- Representation of an element of a free magma. -/
protected def free_magma.repr {α : Type u} [has_repr α] : free_magma α → string := sorry

/-- Representation of an element of a free additive magma. -/
protected def free_add_magma.repr {α : Type u} [has_repr α] : free_add_magma α → string := sorry

protected instance free_add_magma.has_repr {α : Type u} [has_repr α] :
    has_repr (free_add_magma α) :=
  has_repr.mk free_add_magma.repr

/-- Length of an element of a free magma. -/
def free_magma.length {α : Type u} : free_magma α → ℕ := sorry

/-- Length of an element of a free additive magma. -/
def free_add_magma.length {α : Type u} : free_add_magma α → ℕ := sorry

/-- Associativity relations for a magma. -/
inductive magma.free_semigroup.r (α : Type u) [Mul α] : α → α → Prop where
| intro : ∀ (x y z : α), magma.free_semigroup.r α (x * y * z) (x * (y * z))
| left : ∀ (w x y z : α), magma.free_semigroup.r α (w * (x * y * z)) (w * (x * (y * z)))

/-- Associativity relations for an additive magma. -/
inductive add_magma.free_add_semigroup.r (α : Type u) [Add α] : α → α → Prop where
| intro : ∀ (x y z : α), add_magma.free_add_semigroup.r α (x + y + z) (x + (y + z))
| left : ∀ (w x y z : α), add_magma.free_add_semigroup.r α (w + (x + y + z)) (w + (x + (y + z)))

namespace magma

/-- Free semigroup over a magma. -/
def free_semigroup (α : Type u) [Mul α] := Quot sorry

namespace free_semigroup

/-- Embedding from magma to its free semigroup. -/
def Mathlib.add_magma.free_add_semigroup.of {α : Type u} [Add α] :
    α → add_magma.free_add_semigroup α :=
  Quot.mk (add_magma.free_add_semigroup.r α)

protected instance Mathlib.add_magma.free_add_semigroup.inhabited {α : Type u} [Add α]
    [Inhabited α] : Inhabited (add_magma.free_add_semigroup α) :=
  { default := add_magma.free_add_semigroup.of Inhabited.default }

protected theorem Mathlib.add_magma.free_add_semigroup.induction_on {α : Type u} [Add α]
    {C : add_magma.free_add_semigroup α → Prop} (x : add_magma.free_add_semigroup α)
    (ih : ∀ (x : α), C (add_magma.free_add_semigroup.of x)) : C x :=
  quot.induction_on x ih

theorem of_mul_assoc {α : Type u} [Mul α] (x : α) (y : α) (z : α) :
    of (x * y * z) = of (x * (y * z)) :=
  quot.sound (r.intro x y z)

theorem of_mul_assoc_left {α : Type u} [Mul α] (w : α) (x : α) (y : α) (z : α) :
    of (w * (x * y * z)) = of (w * (x * (y * z))) :=
  quot.sound (r.left w x y z)

theorem of_mul_assoc_right {α : Type u} [Mul α] (w : α) (x : α) (y : α) (z : α) :
    of (w * x * y * z) = of (w * (x * y) * z) :=
  sorry

protected instance semigroup {α : Type u} [Mul α] : semigroup (free_semigroup α) :=
  semigroup.mk
    (fun (x y : free_semigroup α) =>
      quot.lift_on x (fun (p : α) => quot.lift_on y (fun (q : α) => Quot.mk (r α) (p * q)) sorry)
        sorry)
    sorry

theorem Mathlib.add_magma.free_add_semigroup.of_add {α : Type u} [Add α] (x : α) (y : α) :
    add_magma.free_add_semigroup.of (x + y) =
        add_magma.free_add_semigroup.of x + add_magma.free_add_semigroup.of y :=
  rfl

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `magma.free_semigroup α → β`
given a semigroup `β`. -/
def lift {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β)
    (hf : ∀ (x y : α), f (x * y) = f x * f y) : free_semigroup α → β :=
  Quot.lift f sorry

@[simp] theorem lift_of {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β)
    {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : α) : lift f hf (of x) = f x :=
  rfl

@[simp] theorem lift_mul {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β)
    {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : free_semigroup α) (y : free_semigroup α) :
    lift f hf (x * y) = lift f hf x * lift f hf y :=
  quot.induction_on x fun (p : α) => quot.induction_on y fun (q : α) => hf p q

theorem Mathlib.add_magma.free_add_semigroup.lift_unique {α : Type u} [Add α] {β : Type v}
    [add_semigroup β] (f : add_magma.free_add_semigroup α → β)
    (hf : ∀ (x y : add_magma.free_add_semigroup α), f (x + y) = f x + f y) :
    f =
        add_magma.free_add_semigroup.lift (f ∘ add_magma.free_add_semigroup.of)
          fun (p q : α) =>
            hf (add_magma.free_add_semigroup.of p) (add_magma.free_add_semigroup.of q) :=
  funext fun (x : add_magma.free_add_semigroup α) => quot.induction_on x fun (p : α) => rfl

/-- From a magma homomorphism `α → β` to a semigroup homomorphism
`magma.free_semigroup α → magma.free_semigroup β`. -/
def Mathlib.add_magma.free_add_semigroup.map {α : Type u} [Add α] {β : Type v} [Add β] (f : α → β)
    (hf : ∀ (x y : α), f (x + y) = f x + f y) :
    add_magma.free_add_semigroup α → add_magma.free_add_semigroup β :=
  add_magma.free_add_semigroup.lift (add_magma.free_add_semigroup.of ∘ f) sorry

@[simp] theorem Mathlib.add_magma.free_add_semigroup.map_of {α : Type u} [Add α] {β : Type v}
    [Add β] (f : α → β) {hf : ∀ (x y : α), f (x + y) = f x + f y} (x : α) :
    add_magma.free_add_semigroup.map f hf (add_magma.free_add_semigroup.of x) =
        add_magma.free_add_semigroup.of (f x) :=
  rfl

@[simp] theorem map_mul {α : Type u} [Mul α] {β : Type v} [Mul β] (f : α → β)
    {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : free_semigroup α) (y : free_semigroup α) :
    map f hf (x * y) = map f hf x * map f hf y :=
  lift_mul (of ∘ f) x y

end free_semigroup

end magma

/-- Free semigroup over a given alphabet.
(Note: In this definition, the free semigroup does not contain the empty word.) -/
def free_semigroup (α : Type u) := α × List α

namespace free_semigroup

protected instance semigroup {α : Type u} : semigroup (free_semigroup α) :=
  semigroup.mk
    (fun (L1 L2 : free_semigroup α) => (prod.fst L1, prod.snd L1 ++ prod.fst L2 :: prod.snd L2))
    sorry

/-- The embedding `α → free_semigroup α`. -/
def Mathlib.free_add_semigroup.of {α : Type u} (x : α) : free_add_semigroup α := (x, [])

protected instance Mathlib.free_add_semigroup.inhabited {α : Type u} [Inhabited α] :
    Inhabited (free_add_semigroup α) :=
  { default := free_add_semigroup.of Inhabited.default }

/-- Recursor for free semigroup using `of` and `*`. -/
protected def Mathlib.free_add_semigroup.rec_on {α : Type u} {C : free_add_semigroup α → Sort l}
    (x : free_add_semigroup α) (ih1 : (x : α) → C (free_add_semigroup.of x))
    (ih2 :
      (x : α) →
        (y : free_add_semigroup α) →
          C (free_add_semigroup.of x) → C y → C (free_add_semigroup.of x + y)) :
    C x :=
  prod.rec_on x
    fun (f : α) (s : List α) =>
      list.rec_on s ih1
        (fun (hd : α) (tl : List α) (ih : (_a : α) → C (_a, tl)) (f : α) =>
          ih2 f (hd, tl) (ih1 f) (ih hd))
        f

end free_semigroup

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_semigroup.lift' {α : Type u} {β : Type v} [semigroup β] (f : α → β) : α → List α → β :=
  sorry

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_add_semigroup.lift' {α : Type u} {β : Type v} [add_semigroup β] (f : α → β) :
    α → List α → β :=
  sorry

namespace free_semigroup

/-- Lifts a function `α → β` to a semigroup homomorphism `free_semigroup α → β` given
a semigroup `β`. -/
def lift {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : free_semigroup α) : β :=
  lift' f (prod.fst x) (prod.snd x)

@[simp] theorem lift_of {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : α) :
    lift f (of x) = f x :=
  rfl

theorem lift_of_mul {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : α)
    (y : free_semigroup α) : lift f (of x * y) = f x * lift f y :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.lift_add {α : Type u} {β : Type v} [add_semigroup β]
    (f : α → β) (x : free_add_semigroup α) (y : free_add_semigroup α) :
    free_add_semigroup.lift f (x + y) = free_add_semigroup.lift f x + free_add_semigroup.lift f y :=
  sorry

theorem Mathlib.free_add_semigroup.lift_unique {α : Type u} {β : Type v} [add_semigroup β]
    (f : free_add_semigroup α → β) (hf : ∀ (x y : free_add_semigroup α), f (x + y) = f x + f y) :
    f = free_add_semigroup.lift (f ∘ free_add_semigroup.of) :=
  sorry

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
def Mathlib.free_add_semigroup.map {α : Type u} {β : Type v} (f : α → β) :
    free_add_semigroup α → free_add_semigroup β :=
  free_add_semigroup.lift (free_add_semigroup.of ∘ f)

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

@[simp] theorem Mathlib.free_add_semigroup.map_add {α : Type u} {β : Type v} (f : α → β)
    (x : free_add_semigroup α) (y : free_add_semigroup α) :
    free_add_semigroup.map f (x + y) = free_add_semigroup.map f x + free_add_semigroup.map f y :=
  free_add_semigroup.lift_add (free_add_semigroup.of ∘ f) x y

protected instance Mathlib.free_add_semigroup.monad : Monad free_add_semigroup := sorry

/-- Recursor that uses `pure` instead of `of`. -/
def rec_on' {α : Type u} {C : free_semigroup α → Sort l} (x : free_semigroup α)
    (ih1 : (x : α) → C (pure x))
    (ih2 : (x : α) → (y : free_semigroup α) → C (pure x) → C y → C (pure x * y)) : C x :=
  free_semigroup.rec_on x ih1 ih2

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

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

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_semigroup β) (x : α) :
    pure x >>= f = f x :=
  rfl

@[simp] theorem mul_bind {α : Type u} {β : Type u} (f : α → free_semigroup β) (x : free_semigroup α)
    (y : free_semigroup α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  lift_mul f x y

@[simp] theorem Mathlib.free_add_semigroup.pure_seq {α : Type u} {β : Type u} {f : α → β}
    {x : free_add_semigroup α} : pure f <*> x = f <$> x :=
  rfl

@[simp] theorem mul_seq {α : Type u} {β : Type u} {f : free_semigroup (α → β)}
    {g : free_semigroup (α → β)} {x : free_semigroup α} : f * g <*> x = (f <*> x) * (g <*> x) :=
  mul_bind
    (fun (_x : α → β) =>
      (fun (α β : Type u) (f : α → β) (x : free_semigroup α) => lift (of ∘ f) x) α β _x x)
    f g

protected instance Mathlib.free_add_semigroup.is_lawful_monad :
    is_lawful_monad free_add_semigroup :=
  sorry

/-- `free_semigroup` is traversable. -/
protected def Mathlib.free_add_semigroup.traverse {m : Type u → Type u} [Applicative m] {α : Type u}
    {β : Type u} (F : α → m β) (x : free_add_semigroup α) : m (free_add_semigroup β) :=
  free_add_semigroup.rec_on' x (fun (x : α) => pure <$> F x)
    fun (x : α) (y : free_add_semigroup α) (ihx ihy : m (free_add_semigroup β)) =>
      Add.add <$> ihx <*> ihy

protected instance Mathlib.free_add_semigroup.traversable : traversable free_add_semigroup :=
  traversable.mk free_add_semigroup.traverse

@[simp] theorem traverse_pure {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m]
    (F : α → m β) (x : α) : traverse F (pure x) = pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.traverse_pure' {α : Type u} {β : Type u}
    {m : Type u → Type u} [Applicative m] (F : α → m β) :
    traverse F ∘ pure = fun (x : α) => pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.traverse_add {α : Type u} {β : Type u}
    {m : Type u → Type u} [Applicative m] (F : α → m β) [is_lawful_applicative m]
    (x : free_add_semigroup α) (y : free_add_semigroup α) :
    traverse F (x + y) = Add.add <$> traverse F x <*> traverse F y :=
  sorry

@[simp] theorem Mathlib.free_add_semigroup.traverse_add' {α : Type u} {β : Type u}
    {m : Type u → Type u} [Applicative m] (F : α → m β) [is_lawful_applicative m] :
    function.comp (traverse F) ∘ Add.add =
        fun (x y : free_add_semigroup α) => Add.add <$> traverse F x <*> traverse F y :=
  funext
    fun (x : free_add_semigroup α) =>
      funext fun (y : free_add_semigroup α) => free_add_semigroup.traverse_add F x y

@[simp] theorem Mathlib.free_add_semigroup.traverse_eq {α : Type u} {β : Type u}
    {m : Type u → Type u} [Applicative m] (F : α → m β) (x : free_add_semigroup α) :
    free_add_semigroup.traverse F x = traverse F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.add_map_seq {α : Type u} (x : free_add_semigroup α)
    (y : free_add_semigroup α) : Add.add <$> x <*> y = x + y :=
  rfl

protected instance Mathlib.free_add_semigroup.is_lawful_traversable :
    is_lawful_traversable free_add_semigroup :=
  is_lawful_traversable.mk sorry sorry sorry sorry

protected instance Mathlib.free_add_semigroup.decidable_eq {α : Type u} [DecidableEq α] :
    DecidableEq (free_add_semigroup α) :=
  prod.decidable_eq

end free_semigroup

/-- Isomorphism between `magma.free_semigroup (free_magma α)` and `free_semigroup α`. -/
def free_add_semigroup_free_add_magma (α : Type u) :
    add_magma.free_add_semigroup (free_add_magma α) ≃ free_add_semigroup α :=
  equiv.mk (add_magma.free_add_semigroup.lift (free_add_magma.lift free_add_semigroup.of) sorry)
    (free_add_semigroup.lift (add_magma.free_add_semigroup.of ∘ free_add_magma.of)) sorry sorry

@[simp] theorem free_semigroup_free_magma_mul {α : Type u} (x : magma.free_semigroup (free_magma α))
    (y : magma.free_semigroup (free_magma α)) :
    coe_fn (free_semigroup_free_magma α) (x * y) =
        coe_fn (free_semigroup_free_magma α) x * coe_fn (free_semigroup_free_magma α) y :=
  magma.free_semigroup.lift_mul (free_magma.lift free_semigroup.of) x y

end Mathlib


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston
-/
import group_theory.submonoid.operations
import data.equiv.mul_add
import data.setoid.basic
import algebra.group.prod

/-!
# Congruence relations

This file defines congruence relations: equivalence relations that preserve a binary operation,
which in this case is multiplication or addition. The principal definition is a `structure`
extending a `setoid` (an equivalence relation), and the inductive definition of the smallest
congruence relation containing a binary relation is also given (see `con_gen`).

The file also proves basic properties of the quotient of a type by a congruence relation, and the
complete lattice of congruence relations on a type. We then establish an order-preserving bijection
between the set of congruence relations containing a congruence relation `c` and the set of
congruence relations on the quotient by `c`.

The second half of the file concerns congruence relations on monoids, in which case the
quotient by the congruence relation is also a monoid. There are results about the universal
property of quotients of monoids, and the isomorphism theorems for monoids.

## Implementation notes

The inductive definition of a congruence relation could be a nested inductive type, defined using
the equivalence closure of a binary relation `eqv_gen`, but the recursor generated does not work.
A nested inductive definition could conceivably shorten proofs, because they would allow invocation
of the corresponding lemmas about `eqv_gen`.

The lemmas `refl`, `symm` and `trans` are not tagged with `@[refl]`, `@[symm]`, and `@[trans]`
respectively as these tags do not work on a structure coerced to a binary relation.

There is a coercion from elements of a type to the element's equivalence class under a
congruence relation.

A congruence relation on a monoid `M` can be thought of as a submonoid of `M × M` for which
membership is an equivalence relation, but whilst this fact is established in the file, it is not
used, since this perspective adds more layers of definitional unfolding.

## Tags

congruence, congruence relation, quotient, quotient by congruence relation, monoid,
quotient monoid, isomorphism theorems
-/

variables (M : Type*) {N : Type*} {P : Type*}

open function setoid

/-- A congruence relation on a type with an addition is an equivalence relation which
    preserves addition. -/
structure add_con [has_add M] extends setoid M :=
(add' : ∀ {w x y z}, r w x → r y z → r (w + y) (x + z))

/-- A congruence relation on a type with a multiplication is an equivalence relation which
    preserves multiplication. -/
@[to_additive add_con] structure con [has_mul M] extends setoid M :=
(mul' : ∀ {w x y z}, r w x → r y z → r (w * y) (x * z))

/-- The equivalence relation underlying an additive congruence relation. -/
add_decl_doc add_con.to_setoid

/-- The equivalence relation underlying a multiplicative congruence relation. -/
add_decl_doc con.to_setoid

variables {M}

/-- The inductively defined smallest additive congruence relation containing a given binary
    relation. -/
inductive add_con_gen.rel [has_add M] (r : M → M → Prop) : M → M → Prop
| of : Π x y, r x y → add_con_gen.rel x y
| refl : Π x, add_con_gen.rel x x
| symm : Π x y, add_con_gen.rel x y → add_con_gen.rel y x
| trans : Π x y z, add_con_gen.rel x y → add_con_gen.rel y z → add_con_gen.rel x z
| add : Π w x y z, add_con_gen.rel w x → add_con_gen.rel y z → add_con_gen.rel (w + y) (x + z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
@[to_additive add_con_gen.rel]
inductive con_gen.rel [has_mul M] (r : M → M → Prop) : M → M → Prop
| of : Π x y, r x y → con_gen.rel x y
| refl : Π x, con_gen.rel x x
| symm : Π x y, con_gen.rel x y → con_gen.rel y x
| trans : Π x y z, con_gen.rel x y → con_gen.rel y z → con_gen.rel x z
| mul : Π w x y z, con_gen.rel w x → con_gen.rel y z → con_gen.rel (w * y) (x * z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
@[to_additive add_con_gen "The inductively defined smallest additive congruence relation containing
a given binary relation."]
def con_gen [has_mul M] (r : M → M → Prop) : con M :=
⟨⟨con_gen.rel r, ⟨con_gen.rel.refl, con_gen.rel.symm, con_gen.rel.trans⟩⟩, con_gen.rel.mul⟩

namespace con

section
variables [has_mul M] [has_mul N] [has_mul P] (c : con M)

@[to_additive]
instance : inhabited (con M) :=
⟨con_gen empty_relation⟩

/-- A coercion from a congruence relation to its underlying binary relation. -/
@[to_additive "A coercion from an additive congruence relation to its underlying binary relation."]
instance : has_coe_to_fun (con M) (λ _, M → M → Prop) := ⟨λ c, λ x y, @setoid.r _ c.to_setoid x y⟩

@[simp, to_additive] lemma rel_eq_coe (c : con M) : c.r = c := rfl

/-- Congruence relations are reflexive. -/
@[to_additive "Additive congruence relations are reflexive."]
protected lemma refl (x) : c x x := c.to_setoid.refl' x

/-- Congruence relations are symmetric. -/
@[to_additive "Additive congruence relations are symmetric."]
protected lemma symm : ∀ {x y}, c x y → c y x := λ _ _ h, c.to_setoid.symm' h

/-- Congruence relations are transitive. -/
@[to_additive "Additive congruence relations are transitive."]
protected lemma trans : ∀ {x y z}, c x y → c y z → c x z :=
λ _ _ _ h, c.to_setoid.trans' h

/-- Multiplicative congruence relations preserve multiplication. -/
@[to_additive "Additive congruence relations preserve addition."]
protected lemma mul : ∀ {w x y z}, c w x → c y z → c (w * y) (x * z) :=
λ _ _ _ _ h1 h2, c.mul' h1 h2

@[simp, to_additive] lemma rel_mk {s : setoid M} {h a b} :
  con.mk s h a b ↔ r a b :=
iff.rfl

/-- Given a type `M` with a multiplication, a congruence relation `c` on `M`, and elements of `M`
    `x, y`, `(x, y) ∈ M × M` iff `x` is related to `y` by `c`. -/
@[to_additive "Given a type `M` with an addition, `x, y ∈ M`, and an additive congruence relation
`c` on `M`, `(x, y) ∈ M × M` iff `x` is related to `y` by `c`."]
instance : has_mem (M × M) (con M) := ⟨λ x c, c x.1 x.2⟩

variables {c}

/-- The map sending a congruence relation to its underlying binary relation is injective. -/
@[to_additive "The map sending an additive congruence relation to its underlying binary relation
is injective."]
lemma ext' {c d : con M} (H : c.r = d.r) : c = d :=
by { rcases c with ⟨⟨⟩⟩, rcases d with ⟨⟨⟩⟩, cases H, congr, }

/-- Extensionality rule for congruence relations. -/
@[ext, to_additive "Extensionality rule for additive congruence relations."]
lemma ext {c d : con M} (H : ∀ x y, c x y ↔ d x y) : c = d :=
ext' $ by ext; apply H

/-- The map sending a congruence relation to its underlying equivalence relation is injective. -/
@[to_additive "The map sending an additive congruence relation to its underlying equivalence
relation is injective."]
lemma to_setoid_inj {c d : con M} (H : c.to_setoid = d.to_setoid) : c = d :=
ext $ ext_iff.1 H

/-- Iff version of extensionality rule for congruence relations. -/
@[to_additive "Iff version of extensionality rule for additive congruence relations."]
lemma ext_iff {c d : con M} : (∀ x y, c x y ↔ d x y) ↔ c = d :=
⟨ext, λ h _ _, h ▸ iff.rfl⟩

/-- Two congruence relations are equal iff their underlying binary relations are equal. -/
@[to_additive "Two additive congruence relations are equal iff their underlying binary relations
are equal."]
lemma ext'_iff {c d : con M} : c.r = d.r ↔ c = d :=
⟨ext', λ h, h ▸ rfl⟩

/-- The kernel of a multiplication-preserving function as a congruence relation. -/
@[to_additive "The kernel of an addition-preserving function as an additive congruence relation."]
def mul_ker (f : M → P) (h : ∀ x y, f (x * y) = f x * f y) : con M :=
{ to_setoid := setoid.ker f,
  mul' := λ _ _ _ _ h1 h2, by { dsimp [setoid.ker, on_fun] at *, rw [h, h1, h2, h], } }

/-- Given types with multiplications `M, N`, the product of two congruence relations `c` on `M` and
    `d` on `N`: `(x₁, x₂), (y₁, y₂) ∈ M × N` are related by `c.prod d` iff `x₁` is related to `y₁`
    by `c` and `x₂` is related to `y₂` by `d`. -/
@[to_additive prod "Given types with additions `M, N`, the product of two congruence relations
`c` on `M` and `d` on `N`: `(x₁, x₂), (y₁, y₂) ∈ M × N` are related by `c.prod d` iff `x₁`
is related to `y₁` by `c` and `x₂` is related to `y₂` by `d`."]
protected def prod (c : con M) (d : con N) : con (M × N) :=
{ mul' := λ _ _ _ _ h1 h2, ⟨c.mul h1.1 h2.1, d.mul h1.2 h2.2⟩, ..c.to_setoid.prod d.to_setoid }

/-- The product of an indexed collection of congruence relations. -/
@[to_additive "The product of an indexed collection of additive congruence relations."]
def pi {ι : Type*} {f : ι → Type*} [Π i, has_mul (f i)]
  (C : Π i, con (f i)) : con (Π i, f i) :=
{ mul' := λ _ _ _ _ h1 h2 i, (C i).mul (h1 i) (h2 i), ..@pi_setoid _ _ $ λ i, (C i).to_setoid }

variables (c)

-- Quotients

/-- Defining the quotient by a congruence relation of a type with a multiplication. -/
@[to_additive "Defining the quotient by an additive congruence relation of a type with
an addition."]
protected def quotient := quotient $ c.to_setoid

/-- Coercion from a type with a multiplication to its quotient by a congruence relation.

See Note [use has_coe_t]. -/
@[to_additive "Coercion from a type with an addition to its quotient by an additive congruence
relation", priority 0]
instance : has_coe_t M c.quotient := ⟨@quotient.mk _ c.to_setoid⟩

/-- The quotient by a decidable congruence relation has decidable equality. -/
@[to_additive "The quotient by a decidable additive congruence relation has decidable equality.",
  priority 500] -- Lower the priority since it unifies with any quotient type.
instance [d : ∀ a b, decidable (c a b)] : decidable_eq c.quotient :=
@quotient.decidable_eq M c.to_setoid d

@[simp, to_additive] lemma quot_mk_eq_coe {M : Type*} [has_mul M] (c : con M) (x : M) :
  quot.mk c x = (x : c.quotient) :=
rfl

/-- The function on the quotient by a congruence relation `c` induced by a function that is
    constant on `c`'s equivalence classes. -/
@[elab_as_eliminator, to_additive "The function on the quotient by a congruence relation `c`
induced by a function that is constant on `c`'s equivalence classes."]
protected def lift_on {β} {c : con M} (q : c.quotient) (f : M → β)
  (h : ∀ a b, c a b → f a = f b) : β := quotient.lift_on' q f h

/-- The binary function on the quotient by a congruence relation `c` induced by a binary function
    that is constant on `c`'s equivalence classes. -/
@[elab_as_eliminator, to_additive "The binary function on the quotient by a congruence relation `c`
induced by a binary function that is constant on `c`'s equivalence classes."]
protected def lift_on₂ {β} {c : con M} (q r : c.quotient) (f : M → M → β)
  (h : ∀ a₁ a₂ b₁ b₂, c a₁ b₁ → c a₂ b₂ → f a₁ a₂ = f b₁ b₂) : β := quotient.lift_on₂' q r f h

/-- A version of `quotient.hrec_on₂'` for quotients by `con`. -/
@[to_additive "A version of `quotient.hrec_on₂'` for quotients by `add_con`."]
protected def hrec_on₂ {cM : con M} {cN : con N} {φ : cM.quotient → cN.quotient → Sort*}
  (a : cM.quotient) (b : cN.quotient)
  (f : Π (x : M) (y : N), φ x y) (h : ∀ x y x' y', cM x x' → cN y y' → f x y == f x' y') :
  φ a b :=
quotient.hrec_on₂' a b f h

@[simp, to_additive] lemma hrec_on₂_coe {cM : con M} {cN : con N}
  {φ : cM.quotient → cN.quotient → Sort*} (a : M) (b : N)
  (f : Π (x : M) (y : N), φ x y) (h : ∀ x y x' y', cM x x' → cN y y' → f x y == f x' y') :
  con.hrec_on₂ ↑a ↑b f h = f a b :=
rfl

variables {c}

/-- The inductive principle used to prove propositions about the elements of a quotient by a
    congruence relation. -/
@[elab_as_eliminator, to_additive "The inductive principle used to prove propositions about
the elements of a quotient by an additive congruence relation."]
protected lemma induction_on {C : c.quotient → Prop} (q : c.quotient) (H : ∀ x : M, C x) : C q :=
quotient.induction_on' q H

/-- A version of `con.induction_on` for predicates which take two arguments. -/
@[elab_as_eliminator, to_additive "A version of `add_con.induction_on` for predicates which take
two arguments."]
protected lemma induction_on₂ {d : con N} {C : c.quotient → d.quotient → Prop}
  (p : c.quotient) (q : d.quotient) (H : ∀ (x : M) (y : N), C x y) : C p q :=
quotient.induction_on₂' p q H

variables (c)

/-- Two elements are related by a congruence relation `c` iff they are represented by the same
    element of the quotient by `c`. -/
@[simp, to_additive "Two elements are related by an additive congruence relation `c` iff they
are represented by the same element of the quotient by `c`."]
protected lemma eq {a b : M} : (a : c.quotient) = b ↔ c a b :=
quotient.eq'

/-- The multiplication induced on the quotient by a congruence relation on a type with a
    multiplication. -/
@[to_additive "The addition induced on the quotient by an additive congruence relation on a type
with an addition."]
instance has_mul : has_mul c.quotient :=
⟨λ x y, quotient.lift_on₂' x y (λ w z, ((w * z : M) : c.quotient))
     $ λ _ _ _ _ h1 h2, c.eq.2 $ c.mul h1 h2⟩

/-- The kernel of the quotient map induced by a congruence relation `c` equals `c`. -/
@[simp, to_additive "The kernel of the quotient map induced by an additive congruence relation
`c` equals `c`."]
lemma mul_ker_mk_eq : mul_ker (coe : M → c.quotient) (λ x y, rfl) = c :=
ext $ λ x y, quotient.eq'

variables {c}

/-- The coercion to the quotient of a congruence relation commutes with multiplication (by
    definition). -/
@[simp, to_additive "The coercion to the quotient of an additive congruence relation commutes with
addition (by definition)."]
lemma coe_mul (x y : M) : (↑(x * y) : c.quotient) = ↑x * ↑y := rfl

/-- Definition of the function on the quotient by a congruence relation `c` induced by a function
    that is constant on `c`'s equivalence classes. -/
@[simp, to_additive "Definition of the function on the quotient by an additive congruence
relation `c` induced by a function that is constant on `c`'s equivalence classes."]
protected lemma lift_on_coe {β} (c : con M) (f : M → β)
  (h : ∀ a b, c a b → f a = f b) (x : M) :
  con.lift_on (x : c.quotient) f h = f x := rfl

/-- Makes an isomorphism of quotients by two congruence relations, given that the relations are
    equal. -/
@[to_additive "Makes an additive isomorphism of quotients by two additive congruence relations,
given that the relations are equal."]
protected def congr {c d : con M} (h : c = d) :  c.quotient ≃* d.quotient :=
{ map_mul' := λ x y, by rcases x; rcases y; refl,
  ..quotient.congr (equiv.refl M) $ by apply ext_iff.2 h }

-- The complete lattice of congruence relations on a type

/-- For congruence relations `c, d` on a type `M` with a multiplication, `c ≤ d` iff `∀ x y ∈ M`,
    `x` is related to `y` by `d` if `x` is related to `y` by `c`. -/
@[to_additive "For additive congruence relations `c, d` on a type `M` with an addition, `c ≤ d` iff
`∀ x y ∈ M`, `x` is related to `y` by `d` if `x` is related to `y` by `c`."]
instance : has_le (con M) := ⟨λ c d, ∀ ⦃x y⦄, c x y → d x y⟩

/-- Definition of `≤` for congruence relations. -/
@[to_additive "Definition of `≤` for additive congruence relations."]
theorem le_def {c d : con M} : c ≤ d ↔ ∀ {x y}, c x y → d x y := iff.rfl

/-- The infimum of a set of congruence relations on a given type with a multiplication. -/
@[to_additive "The infimum of a set of additive congruence relations on a given type with
an addition."]
instance : has_Inf (con M) :=
⟨λ S, ⟨⟨λ x y, ∀ c : con M, c ∈ S → c x y,
⟨λ x c hc, c.refl x, λ _ _ h c hc, c.symm $ h c hc,
 λ _ _ _ h1 h2 c hc, c.trans (h1 c hc) $ h2 c hc⟩⟩,
 λ _ _ _ _ h1 h2 c hc, c.mul (h1 c hc) $ h2 c hc⟩⟩

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying equivalence relation. -/
@[to_additive "The infimum of a set of additive congruence relations is the same as the infimum of
the set's image under the map to the underlying equivalence relation."]
lemma Inf_to_setoid (S : set (con M)) : (Inf S).to_setoid = Inf (to_setoid '' S) :=
setoid.ext' $ λ x y, ⟨λ h r ⟨c, hS, hr⟩, by rw ←hr; exact h c hS,
  λ h c hS, h c.to_setoid ⟨c, hS, rfl⟩⟩

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying binary relation. -/
@[to_additive "The infimum of a set of additive congruence relations is the same as the infimum
of the set's image under the map to the underlying binary relation."]
lemma Inf_def (S : set (con M)) : ⇑(Inf S) = Inf (@set.image (con M) (M → M → Prop) coe_fn S) :=
by { ext, simp only [Inf_image, infi_apply, infi_Prop_eq], refl }

@[to_additive]
instance : partial_order (con M) :=
{ le := (≤),
  lt := λ c d, c ≤ d ∧ ¬d ≤ c,
  le_refl := λ c _ _, id,
  le_trans := λ c1 c2 c3 h1 h2 x y h, h2 $ h1 h,
  lt_iff_le_not_le := λ _ _, iff.rfl,
  le_antisymm := λ c d hc hd, ext $ λ x y, ⟨λ h, hc h, λ h, hd h⟩ }

/-- The complete lattice of congruence relations on a given type with a multiplication. -/
@[to_additive "The complete lattice of additive congruence relations on a given type with
an addition."]
instance : complete_lattice (con M) :=
{ inf := λ c d, ⟨(c.to_setoid ⊓ d.to_setoid), λ _ _ _ _ h1 h2, ⟨c.mul h1.1 h2.1, d.mul h1.2 h2.2⟩⟩,
  inf_le_left := λ _ _ _ _ h, h.1,
  inf_le_right := λ _ _ _ _ h, h.2,
  le_inf := λ _ _ _ hb hc _ _ h, ⟨hb h, hc h⟩,
  top := { mul' := by tauto, ..setoid.complete_lattice.top},
  le_top := λ _ _ _ h, trivial,
  bot := { mul' := λ _ _ _ _ h1 h2, h1 ▸ h2 ▸ rfl, ..setoid.complete_lattice.bot},
  bot_le := λ c x y h, h ▸ c.refl x,
  .. complete_lattice_of_Inf (con M) $ assume s,
    ⟨λ r hr x y h, (h : ∀ r ∈ s, (r : con M) x y) r hr, λ r hr x y h r' hr', hr hr' h⟩ }

/-- The infimum of two congruence relations equals the infimum of the underlying binary
    operations. -/
@[to_additive "The infimum of two additive congruence relations equals the infimum of the
underlying binary operations."]
lemma inf_def {c d : con M} : (c ⊓ d).r = c.r ⊓ d.r := rfl

/-- Definition of the infimum of two congruence relations. -/
@[to_additive "Definition of the infimum of two additive congruence relations."]
theorem inf_iff_and {c d : con M} {x y} : (c ⊓ d) x y ↔ c x y ∧ d x y := iff.rfl

/-- The inductively defined smallest congruence relation containing a binary relation `r` equals
    the infimum of the set of congruence relations containing `r`. -/
@[to_additive add_con_gen_eq "The inductively defined smallest additive congruence relation
containing a binary relation `r` equals the infimum of the set of additive congruence relations
containing `r`."]
theorem con_gen_eq (r : M → M → Prop) :
  con_gen r = Inf {s : con M | ∀ x y, r x y → s x y} :=
le_antisymm
  (λ x y H, con_gen.rel.rec_on H (λ _ _ h _ hs, hs _ _ h) (con.refl _) (λ _ _ _, con.symm _)
    (λ _ _ _ _ _, con.trans _)
    $ λ w x y z _ _ h1 h2 c hc, c.mul (h1 c hc) $ h2 c hc)
  (Inf_le (λ _ _, con_gen.rel.of _ _))

/-- The smallest congruence relation containing a binary relation `r` is contained in any
    congruence relation containing `r`. -/
@[to_additive add_con_gen_le "The smallest additive congruence relation containing a binary
relation `r` is contained in any additive congruence relation containing `r`."]
theorem con_gen_le {r : M → M → Prop} {c : con M} (h : ∀ x y, r x y → @setoid.r _ c.to_setoid x y) :
  con_gen r ≤ c :=
by rw con_gen_eq; exact Inf_le h

/-- Given binary relations `r, s` with `r` contained in `s`, the smallest congruence relation
    containing `s` contains the smallest congruence relation containing `r`. -/
@[to_additive add_con_gen_mono "Given binary relations `r, s` with `r` contained in `s`, the
smallest additive congruence relation containing `s` contains the smallest additive congruence
relation containing `r`."]
theorem con_gen_mono {r s : M → M → Prop} (h : ∀ x y, r x y → s x y) :
  con_gen r ≤ con_gen s :=
con_gen_le $ λ x y hr, con_gen.rel.of _ _ $ h x y hr

/-- Congruence relations equal the smallest congruence relation in which they are contained. -/
@[simp, to_additive add_con_gen_of_add_con "Additive congruence relations equal the smallest
additive congruence relation in which they are contained."]
lemma con_gen_of_con (c : con M) : con_gen c = c :=
le_antisymm (by rw con_gen_eq; exact Inf_le (λ _ _, id)) con_gen.rel.of

/-- The map sending a binary relation to the smallest congruence relation in which it is
    contained is idempotent. -/
@[simp, to_additive add_con_gen_idem "The map sending a binary relation to the smallest additive
congruence relation in which it is contained is idempotent."]
lemma con_gen_idem (r : M → M → Prop) :
  con_gen (con_gen r) = con_gen r :=
con_gen_of_con _

/-- The supremum of congruence relations `c, d` equals the smallest congruence relation containing
    the binary relation '`x` is related to `y` by `c` or `d`'. -/
@[to_additive sup_eq_add_con_gen "The supremum of additive congruence relations `c, d` equals the
smallest additive congruence relation containing the binary relation '`x` is related to `y`
by `c` or `d`'."]
lemma sup_eq_con_gen (c d : con M) :
  c ⊔ d = con_gen (λ x y, c x y ∨ d x y) :=
begin
  rw con_gen_eq,
  apply congr_arg Inf,
  simp only [le_def, or_imp_distrib, ← forall_and_distrib]
end

/-- The supremum of two congruence relations equals the smallest congruence relation containing
    the supremum of the underlying binary operations. -/
@[to_additive "The supremum of two additive congruence relations equals the smallest additive
congruence relation containing the supremum of the underlying binary operations."]
lemma sup_def {c d : con M} : c ⊔ d = con_gen (c.r ⊔ d.r) :=
by rw sup_eq_con_gen; refl

/-- The supremum of a set of congruence relations `S` equals the smallest congruence relation
    containing the binary relation 'there exists `c ∈ S` such that `x` is related to `y` by
    `c`'. -/
@[to_additive Sup_eq_add_con_gen "The supremum of a set of additive congruence relations `S` equals
the smallest additive congruence relation containing the binary relation 'there exists `c ∈ S`
such that `x` is related to `y` by `c`'."]
lemma Sup_eq_con_gen (S : set (con M)) :
  Sup S = con_gen (λ x y, ∃ c : con M, c ∈ S ∧ c x y) :=
begin
  rw con_gen_eq,
  apply congr_arg Inf,
  ext,
  exact ⟨λ h _ _ ⟨r, hr⟩, h hr.1 hr.2,
         λ h r hS _ _ hr, h _ _ ⟨r, hS, hr⟩⟩,
end

/-- The supremum of a set of congruence relations is the same as the smallest congruence relation
    containing the supremum of the set's image under the map to the underlying binary relation. -/
@[to_additive "The supremum of a set of additive congruence relations is the same as the smallest
additive congruence relation containing the supremum of the set's image under the map to the
underlying binary relation."]
lemma Sup_def {S : set (con M)} :
  Sup S = con_gen (Sup (@set.image (con M) (M → M → Prop) coe_fn S)) :=
begin
  rw [Sup_eq_con_gen, Sup_image],
  congr' with x y,
  simp only [Sup_image, supr_apply, supr_Prop_eq, exists_prop, rel_eq_coe]
end

variables (M)

/-- There is a Galois insertion of congruence relations on a type with a multiplication `M` into
    binary relations on `M`. -/
@[to_additive "There is a Galois insertion of additive congruence relations on a type with
an addition `M` into binary relations on `M`."]
protected noncomputable def gi :
  @galois_insertion (M → M → Prop) (con M) _ _ con_gen coe_fn :=
{ choice := λ r h, con_gen r,
  gc := λ r c, ⟨λ H _ _ h, H $ con_gen.rel.of _ _ h, λ H, con_gen_of_con c ▸ con_gen_mono H⟩,
  le_l_u := λ x, (con_gen_of_con x).symm ▸ le_refl x,
  choice_eq := λ _ _, rfl }

variables {M} (c)

/-- Given a function `f`, the smallest congruence relation containing the binary relation on `f`'s
    image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)`
    by a congruence relation `c`.' -/
@[to_additive "Given a function `f`, the smallest additive congruence relation containing the
binary relation on `f`'s image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the
elements of `f⁻¹(y)` by an additive congruence relation `c`.'"]
def map_gen (f : M → N) : con N :=
con_gen $ λ x y, ∃ a b, f a = x ∧ f b = y ∧ c a b

/-- Given a surjective multiplicative-preserving function `f` whose kernel is contained in a
    congruence relation `c`, the congruence relation on `f`'s codomain defined by '`x ≈ y` iff the
    elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)` by `c`.' -/
@[to_additive "Given a surjective addition-preserving function `f` whose kernel is contained in
an additive congruence relation `c`, the additive congruence relation on `f`'s codomain defined
by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)` by `c`.'"]
def map_of_surjective (f : M → N) (H : ∀ x y, f (x * y) = f x * f y) (h : mul_ker f H ≤ c)
  (hf : surjective f) : con N :=
{ mul' := λ w x y z ⟨a, b, hw, hx, h1⟩ ⟨p, q, hy, hz, h2⟩,
    ⟨a * p, b * q, by rw [H, hw, hy], by rw [H, hx, hz], c.mul h1 h2⟩,
  ..c.to_setoid.map_of_surjective f h hf }

/-- A specialization of 'the smallest congruence relation containing a congruence relation `c`
    equals `c`'. -/
@[to_additive "A specialization of 'the smallest additive congruence relation containing
an additive congruence relation `c` equals `c`'."]
lemma map_of_surjective_eq_map_gen {c : con M} {f : M → N} (H : ∀ x y, f (x * y) = f x * f y)
  (h : mul_ker f H ≤ c) (hf : surjective f) :
  c.map_gen f = c.map_of_surjective f H h hf :=
by rw ←con_gen_of_con (c.map_of_surjective f H h hf); refl

/-- Given types with multiplications `M, N` and a congruence relation `c` on `N`, a
    multiplication-preserving map `f : M → N` induces a congruence relation on `f`'s domain
    defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `c`.' -/
@[to_additive "Given types with additions `M, N` and an additive congruence relation `c` on `N`,
an addition-preserving map `f : M → N` induces an additive congruence relation on `f`'s domain
defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `c`.' "]
def comap (f : M → N) (H : ∀ x y, f (x * y) = f x * f y) (c : con N) : con M :=
{ mul' := λ w x y z h1 h2, show c (f (w * y)) (f (x * z)), by rw [H, H]; exact c.mul h1 h2,
  ..c.to_setoid.comap f }

@[simp, to_additive] lemma comap_rel {f : M → N} (H : ∀ x y, f (x * y) = f x * f y)
  {c : con N} {x y : M} :
  comap f H c x y ↔ c (f x) (f y) :=
iff.rfl

section
open _root_.quotient

/-- Given a congruence relation `c` on a type `M` with a multiplication, the order-preserving
    bijection between the set of congruence relations containing `c` and the congruence relations
    on the quotient of `M` by `c`. -/
@[to_additive "Given an additive congruence relation `c` on a type `M` with an addition,
the order-preserving bijection between the set of additive congruence relations containing `c` and
the additive congruence relations on the quotient of `M` by `c`."]
def correspondence : {d // c ≤ d} ≃o (con c.quotient) :=
{ to_fun := λ d, d.1.map_of_surjective coe _
    (by rw mul_ker_mk_eq; exact d.2) $ @exists_rep _ c.to_setoid,
  inv_fun := λ d, ⟨comap (coe : M → c.quotient) (λ x y, rfl) d, λ _ _ h,
    show d _ _, by rw c.eq.2 h; exact d.refl _ ⟩,
  left_inv := λ d, subtype.ext_iff_val.2 $ ext $ λ _ _,
    ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in
      d.1.trans (d.1.symm $ d.2 $ c.eq.1 hx) $ d.1.trans H $ d.2 $ c.eq.1 hy,
     λ h, ⟨_, _, rfl, rfl, h⟩⟩,
  right_inv := λ d, let Hm : mul_ker (coe : M → c.quotient) (λ x y, rfl) ≤
        comap (coe : M → c.quotient) (λ x y, rfl) d :=
      λ x y h, show d _ _, by rw mul_ker_mk_eq at h; exact c.eq.2 h ▸ d.refl _ in
    ext $ λ x y, ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in hx ▸ hy ▸ H,
      con.induction_on₂ x y $ λ w z h, ⟨w, z, rfl, rfl, h⟩⟩,
  map_rel_iff' := λ s t, ⟨λ h _ _ hs, let ⟨a, b, hx, hy, ht⟩ := h ⟨_, _, rfl, rfl, hs⟩ in
      t.1.trans (t.1.symm $ t.2 $ eq_rel.1 hx) $ t.1.trans ht $ t.2 $ eq_rel.1 hy,
      λ h _ _ hs, let ⟨a, b, hx, hy, Hs⟩ := hs in ⟨a, b, hx, hy, h Hs⟩⟩ }

end

end

section mul_one_class

variables {M} [mul_one_class M] [mul_one_class N] [mul_one_class P] (c : con M)

/-- The quotient of a monoid by a congruence relation is a monoid. -/
@[to_additive "The quotient of an `add_monoid` by an additive congruence relation is
an `add_monoid`."]
instance mul_one_class : mul_one_class c.quotient :=
{ one := ((1 : M) : c.quotient),
  mul := (*),
  mul_one := λ x, quotient.induction_on' x $ λ _, congr_arg coe $ mul_one _,
  one_mul := λ x, quotient.induction_on' x $ λ _, congr_arg coe $ one_mul _ }

variables {c}

/-- The 1 of the quotient of a monoid by a congruence relation is the equivalence class of the
    monoid's 1. -/
@[simp, to_additive "The 0 of the quotient of an `add_monoid` by an additive congruence relation
is the equivalence class of the `add_monoid`'s 0."]
lemma coe_one : ((1 : M) : c.quotient) = 1 := rfl

variables (M c)

/-- The submonoid of `M × M` defined by a congruence relation on a monoid `M`. -/
@[to_additive "The `add_submonoid` of `M × M` defined by an additive congruence
relation on an `add_monoid` `M`."]
protected def submonoid : submonoid (M × M) :=
{ carrier := { x | c x.1 x.2 },
  one_mem' := c.iseqv.1 1,
  mul_mem' := λ _ _, c.mul }

variables {M c}

/-- The congruence relation on a monoid `M` from a submonoid of `M × M` for which membership
    is an equivalence relation. -/
@[to_additive "The additive congruence relation on an `add_monoid` `M` from
an `add_submonoid` of `M × M` for which membership is an equivalence relation."]
def of_submonoid (N : submonoid (M × M)) (H : equivalence (λ x y, (x, y) ∈ N)) : con M :=
{ r := λ x y, (x, y) ∈ N,
  iseqv := H,
  mul' := λ _ _ _ _, N.mul_mem }

/-- Coercion from a congruence relation `c` on a monoid `M` to the submonoid of `M × M` whose
    elements are `(x, y)` such that `x` is related to `y` by `c`. -/
@[to_additive "Coercion from a congruence relation `c` on an `add_monoid` `M`
to the `add_submonoid` of `M × M` whose elements are `(x, y)` such that `x`
is related to `y` by `c`."]
instance to_submonoid : has_coe (con M) (submonoid (M × M)) := ⟨λ c, c.submonoid M⟩

@[to_additive] lemma mem_coe {c : con M} {x y} :
  (x, y) ∈ (↑c : submonoid (M × M)) ↔ (x, y) ∈ c := iff.rfl

@[to_additive]
theorem to_submonoid_inj (c d : con M) (H : (c : submonoid (M × M)) = d) : c = d :=
ext $ λ x y, show (x, y) ∈ (c : submonoid (M × M)) ↔ (x, y) ∈ ↑d, by rw H

@[to_additive]
lemma le_iff {c d : con M} : c ≤ d ↔ (c : submonoid (M × M)) ≤ d :=
⟨λ h x H, h H, λ h x y hc, h $ show (x, y) ∈ c, from hc⟩

/-- The kernel of a monoid homomorphism as a congruence relation. -/
@[to_additive "The kernel of an `add_monoid` homomorphism as an additive congruence relation."]
def ker (f : M →* P) : con M := mul_ker f f.3

/-- The definition of the congruence relation defined by a monoid homomorphism's kernel. -/
@[simp, to_additive "The definition of the additive congruence relation defined by an `add_monoid`
homomorphism's kernel."]
lemma ker_rel (f : M →* P) {x y} : ker f x y ↔ f x = f y := iff.rfl

/-- There exists an element of the quotient of a monoid by a congruence relation (namely 1). -/
@[to_additive "There exists an element of the quotient of an `add_monoid` by a congruence relation
(namely 0)."]
instance quotient.inhabited : inhabited c.quotient := ⟨((1 : M) : c.quotient)⟩

variables (c)

/-- The natural homomorphism from a monoid to its quotient by a congruence relation. -/
@[to_additive "The natural homomorphism from an `add_monoid` to its quotient by an additive
congruence relation."]
def mk' : M →* c.quotient := ⟨coe, rfl, λ _ _, rfl⟩

variables (x y : M)

/-- The kernel of the natural homomorphism from a monoid to its quotient by a congruence
    relation `c` equals `c`. -/
@[simp, to_additive "The kernel of the natural homomorphism from an `add_monoid` to its quotient by
an additive congruence relation `c` equals `c`."]
lemma mk'_ker : ker c.mk' = c := ext $ λ _ _, c.eq

variables {c}

/-- The natural homomorphism from a monoid to its quotient by a congruence relation is
    surjective. -/
@[to_additive "The natural homomorphism from an `add_monoid` to its quotient by a congruence
relation is surjective."]
lemma mk'_surjective : surjective c.mk' :=
quotient.surjective_quotient_mk'

@[simp, to_additive] lemma coe_mk' : (c.mk' : M → c.quotient) = coe := rfl

/-- The elements related to `x ∈ M`, `M` a monoid, by the kernel of a monoid homomorphism are
    those in the preimage of `f(x)` under `f`. -/
@[to_additive "The elements related to `x ∈ M`, `M` an `add_monoid`, by the kernel of
an `add_monoid` homomorphism are those in the preimage of `f(x)` under `f`. "]
lemma ker_apply_eq_preimage {f : M →* P} (x) : (ker f) x = f ⁻¹' {f x} :=
set.ext $ λ x,
  ⟨λ h, set.mem_preimage.2 $ set.mem_singleton_iff.2 h.symm,
   λ h, (set.mem_singleton_iff.1 $ set.mem_preimage.1 h).symm⟩

/-- Given a monoid homomorphism `f : N → M` and a congruence relation `c` on `M`, the congruence
    relation induced on `N` by `f` equals the kernel of `c`'s quotient homomorphism composed with
    `f`. -/
@[to_additive "Given an `add_monoid` homomorphism `f : N → M` and an additive congruence relation
`c` on `M`, the additive congruence relation induced on `N` by `f` equals the kernel of `c`'s
quotient homomorphism composed with `f`."]
lemma comap_eq {f : N →* M} : comap f f.map_mul c = ker (c.mk'.comp f) :=
ext $ λ x y, show c _ _ ↔ c.mk' _ = c.mk' _, by rw ←c.eq; refl

variables (c) (f : M →* P)

/-- The homomorphism on the quotient of a monoid by a congruence relation `c` induced by a
    homomorphism constant on `c`'s equivalence classes. -/
@[to_additive "The homomorphism on the quotient of an `add_monoid` by an additive congruence
relation `c` induced by a homomorphism constant on `c`'s equivalence classes."]
def lift (H : c ≤ ker f) : c.quotient →* P :=
{ to_fun := λ x, con.lift_on x f $ λ _ _ h, H h,
  map_one' := by rw ←f.map_one; refl,
  map_mul' := λ x y, con.induction_on₂ x y $ λ m n, f.map_mul m n ▸ rfl }

variables {c f}

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
lemma lift_mk' (H : c ≤ ker f) (x) :
  c.lift f H (c.mk' x) = f x := rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp, to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
lemma lift_coe (H : c ≤ ker f) (x : M) :
  c.lift f H x = f x := rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp, to_additive "The diagram describing the universal property for quotients of `add_monoid`s
commutes."]
theorem lift_comp_mk' (H : c ≤ ker f) :
  (c.lift f H).comp c.mk' = f := by ext; refl

/-- Given a homomorphism `f` from the quotient of a monoid by a congruence relation, `f` equals the
    homomorphism on the quotient induced by `f` composed with the natural map from the monoid to
    the quotient. -/
@[simp, to_additive "Given a homomorphism `f` from the quotient of an `add_monoid` by an additive
congruence relation, `f` equals the homomorphism on the quotient induced by `f` composed with the
natural map from the `add_monoid` to the quotient."]
lemma lift_apply_mk' (f : c.quotient →* P) :
  c.lift (f.comp c.mk') (λ x y h, show f ↑x = f ↑y, by rw c.eq.2 h) = f :=
by ext; rcases x; refl

/-- Homomorphisms on the quotient of a monoid by a congruence relation are equal if they
    are equal on elements that are coercions from the monoid. -/
@[to_additive "Homomorphisms on the quotient of an `add_monoid` by an additive congruence relation
are equal if they are equal on elements that are coercions from the `add_monoid`."]
lemma lift_funext (f g : c.quotient →* P) (h : ∀ a : M, f a = g a) : f = g :=
begin
  rw [←lift_apply_mk' f, ←lift_apply_mk' g],
  congr' 1,
  exact monoid_hom.ext_iff.2 h,
end

/-- The uniqueness part of the universal property for quotients of monoids. -/
@[to_additive "The uniqueness part of the universal property for quotients of `add_monoid`s."]
theorem lift_unique (H : c ≤ ker f) (g : c.quotient →* P)
  (Hg : g.comp c.mk' = f) : g = c.lift f H :=
lift_funext g (c.lift f H) $ λ x, by { subst f, refl }

/-- Given a congruence relation `c` on a monoid and a homomorphism `f` constant on `c`'s
    equivalence classes, `f` has the same image as the homomorphism that `f` induces on the
    quotient. -/
@[to_additive "Given an additive congruence relation `c` on an `add_monoid` and a homomorphism `f`
constant on `c`'s equivalence classes, `f` has the same image as the homomorphism that `f` induces
on the quotient."]
theorem lift_range (H : c ≤ ker f) : (c.lift f H).mrange = f.mrange :=
submonoid.ext $ λ x, ⟨by rintros ⟨⟨y⟩, hy⟩; exact ⟨y, hy⟩, λ ⟨y, hy⟩, ⟨↑y, hy⟩⟩

/-- Surjective monoid homomorphisms constant on a congruence relation `c`'s equivalence classes
    induce a surjective homomorphism on `c`'s quotient. -/
@[to_additive "Surjective `add_monoid` homomorphisms constant on an additive congruence
relation `c`'s equivalence classes induce a surjective homomorphism on `c`'s quotient."]
lemma lift_surjective_of_surjective (h : c ≤ ker f) (hf : surjective f) :
  surjective (c.lift f h) :=
λ y, exists.elim (hf y) $ λ w hw, ⟨w, (lift_mk' h w).symm ▸ hw⟩

variables (c f)

/-- Given a monoid homomorphism `f` from `M` to `P`, the kernel of `f` is the unique congruence
    relation on `M` whose induced map from the quotient of `M` to `P` is injective. -/
@[to_additive "Given an `add_monoid` homomorphism `f` from `M` to `P`, the kernel of `f`
is the unique additive congruence relation on `M` whose induced map from the quotient of `M`
to `P` is injective."]
lemma ker_eq_lift_of_injective (H : c ≤ ker f) (h : injective (c.lift f H)) :
  ker f = c :=
to_setoid_inj $ ker_eq_lift_of_injective f H h

variables {c}

/-- The homomorphism induced on the quotient of a monoid by the kernel of a monoid homomorphism. -/
@[to_additive "The homomorphism induced on the quotient of an `add_monoid` by the kernel
of an `add_monoid` homomorphism."]
def ker_lift : (ker f).quotient →* P :=
(ker f).lift f $ λ _ _, id

variables {f}

/-- The diagram described by the universal property for quotients of monoids, when the congruence
    relation is the kernel of the homomorphism, commutes. -/
@[simp, to_additive "The diagram described by the universal property for quotients
of `add_monoid`s, when the additive congruence relation is the kernel of the homomorphism,
commutes."]
lemma ker_lift_mk (x : M) :  ker_lift f x = f x := rfl

/-- Given a monoid homomorphism `f`, the induced homomorphism on the quotient by `f`'s kernel has
    the same image as `f`. -/
@[simp, to_additive "Given an `add_monoid` homomorphism `f`, the induced homomorphism
on the quotient by `f`'s kernel has the same image as `f`."]
lemma ker_lift_range_eq : (ker_lift f).mrange = f.mrange :=
lift_range $ λ _ _, id

/-- A monoid homomorphism `f` induces an injective homomorphism on the quotient by `f`'s kernel. -/
@[to_additive "An `add_monoid` homomorphism `f` induces an injective homomorphism on the quotient
by `f`'s kernel."]
lemma ker_lift_injective (f : M →* P) : injective (ker_lift f) :=
λ x y, quotient.induction_on₂' x y $ λ _ _, (ker f).eq.2

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, `d`'s quotient
    map induces a homomorphism from the quotient by `c` to the quotient by `d`. -/
@[to_additive "Given additive congruence relations `c, d` on an `add_monoid` such that `d`
contains `c`, `d`'s quotient map induces a homomorphism from the quotient by `c` to the quotient
by `d`."]
def map (c d : con M) (h : c ≤ d) : c.quotient →* d.quotient :=
c.lift d.mk' $ λ x y hc, show (ker d.mk') x y, from
  (mk'_ker d).symm ▸ h hc

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, the definition of
    the homomorphism from the quotient by `c` to the quotient by `d` induced by `d`'s quotient
    map. -/
@[to_additive "Given additive congruence relations `c, d` on an `add_monoid` such that `d`
contains `c`, the definition of the homomorphism from the quotient by `c` to the quotient by `d`
induced by `d`'s quotient map."]
lemma map_apply {c d : con M} (h : c ≤ d) (x) :
  c.map d h x = c.lift d.mk' (λ x y hc, d.eq.2 $ h hc) x := rfl

variables (c)

/-- The first isomorphism theorem for monoids. -/
@[to_additive "The first isomorphism theorem for `add_monoid`s."]
noncomputable def quotient_ker_equiv_range (f : M →* P) : (ker f).quotient ≃* f.mrange :=
{ map_mul' := monoid_hom.map_mul _,
  ..equiv.of_bijective
      ((@mul_equiv.to_monoid_hom (ker_lift f).mrange _ _ _
        $ mul_equiv.submonoid_congr ker_lift_range_eq).comp (ker_lift f).mrange_restrict) $
      (equiv.bijective _).comp
        ⟨λ x y h, ker_lift_injective f $ by rcases x; rcases y; injections,
         λ ⟨w, z, hz⟩, ⟨z, by rcases hz; rcases _x; refl⟩⟩ }

/-- The first isomorphism theorem for monoids in the case of a homomorphism with right inverse. -/
@[to_additive "The first isomorphism theorem for `add_monoid`s in the case of a homomorphism
with right inverse.", simps]
def quotient_ker_equiv_of_right_inverse (f : M →* P) (g : P → M)
  (hf : function.right_inverse g f) :
  (ker f).quotient ≃* P :=
{ to_fun := ker_lift f,
  inv_fun := coe ∘ g,
  left_inv := λ x, ker_lift_injective _ (by rw [function.comp_app, ker_lift_mk, hf]),
  right_inv := hf,
  .. ker_lift f }

/-- The first isomorphism theorem for monoids in the case of a surjective homomorphism.

For a `computable` version, see `con.quotient_ker_equiv_of_right_inverse`.
-/
@[to_additive "The first isomorphism theorem for `add_monoid`s in the case of a surjective
homomorphism.

For a `computable` version, see `add_con.quotient_ker_equiv_of_right_inverse`.
"]
noncomputable def quotient_ker_equiv_of_surjective (f : M →* P) (hf : surjective f) :
  (ker f).quotient ≃* P :=
quotient_ker_equiv_of_right_inverse _ _ hf.has_right_inverse.some_spec

/-- The second isomorphism theorem for monoids. -/
@[to_additive "The second isomorphism theorem for `add_monoid`s."]
noncomputable def comap_quotient_equiv (f : N →* M) :
  (comap f f.map_mul c).quotient ≃* (c.mk'.comp f).mrange :=
(con.congr comap_eq).trans $ quotient_ker_equiv_range $ c.mk'.comp f

/-- The third isomorphism theorem for monoids. -/
@[to_additive "The third isomorphism theorem for `add_monoid`s."]
def quotient_quotient_equiv_quotient (c d : con M) (h : c ≤ d) :
  (ker (c.map d h)).quotient ≃* d.quotient :=
{ map_mul' := λ x y, con.induction_on₂ x y $ λ w z, con.induction_on₂ w z $ λ a b,
    show _ = d.mk' a * d.mk' b, by rw ←d.mk'.map_mul; refl,
  ..quotient_quotient_equiv_quotient c.to_setoid d.to_setoid h }

end mul_one_class

section monoids

/-- The quotient of a monoid by a congruence relation is a monoid. -/
@[to_additive "The quotient of an `add_monoid` by an additive congruence relation is
an `add_monoid`."]
instance monoid {M : Type*} [monoid M] (c : con M): monoid c.quotient :=
{ one := ((1 : M) : c.quotient),
  mul := (*),
  mul_assoc := λ x y z, quotient.induction_on₃' x y z
               $ λ _ _ _, congr_arg coe $ mul_assoc _ _ _,
  .. c.mul_one_class }

/-- The quotient of a `comm_monoid` by a congruence relation is a `comm_monoid`. -/
@[to_additive "The quotient of an `add_comm_monoid` by an additive congruence
relation is an `add_comm_monoid`."]
instance comm_monoid {M : Type*} [comm_monoid M] (c : con M) :
  comm_monoid c.quotient :=
{ mul_comm := λ x y, con.induction_on₂ x y $ λ w z, by rw [←coe_mul, ←coe_mul, mul_comm],
  ..c.monoid}

end monoids

section groups

variables {M} [group M] [group N] [group P] (c : con M)

/-- Multiplicative congruence relations preserve inversion. -/
@[to_additive "Additive congruence relations preserve negation."]
protected lemma inv : ∀ {w x}, c w x → c w⁻¹ x⁻¹ :=
λ x y h, by simpa using c.symm (c.mul (c.mul (c.refl x⁻¹) h) (c.refl y⁻¹))

/-- The inversion induced on the quotient by a congruence relation on a type with a
    inversion. -/
@[to_additive "The negation induced on the quotient by an additive congruence relation on a type
with an negation."]
instance has_inv : has_inv c.quotient :=
⟨λ x, quotient.lift_on' x (λ w, ((w⁻¹ : M) : c.quotient))
     $ λ x y h, c.eq.2 $ c.inv h⟩

/-- The quotient of a group by a congruence relation is a group. -/
@[to_additive "The quotient of an `add_group` by an additive congruence relation is
an `add_group`."]
instance group : group c.quotient :=
{ inv := λ x, x⁻¹,
  mul_left_inv := λ x, show x⁻¹ * x = 1,
    from quotient.induction_on' x $ λ _, congr_arg coe $ mul_left_inv _,
  .. con.monoid c}

end groups

section units

variables {α : Type*} [monoid M] {c : con M}

/-- In order to define a function `units (con.quotient c) → α` on the units of `con.quotient c`,
where `c : con M` is a multiplicative congruence on a monoid, it suffices to define a function `f`
that takes elements `x y : M` with proofs of `c (x * y) 1` and `c (y * x) 1`, and returns an element
of `α` provided that `f x y _ _ = f x' y' _ _` whenever `c x x'` and `c y y'`. -/
@[to_additive lift_on_add_units] def lift_on_units (u : units c.quotient)
  (f : Π (x y : M), c (x * y) 1 → c (y * x) 1 → α)
  (Hf : ∀ x y hxy hyx x' y' hxy' hyx', c x x' → c y y' → f x y hxy hyx = f x' y' hxy' hyx') :
  α :=
begin
  refine @con.hrec_on₂ M M _ _ c c (λ x y, x * y = 1 → y * x = 1 → α)
    (u : c.quotient) (↑u⁻¹ : c.quotient)
    (λ (x y : M) (hxy : (x * y : c.quotient) = 1) (hyx : (y * x : c.quotient) = 1),
    f x y (c.eq.1 hxy) (c.eq.1 hyx)) (λ x y x' y' hx hy, _) u.3 u.4,
  ext1, { rw [c.eq.2 hx, c.eq.2 hy] },
  rintro Hxy Hxy' -,
  ext1, { rw [c.eq.2 hx, c.eq.2 hy] },
  rintro Hyx Hyx' -,
  exact heq_of_eq (Hf _ _ _ _ _ _ _ _ hx hy)
end

/-- In order to define a function `units (con.quotient c) → α` on the units of `con.quotient c`,
where `c : con M` is a multiplicative congruence on a monoid, it suffices to define a function `f`
that takes elements `x y : M` with proofs of `c (x * y) 1` and `c (y * x) 1`, and returns an element
of `α` provided that `f x y _ _ = f x' y' _ _` whenever `c x x'` and `c y y'`. -/
add_decl_doc add_con.lift_on_add_units

@[simp, to_additive]
lemma lift_on_units_mk (f : Π (x y : M), c (x * y) 1 → c (y * x) 1 → α)
  (Hf : ∀ x y hxy hyx x' y' hxy' hyx', c x x' → c y y' → f x y hxy hyx = f x' y' hxy' hyx')
  (x y : M) (hxy hyx) :
  lift_on_units ⟨(x : c.quotient), y, hxy, hyx⟩ f Hf = f x y (c.eq.1 hxy) (c.eq.1 hyx) :=
rfl

@[elab_as_eliminator, to_additive induction_on_add_units]
lemma induction_on_units {p : units c.quotient → Prop} (u : units c.quotient)
  (H : ∀ (x y : M) (hxy : c (x * y) 1) (hyx : c (y * x) 1), p ⟨x, y, c.eq.2 hxy, c.eq.2 hyx⟩) :
  p u :=
begin
  rcases u with ⟨⟨x⟩, ⟨y⟩, h₁, h₂⟩,
  exact H x y (c.eq.1 h₁) (c.eq.1 h₂)
end

end units

end con


import breen_deligne.eg
import thm95.constants
import polyhedral_lattice.int
import system_of_complexes.shift_sub_id

open breen_deligne thm95.universal_constants
open_locale nnreal

namespace Lbar

variables (r r' : ℝ≥0)
variables [fact (0 < r')] [fact (r < 1)]
variables (i : ℕ)

-- move me
lemma κ_pos : ∀ m, 0 < eg.κ r r' m
| 0 := zero_lt_one
| (m+1) := begin
  dsimp only [eg.κ, data.κ],
  refine mul_pos _ _,
  { refine nnreal.inv_pos.mpr (lt_max_of_lt_left zero_lt_one), },
  { refine mul_pos (pow_pos (fact.out _) _) (κ_pos _), }
end

variables [fact (0 < r)] [fact (r < r')] [fact (r' < 1)]

noncomputable!
def ι' : ℕ → ℝ≥0
| 0 := max
        (c₀ r r' eg (λ (n : ℕ), eg.κ r r' n) (eg.κ' r r') (i + 1) ⟨ℤ⟩)
        (c₀ r r' eg (λ (n : ℕ), eg.κ r r' n) (eg.κ' r r') (i + 1 + 1) ⟨ℤ⟩)
| (j+1) := max
        (max (j+1) (ι' j))
        (max
          (max
            (k (eg.κ' r r') i ^ 2 * ι' j)
            (k (eg.κ' r r') (i+1) ^ 2 * ι' j))
            ((k (eg.κ' r r') (i+1+1) ^ 2 * ι' j)))

lemma hι' : monotone (ι' r r' i) :=
begin
  apply monotone_nat_of_le_succ,
  rintro (_|j); refine le_trans (le_max_right _ _) (le_max_left _ _),
end

lemma Hι1 : ∀ j,
  c₀ r r' eg (λ (n : ℕ), eg.κ r r' n) (eg.κ' r r') (i + 1) ⟨ℤ⟩ ≤ ι' r r' i j
| 0 := le_max_left _ _
| (j+1) := (Hι1 j).trans $ by { apply hι', apply nat.le_succ }

lemma Hι1' : ∀ j,
  c₀ r r' eg (λ (n : ℕ), eg.κ r r' n) (eg.κ' r r') (i + 1 + 1) ⟨ℤ⟩ ≤ ι' r r' i j
| 0 := le_max_right _ _
| (j+1) := (Hι1' j).trans $ by { apply hι', apply nat.le_succ }

lemma Hι2a : ∀ j,
  k (eg.κ' r r') i ^ 2 * ι' r r' i j ≤ ι' r r' i (j + 1) :=
by rintro (_|j); simp only [ι', le_max_iff, le_rfl, true_or, or_true]

lemma Hι2b : ∀ j,
  k (eg.κ' r r') (i + 1) ^ 2 * ι' r r' i j ≤ ι' r r' i (j + 1) :=
by rintro (_|j); simp only [ι', le_max_iff, le_rfl, true_or, or_true]

lemma Hι2c : ∀ j,
  k (eg.κ' r r') (i + 1 + 1) ^ 2 * ι' r r' i j ≤ ι' r r' i (j + 1) :=
by rintro (_|j); simp only [ι', le_max_iff, le_rfl, true_or, or_true]

noncomputable
def ι : ulift.{1} ℕ → ℝ≥0 := ι' r r' i ∘ ulift.down

lemma hι : monotone (ι r r' i) :=
λ j₁ j₂ h, by { delta ι, apply hι', exact h }

lemma hι'_self_le : ∀ j:ℕ, (j:ℝ≥0) ≤ ι' r r' i j
| 0 := by { norm_cast, exact zero_le' }
| (j+1) := by simp only [ι', le_max_iff, nat.cast_add, nat.cast_one, le_refl, true_or]

lemma sufficiently_increasing_eg (s : ℝ≥0) (m : ℕ) :
  ∃ n : ℕ, s ≤ ι' r r' i n * eg.κ r r' m :=
begin
  let κ := eg.κ r r' m,
  let n := ⌈s * κ⁻¹⌉₊,
  let ι := ι' r r' i n,
  refine ⟨n, _⟩,
  calc s = s * κ⁻¹ * κ : _
     ... ≤ ι * κ : mul_le_mul' _ le_rfl,
  { rw inv_mul_cancel_right₀, apply ne_of_gt, apply κ_pos, },
  { refine (nat.le_ceil _).trans (hι'_self_le _ _ _ _) }
end

lemma sufficiently_increasing_eg' (s : ℝ≥0) (m : ℕ) :
  ∃ n : ℕ, s ≤ r' * (ι' r r' i n * eg.κ r r' m) :=
begin
  obtain ⟨n,hn⟩ := sufficiently_increasing_eg r r' i (s / r') m,
  use n,
  replace hn := mul_le_mul (le_refl r') hn (zero_le (s / r')) (zero_le _),
  refine le_trans (le_of_eq _) hn,
  have : r' ≠ 0, { symmetry, exact ne_of_lt (fact.out (0 < r')) },
  rw mul_comm,
  exact (div_eq_iff this).mp rfl
end

def sufficiently_increasing
  (κ : ℝ≥0 → ℕ → ℝ≥0) (ι : ulift ℕ → ℝ≥0) : Prop :=
∀ (r : ℝ≥0) (m : ℕ), ∃ n : ℕ, r ≤ κ (ι ⟨n⟩) m

end Lbar


import data.sum
import data.set

open sum

lemma preimage_inl_image_inl {α β : Type*} (u : set α) :
  @inl α β ⁻¹' (@inl α β '' u) = u :=
set.preimage_image_eq u (λ _ _, inl.inj_iff.mp)

lemma preimage_inl_image_inr {α β : Type*} (u : set β) :
  @inl α β ⁻¹' (@inr α β '' u) = ∅ :=
set.eq_empty_iff_forall_not_mem.mpr (assume b ⟨a, _, h⟩, inr_ne_inl h)

lemma preimage_inr_image_inl {α β : Type*} (u : set α) :
  @inr α β ⁻¹' (@inl α β '' u) = ∅ :=
set.eq_empty_iff_forall_not_mem.mpr (assume a ⟨b, _, h⟩, inl_ne_inr h)

lemma preimage_inr_image_inr {α β : Type*} (u : set β) :
  @inr α β ⁻¹' (@inr α β '' u) = u :=
set.preimage_image_eq u (λ _ _, inr.inj_iff.mp)


import .basic

namespace premodel

-- `optree` defines an (initial) premodel
instance tree_premodel (th : theory) (α : Type*) : premodel th (optree th.op α) :=
  {
    act := @optree.opnode th.op α
  }

end premodel

namespace morphism

-- maps into premodels give rise to morphisms out of trees
definition treelift (th : theory) {α β: Type*} [premodel th β] (f : α → β) : morphism th (optree th.op α) β :=
  subtype.mk (optree.elim (@premodel.act th β _) f) $
    by intros n μ ts; unfold premodel.act; rw [optree.elim_opnode]

-- Computation rule for treelift; treelift preserves the original map
theorem treelift_comp {th : theory} {α β: Type*} [premodel th β] (f : α → β) : ∀ {a : α}, (treelift th f).val (optree.varleaf a) = f a :=
  begin
    intros,
    dsimp [treelift],
    exact optree.elim_varleaf
  end

-- The embedding into a treemodel is "epimorphic"
mutual theorem tree_unique, tree_unique_aux {th : theory} {α β : Type*} [premodel th β] {f g : morphism th (optree th.op α) β} (h : ∀ a, f.val (optree.varleaf a) = g.val (optree.varleaf a))
with tree_unique : ∀ {t : optree th.op α}, f.val t = g.val t
| (optree.varleaf a) := h a
| (optree.opnode k vect.nil) :=
  begin
    have : (optree.opnode k vect.nil) = (@premodel.act th (optree th.op α) _ 0 k) vect.nil,
      by unfold premodel.act; refl,
    rw [this],
    rw [f.property,g.property],
    unfold vect.map
  end
| (optree.opnode k (vect.cons t ts)) :=
  begin
    have : ∀ t, (optree.opnode k t) = (@premodel.act th (optree th.op α) _ _ k) t,
      from λ_, rfl,
    rw [this],
    rw [f.property,g.property],
    unfold vect.map,
    rw [tree_unique, tree_unique_aux]
  end
with tree_unique_aux : ∀ {n : ℕ} {ts : vect (optree th.op α) n}, vect.map f.val ts = vect.map g.val ts
| _ vect.nil := by unfold vect.map; refl
| _ (vect.cons t ts) :=
  begin
    unfold vect.map,
    rw [tree_unique, tree_unique_aux],
    try {split; refl}
  end

end morphism


import classes.context_free.basics.lifting

variables {T : Type}

private def union_grammar (g₁ g₂ : CF_grammar T) : CF_grammar T :=
CF_grammar.mk (option (g₁.nt ⊕ g₂.nt)) none (
  (none, [symbol.nonterminal (some (sum.inl (g₁.initial)))]) ::
  (none, [symbol.nonterminal (some (sum.inr (g₂.initial)))]) ::
  ((list.map rule_of_rule₁ g₁.rules) ++ (list.map rule_of_rule₂ g₂.rules))
)

variables {g₁ g₂ : CF_grammar T}

section lifted_grammars

private def oN₁_of_N : (union_grammar g₁ g₂).nt → (option g₁.nt)
| none := none
| (some (sum.inl nonte)) := some nonte
| (some (sum.inr _)) := none

private def oN₂_of_N : (union_grammar g₁ g₂).nt → (option g₂.nt)
| none := none
| (some (sum.inl _)) := none
| (some (sum.inr nonte)) := some nonte

private def g₁g : @lifted_grammar T :=
lifted_grammar.mk g₁ (union_grammar g₁ g₂) (some ∘ sum.inl) (by {
  intros x y h,
  apply sum.inl_injective,
  apply option.some_injective,
  exact h,
}) (by {
  intros r h,
  apply list.mem_cons_of_mem,
  apply list.mem_cons_of_mem,
  apply list.mem_append_left,
  rw list.mem_map,
  use r,
  split,
  {
    exact h,
  },
  unfold rule_of_rule₁,
  unfold lift_rule,
  norm_num,
  unfold lift_string,
  unfold lsTN_of_lsTN₁,
  five_steps,
}) oN₁_of_N (by {
  intros x y ass,
  cases x,
  {
    right,
    refl,
  },
  cases x, swap,
  {
    right,
    refl,
  },
  cases y,
  {
    rw ass,
    right,
    refl,
  },
  cases y, swap,
  {
    tauto,
  },
  left,
  simp only [oN₁_of_N] at ass,
  apply congr_arg,
  apply congr_arg,
  exact ass,
}) (by {
  intro r,
  rintro ⟨r_in, r_ntype⟩,
  cases r_in,
  {
    exfalso,
    rw r_in at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₀ imposs,
    exact option.no_confusion imposs,
  },
  cases r_in,
  {
    exfalso,
    rw r_in at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₀ imposs,
    exact option.no_confusion imposs,
  },
  change r ∈ (list.map rule_of_rule₁ g₁.rules ++ list.map rule_of_rule₂ g₂.rules) at r_in,
  rw list.mem_append at r_in,
  cases r_in,
  {
    rw list.mem_map at r_in,
    rcases r_in with ⟨r₁, r₁_in, r₁_convert_r⟩,
    use r₁,
    split,
    {
      exact r₁_in,
    },
    rw ←r₁_convert_r,
    simp only [
      lift_rule, rule_of_rule₁, lift_string, lsTN_of_lsTN₁,
      prod.mk.inj_iff, eq_self_iff_true, true_and
    ],
    five_steps,
  },
  {
    exfalso,
    rw list.mem_map at r_in,
    rcases r_in with ⟨r₂, r₂_in, r₂_convert_r⟩,
    rw ←r₂_convert_r at r_ntype,
    unfold rule_of_rule₂ at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₁ contr,
    rw option.some_inj at contr,
    exact sum.no_confusion contr,
  },
}) (by { intro, refl })

private def g₂g : @lifted_grammar T :=
lifted_grammar.mk g₂ (union_grammar g₁ g₂) (some ∘ sum.inr) (by {
  intros x y h,
  apply sum.inr_injective,
  apply option.some_injective,
  exact h,
}) (by {
  intros r h,
  apply list.mem_cons_of_mem,
  apply list.mem_cons_of_mem,
  apply list.mem_append_right,
  rw list.mem_map,
  use r,
  split,
  {
    exact h,
  },
  unfold rule_of_rule₂,
  unfold lift_rule,
  norm_num,
  unfold lift_string,
  unfold lsTN_of_lsTN₂,
  five_steps,
}) oN₂_of_N (by {
  intros x y ass,
  cases x,
  {
    right,
    refl,
  },
  cases x,
  {
    right,
    refl,
  },
  cases y,
  {
    right,
    rw ass,
    refl,
  },
  cases y,
  {
    tauto,
  },
  left,
  simp only [oN₂_of_N] at ass,
  apply congr_arg,
  apply congr_arg,
  exact ass,
}) (by {
  intro r,
  rintro ⟨r_in, r_ntype⟩,
  cases list.eq_or_mem_of_mem_cons r_in with r_eq r_in_,
  {
    exfalso,
    rw r_eq at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₀ imposs,
    exact option.no_confusion imposs,
  },
  cases list.eq_or_mem_of_mem_cons r_in_ with r_eq_ r_in__,
  {
    exfalso,
    rw r_eq_ at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₀ imposs,
    exact option.no_confusion imposs,
  },
  clear r_in r_in_,
  rename r_in__ r_in,
  rw list.mem_append at r_in,
  cases r_in,
  {
    exfalso,
    rw list.mem_map at r_in,
    rcases r_in with ⟨r₁, r₁_in, r₁_convert_r⟩,
    rw ←r₁_convert_r at r_ntype,
    unfold rule_of_rule₁ at r_ntype,
    dsimp only at r_ntype,
    cases r_ntype with n₂ contr,
    rw option.some_inj at contr,
    exact sum.no_confusion contr,
  },
  {
    rw list.mem_map at r_in,
    rcases r_in with ⟨r₂, r₂_in, r₂_convert_r⟩,
    use r₂,
    split,
    {
      exact r₂_in,
    },
    rw ←r₂_convert_r,
    simp only [
      lift_rule, rule_of_rule₂, lift_string, lsTN_of_lsTN₂,
      prod.mk.inj_iff, eq_self_iff_true, true_and
    ],
    five_steps,
  },
}) (by { intro, refl })

end lifted_grammars

section lemmata_subset

private lemma deri₁_more (w : list (symbol T g₁.nt)) :
  CF_derives g₁ [symbol.nonterminal g₁.initial] w →
    CF_derives
      (union_grammar g₁ g₂)
      (lsTN_of_lsTN₁ [symbol.nonterminal g₁.initial])
      (lsTN_of_lsTN₁ w) :=
begin
  intro ass,
  let gg₁ := @g₁g T g₁ g₂,
  change CF_derives gg₁.g (lsTN_of_lsTN₁ [symbol.nonterminal g₁.initial]) (lsTN_of_lsTN₁ w),
  have techni : lsTN_of_lsTN₁ = lift_string gg₁.lift_nt,
  {
    unfold lsTN_of_lsTN₁,
    unfold lift_string,
    ext1 w,
    five_steps,
  },
  rw techni,
  exact lift_deri ass,
end

private lemma deri₂_more (w : list (symbol T g₂.nt)) :
  CF_derives g₂ [symbol.nonterminal g₂.initial] w →
    CF_derives
      (union_grammar g₁ g₂)
      (lsTN_of_lsTN₂ [symbol.nonterminal g₂.initial])
      (lsTN_of_lsTN₂ w) :=
begin
  intro ass,
  let gg₂ := @g₂g T g₁ g₂,
  change CF_derives gg₂.g (lsTN_of_lsTN₂ [symbol.nonterminal g₂.initial]) (lsTN_of_lsTN₂ w),
  have techni : lsTN_of_lsTN₂ = lift_string gg₂.lift_nt,
  {
    unfold lsTN_of_lsTN₂,
    unfold lift_string,
    ext1 w,
    five_steps,
  },
  rw techni,
  exact lift_deri ass,
end

private lemma in_union_of_in_first (w : list T) :
  w ∈ CF_language g₁  →  w ∈ CF_language (union_grammar g₁ g₂)  :=
begin
  intro assum,

  have deri_start :
    CF_derives
      (union_grammar g₁ g₂)
      [symbol.nonterminal none]
      [symbol.nonterminal (some (sum.inl g₁.initial))],
  {
    apply CF_deri_of_tran,
    use (none, [symbol.nonterminal (some (sum.inl (g₁.initial)))]),
    split,
    {
      change (none, [symbol.nonterminal (some (sum.inl g₁.initial))]) ∈ (
        (none, [symbol.nonterminal (some (sum.inl (g₁.initial)))]) ::
        (none, [symbol.nonterminal (some (sum.inr (g₂.initial)))]) ::
        ((list.map rule_of_rule₁ g₁.rules) ++ (list.map rule_of_rule₂ g₂.rules))
      ),
      apply list.mem_cons_self,
    },
    use [[], []],
    simp,
  },

  have deri_rest :
    CF_derives
      (union_grammar g₁ g₂)
      [symbol.nonterminal (some (sum.inl g₁.initial))]
      (list.map symbol.terminal w),
  {
    have beginning :
      [symbol.nonterminal (some (sum.inl g₁.initial))] =
      lsTN_of_lsTN₁ [symbol.nonterminal g₁.initial],
    {
      unfold lsTN_of_lsTN₁,
      change
        [symbol.nonterminal (some (sum.inl g₁.initial))] =
        [sTN_of_sTN₁ (symbol.nonterminal g₁.initial)],
      unfold sTN_of_sTN₁,
    },
    have ending :
      (list.map symbol.terminal w) =
      lsTN_of_lsTN₁ (list.map symbol.terminal w),
    {
      ext1,
      unfold lsTN_of_lsTN₁,
      rw [list.nth_map, list.map_map, list.nth_map],
      apply congr_arg,
      refl,
    },
    rw beginning,
    rw ending,
    exact deri₁_more (list.map symbol.terminal w) assum,
  },

  unfold CF_language,
  rw set.mem_set_of_eq,
  unfold CF_generates,
  unfold CF_generates_str,
  unfold CF_derives,
  apply CF_deri_of_deri_deri deri_start,
  exact deri_rest,
end

private lemma in_union_of_in_second (w : list T) :
  w ∈ CF_language g₂  →  w ∈ CF_language (union_grammar g₁ g₂)  :=
begin
  intro assum,

  have deri_start :
    CF_derives
      (union_grammar g₁ g₂)
      [symbol.nonterminal none]
      [symbol.nonterminal (some (sum.inr g₂.initial))],
  {
    apply CF_deri_of_tran,
    use (none, [symbol.nonterminal (some (sum.inr (g₂.initial)))]),
    split,
    {
      change (none, [symbol.nonterminal (some (sum.inr g₂.initial))]) ∈ (
        (none, [symbol.nonterminal (some (sum.inl (g₁.initial)))]) ::
        (none, [symbol.nonterminal (some (sum.inr (g₂.initial)))]) ::
        ((list.map rule_of_rule₁ g₁.rules) ++ (list.map rule_of_rule₂ g₂.rules))
      ),
      apply list.mem_cons_of_mem,
      apply list.mem_cons_self,
    },
    use [[], []],
    simp,
  },

  have deri_rest :
    CF_derives
      (union_grammar g₁ g₂)
      [symbol.nonterminal (some (sum.inr g₂.initial))]
      (list.map symbol.terminal w),
  {
    have beginning :
      [symbol.nonterminal (some (sum.inr g₂.initial))] =
      lsTN_of_lsTN₂ [symbol.nonterminal g₂.initial],
    {
      unfold lsTN_of_lsTN₂,
      change
        [symbol.nonterminal (some (sum.inr g₂.initial))] =
        [sTN_of_sTN₂ (symbol.nonterminal g₂.initial)],
      unfold sTN_of_sTN₂,
    },
    have ending :
      (list.map symbol.terminal w) =
      lsTN_of_lsTN₂ (list.map symbol.terminal w),
    {
      ext1,
      unfold lsTN_of_lsTN₂,
      rw [list.nth_map, list.map_map, list.nth_map],
      apply congr_arg,
      refl,
    },
    rw beginning,
    rw ending,
    exact deri₂_more (list.map symbol.terminal w) assum,
  },

  unfold CF_language,
  rw set.mem_set_of_eq,
  unfold CF_generates,
  unfold CF_generates_str,
  unfold CF_derives,
  apply CF_deri_of_deri_deri deri_start,
  exact deri_rest,
end

end lemmata_subset

section lemmata_supset

meta def good_singleton : tactic unit := `[
  unfold good_string,
  intros a in_singleton,
  rw list.mem_singleton at in_singleton,
  rw in_singleton,
  unfold good_letter
]

private lemma in_language_left_case_of_union {w : list T}
    (hypo : CF_derives (union_grammar g₁ g₂)
      [symbol.nonterminal (some (sum.inl g₁.initial))]
      (list.map symbol.terminal w)) :
  w ∈ CF_language g₁ :=
begin
  unfold CF_language,
  rw set.mem_set_of_eq,
  unfold CF_generates,
  unfold CF_generates_str,

  let gg₁ := @g₁g T g₁ g₂,

  have bar :
    [symbol.nonterminal g₁.initial] =
    (sink_string gg₁.sink_nt [symbol.nonterminal (some (sum.inl g₁.initial))]),
  {
    unfold sink_string,
    refl,
  },
  rw bar,

  have baz : list.map symbol.terminal w = sink_string gg₁.sink_nt (list.map symbol.terminal w),
  {
    unfold sink_string,
    rw list.filter_map_map,
    change list.map symbol.terminal w = list.filter_map (λ x, (sink_symbol gg₁.sink_nt ∘ symbol.terminal) x) w,
    convert_to list.map symbol.terminal w = list.filter_map (λ x, option.some (symbol.terminal x)) w,
    change list.map symbol.terminal w = list.filter_map (option.some ∘ symbol.terminal) w,
    clear hypo,
    induction w with d l,
    {
      refl,
    },
    rw list.map,
    convert_to
      symbol.terminal d :: list.map symbol.terminal l =
      symbol.terminal d :: list.filter_map (some ∘ symbol.terminal) l,
    norm_num,
    exact w_ih,
  },
  rw baz,

  exact (sink_deri gg₁ [symbol.nonterminal (some (sum.inl g₁.initial))] (list.map symbol.terminal w) hypo (by {
    good_singleton,
    use g₁.initial,
    refl,
  })).left,
end

private lemma in_language_right_case_of_union {w : list T}
    (hypo : CF_derives (union_grammar g₁ g₂)
      [symbol.nonterminal (some (sum.inr g₂.initial))]
      (list.map symbol.terminal w)) :
  w ∈ CF_language g₂ :=
begin
  unfold CF_language,
  rw set.mem_set_of_eq,
  unfold CF_generates,
  unfold CF_generates_str,

  let gg₂ := @g₂g T g₁ g₂,

  have bar :
    [symbol.nonterminal g₂.initial] =
    (sink_string gg₂.sink_nt [symbol.nonterminal (some (sum.inr g₂.initial))]),
  {
    unfold sink_string,
    refl,
  },
  rw bar,

  have baz : list.map symbol.terminal w = sink_string gg₂.sink_nt (list.map symbol.terminal w),
  {
    unfold sink_string,
    rw list.filter_map_map,
    change list.map symbol.terminal w = list.filter_map (λ x, (sink_symbol gg₂.sink_nt ∘ symbol.terminal) x) w,
    convert_to list.map symbol.terminal w = list.filter_map (λ x, option.some (symbol.terminal x)) w,
    change list.map symbol.terminal w = list.filter_map (option.some ∘ symbol.terminal) w,
    clear hypo,
    induction w with d l,
    {
      refl,
    },
    rw list.map,
    convert_to
      symbol.terminal d :: list.map symbol.terminal l =
      symbol.terminal d :: list.filter_map (some ∘ symbol.terminal) l,
    norm_num,
    exact w_ih,
  },
  rw baz,

  exact (sink_deri gg₂ [symbol.nonterminal (some (sum.inr g₂.initial))] (list.map symbol.terminal w) hypo (by {
    good_singleton,
    use g₂.initial,
    refl,
  })).left,
end

private lemma both_empty
    (u v: list (symbol T (union_grammar g₁ g₂).nt))
    (a : (symbol T (union_grammar g₁ g₂).nt))
    (bef: [symbol.nonterminal (union_grammar g₁ g₂).initial] = u ++ [a] ++ v) :
  u = []  ∧  v = [] :=
begin
  have len := congr_arg list.length bef,
  rw [list.length_singleton, list.length_append, list.length_append, list.length_singleton] at len,
  split,
  {
    by_contradiction,
    rw ←list.length_eq_zero at h,
    exact nat.not_succ_le_self 1 (by calc
      1 = (u.length + 1) + v.length : len
    ... = u.length + (1 + v.length) : add_assoc (list.length u) 1 (list.length v)
    ... ≥ 1 + (1 + v.length)        : add_le_add (nat.one_le_iff_ne_zero.mpr h) (le_of_eq rfl)
    ... = (1 + 1) + v.length        : eq.symm (add_assoc 1 1 (list.length v))
    ... ≥ 1 + 1 + 0                 : le_self_add
    ... = 2                         : rfl),
  },
  {
    by_contradiction,
    rw ←list.length_eq_zero at h,
    exact nat.not_succ_le_self 1 (by calc
      1 = (u.length + 1) + v.length : len
    ... ≥ (u.length + 1) + 1        : add_le_add (le_of_eq rfl) (nat.one_le_iff_ne_zero.mpr h)
    ... = u.length + (1 + 1)        : add_assoc (list.length u) 1 1
    ... ≥ 0 + (1 + 1)               : le_add_self
    ... = (0 + 1) + 1               : eq.symm (add_assoc 0 1 1)
    ... = 2                         : rfl),
  },
end

private lemma in_language_impossible_case_of_union
    (w : list T)
    (r : (union_grammar g₁ g₂).nt × list (symbol T (union_grammar g₁ g₂).nt))
    (u v: list (symbol T (union_grammar g₁ g₂).nt))
    (hu : u = []) (hv : v = [])
    (bef: [symbol.nonterminal (union_grammar g₁ g₂).initial] = u ++ [symbol.nonterminal r.fst] ++ v)
    (sbi : r ∈ (list.map rule_of_rule₁ g₁.rules ++ list.map rule_of_rule₂ g₂.rules)) :
  w ∈ CF_language g₁ ∨ w ∈ CF_language g₂ :=
begin
  exfalso,
  rw [hu, hv] at bef,
  rw [list.nil_append, list.append_nil] at bef,
  change [symbol.nonterminal none] = [symbol.nonterminal r.fst] at bef,
  have rule_root : r.fst = none,
  {
    have almost := list.head_eq_of_cons_eq bef,
    exact symbol.nonterminal.inj almost.symm,
  },
  rw list.mem_append at sbi,
  cases sbi,
  {
    rw list.mem_map at sbi,
    rcases sbi with ⟨r₁, -, imposs⟩,
    unfold rule_of_rule₁ at imposs,
    rw ←imposs at rule_root,
    unfold prod.fst at rule_root,
    exact option.no_confusion rule_root,
  },
  {
    rw list.mem_map at sbi,
    rcases sbi with ⟨r₂, -, imposs⟩,
    unfold rule_of_rule₂ at imposs,
    rw ←imposs at rule_root,
    unfold prod.fst at rule_root,
    exact option.no_confusion rule_root,
  },
end

private lemma in_language_of_in_union (w : list T) :
  w ∈ CF_language (union_grammar g₁ g₂)   →   w ∈ CF_language g₁  ∨  w ∈ CF_language g₂   :=
begin
  intro ass,

  cases CF_tran_or_id_of_deri ass with impossible h,
  {
    exfalso,
    have zeroth := congr_arg (λ p, list.nth p 0) impossible,
    unfold list.nth at zeroth,
    rw list.nth_map at zeroth,
    cases (w.nth 0),
    {
      rw option.map_none' at zeroth,
      exact option.no_confusion zeroth,
    },
    {
      rw option.map_some' at zeroth,
      exact symbol.no_confusion (option.some.inj zeroth),
    },
  },
  rcases h with ⟨S₁, deri_head, deri_tail⟩,
  rcases deri_head with ⟨rule, ruleok, u, v, h_bef, h_aft⟩,

  rw h_aft at deri_tail,
  cases both_empty u v (symbol.nonterminal rule.fst) h_bef with u_nil v_nil,

  cases ruleok with g₁S r_rest,
  {
    left,
    rw g₁S at *,
    rw u_nil at deri_tail,
    rw v_nil at deri_tail,
    rw list.nil_append at deri_tail,
    exact in_language_left_case_of_union deri_tail,
  },
  cases r_rest with g₂S r_imposs,
  {
    right,
    rw g₂S at *,
    rw u_nil at deri_tail,
    rw v_nil at deri_tail,
    rw list.nil_append at deri_tail,
    exact in_language_right_case_of_union deri_tail,
  },
  exact in_language_impossible_case_of_union w rule u v u_nil v_nil h_bef r_imposs,
end

end lemmata_supset

/-- The class of context-free languages is closed under union. -/
theorem CF_of_CF_u_CF {T : Type} (L₁ : language T) (L₂ : language T) :
  is_CF L₁  ∧  is_CF L₂   →   is_CF (L₁ + L₂)   :=
begin
  rintro ⟨⟨g₁, eq_L₁⟩, ⟨g₂, eq_L₂⟩⟩,

  use union_grammar g₁ g₂,

  apply set.eq_of_subset_of_subset,
  {
    -- prove `L₁ + L₂ ⊇ `
    intros w hyp,
    rw language.mem_add,
    rw ←eq_L₁,
    rw ←eq_L₂,
    exact in_language_of_in_union w hyp,
  },
  {
    -- prove `L₁ + L₂ ⊆ `
    intros w hyp,
    cases hyp with case₁ case₂,
    {
      rw ←eq_L₁ at case₁,
      exact in_union_of_in_first w case₁,
    },
    {
      rw ←eq_L₂ at case₂,
      exact in_union_of_in_second w case₂,
    },
  },
end


import pq_to_group

import tactic

universes u v

section counit_ker_abelian

variables {G : Type u} [group G]

lemma of_inv_group : ∀ x : G, of (x⁻¹) = (of x)⁻¹ :=
begin
  intro x,
  repeat {rw ←gpow_neg_one},
  rw of_pow_eq_pow_of,
end

theorem inner_aut_eq : ∀ x y : pq_group G, x ▷ y = (of (counit x)) ▷ y :=
begin
  intros x,
  induction x,
  {
    rw quot_mk_helper,
    induction x,
    {
      intro y,
      rw ←unit_def,
      apply congr_arg (λ a, a ▷ y),
      rw monoid_hom.map_one,
      rw of_1_eq_unit,
    },
    {
      intro y,
      rw ←of_def,
      rw counit_of,
    },
    {
      intro y,

      rw counit_mul,
      rw ←mul_def,

      rw mul_rhd,
      rw x_ih_b,
      rw x_ih_a,

      rw ←mul_rhd,

      induction y,
      {
        rw quot_mk_helper at *,
        induction y,
        {
          rw ←unit_def,
          repeat {rw power_quandle.rhd_one},
        },
        {
          repeat {rw ←of_def at *},
          rw rhd_def_group,
          rw rhd_def_group,
          have halg_rw_1 : ∀ a b c : pq_group G, a*b*c*(a*b)⁻¹ = a*(b*c*b⁻¹)*a⁻¹,
          {
            intros a b c,
            group,
          },
          rw halg_rw_1,
          repeat {rw rhd_eq_conj},
          rw mul_rhd,
        },
        {
          rw ←mul_def,
          rw rhd_mul,
          rw rhd_mul,
          rw y_ih_a,
          rw y_ih_b,
        },
        {
          rw ←inv_def,
          rw rhd_inv,
          rw y_ih,
          rw rhd_inv,
        },
      },
      {refl,},

    },
    {
      /-
      intro y,
      rw ←inv_def,
      have hx := x_ih (⟦x_a⟧⁻¹▷⟦x_a⟧⁻¹▷y),
      rw ←mul_rhd_eq_rhd at hx,
      simp only [mul_right_inv] at hx,
      rw one_rhd at hx,
      rw hx,
      -/
      intro y,
      rw ←inv_def,
      have hx := x_ih (⟦x_a⟧⁻¹▷y),
      rw ←mul_rhd at hx,
      simp only [mul_right_inv] at hx,
      rw power_quandle.one_rhd at hx,
      --rw hx,
      rw monoid_hom.map_inv,
      rw of_inv_group,
      rw hx,
      rw ←mul_rhd ((of _) ⁻¹),
      simp only [mul_left_inv],
      rw ←hx,
      rw power_quandle.one_rhd,
    }
  },
  {intro y, refl,},
end

theorem counit_ker_center : ∀ a : ((counit : pq_group G →* G).ker), ∀ b : pq_group G, ↑a * b = b * a :=
begin
  intros a b,
  cases a with a ha,
  simp only [subtype.coe_mk],
  rw center_reformulate,
  rw ←rhd_def_group,
  rw inner_aut_eq,
  have ha1 : counit a = 1 := ha,
  rw ha1,
  rw of_1_eq_unit,
  rw power_quandle.one_rhd,
end

theorem counit_ker_sub_center : ((counit : pq_group G →* G).ker) ≤ subgroup.center (pq_group G) :=
begin
  intros x hx,
  intro y,
  apply eq.symm,
  apply counit_ker_center ⟨x, hx⟩ y,
end

theorem counit_ker_abelian : ∀ a b : ((counit : pq_group G →* G).ker), a * b = b * a :=
begin
  intros a b,
  cases b with b hb,
  ext1,
  simp only [subgroup.coe_mul, subtype.coe_mk],
  apply counit_ker_center,
end

lemma counit_ker_rhd : ∀ a b : ((counit : pq_group G →* G).ker), a ▷ b = b :=
begin
  intros a b,
  rw rhd_def_group,
  rw counit_ker_abelian,
  group,
end

lemma counit_ker_abelian_counit (a b : pq_group G) (ha : counit a = 1) : a * b = b * a :=
begin
  suffices : ↑(⟨a, ha⟩ : (counit : pq_group G →* G).ker) * b = b * a,
  simp only [subtype.coe_mk] at this,
  exact this,
  rw counit_ker_center,
  refl,
end

lemma counit_ker_counit (a : ((counit : pq_group G →* G).ker)) : counit (↑a : pq_group G) = 1 :=
begin
  cases a with a ha,
  simp only [subtype.coe_mk],
  exact ha,
end

lemma counit_ker_rhd_left_counit (a b : pq_group G) (ha : counit a = 1) : a ▷ b = b :=
begin
  rw rhd_def_group,
  rw counit_ker_abelian_counit a,
  simp only [mul_inv_cancel_right],
  exact ha,
end

lemma counit_ker_rhd_right_counit (a b : pq_group G) (ha : counit a = 1) : b ▷ a = a :=
begin
  rw rhd_def_group,
  rw mul_assoc,
  rw counit_ker_abelian_counit a,
  simp only [mul_inv_cancel_left],
  exact ha,
end

/-
instance counit_ker_comm : comm_group ((counit : pq_group G →* G).ker) := {
  mul_comm := begin
    exact counit_ker_abelian,
  end ,
  ..
}
-/

end counit_ker_abelian

section phi_ker

variables {G : Type u} [group G]

/-
@[ext]
structure deg (G : Type u) [group G] := (g : G)

instance degen_pq_G : power_quandle (deg G) := {
  triangle_left := λ x y, x,
  triangle_right := λ x y, y,
  right_dist := begin intros a b c, refl, end,
  left_dist := begin intros a b c, refl, end,
  right_inv := begin intros a b, refl, end,
  left_inv := begin intros a b, refl, end,
  self_idem_right := begin intro a, refl, end,
  self_idem_left := begin intro a, refl, end,
  pow := λ x n, ⟨x.g ^ n⟩,
  pow_1 := begin intro a, cases a, ext, simp only [gpow_one], end,
  pow_comp := begin intros a n m, cases a, ext, simp only, exact power_quandle.pow_comp a n m, end,
  q_pow0 := begin intros a b, refl, end,
  q_pown_right := begin intros a b n, refl, end,
  q_powneg_left := begin intros a b, refl, end,
  q_powadd := begin intros a b n m, refl, end }

lemma deg_rhd_def : ∀ a b : (deg G), a ▷ b = b :=
begin
  intros a b,
  refl,
end

lemma deg_pow_def : ∀ a : (deg G), ∀ n : ℤ, a ^ n = ⟨a.g ^ n⟩ :=
begin
  intros a n,
  refl,
end
-/
notation `kerc` G := (counit : pq_group G →* G).ker

def φ' : G × G → kerc G := λ ⟨x, y⟩, ⟨of x * of y * (of (x*y))⁻¹, begin
  refine counit.mem_ker.mpr _,
  repeat {rw monoid_hom.map_mul},
  rw monoid_hom.map_inv,
  repeat {rw counit_of},
  group,
end⟩

theorem φ'_is_cocycle : ∀ g h k : G, φ'(g, h) * φ'(g * h, k) = φ'(g, h * k) * φ'(h ,k) :=
begin
  intros g h k,
  rw counit_ker_abelian (φ' (g, h * k))  (φ' (h, k)),
  unfold φ',
  ext1,
  simp only [subgroup.coe_mul, subgroup.coe_mk],
  have alg_rw : of h * of k * (of (h * k))⁻¹ * (of g * of (h * k) * (of (g * (h * k)))⁻¹) = (of h * (of k * ((of (h * k))⁻¹ * of g * ((of (h * k))⁻¹)⁻¹) * (of k)⁻¹) * (of h)⁻¹ * of h * of k) * (of (g * (h * k)))⁻¹,
  {
    group,
  },
  rw alg_rw,
  clear alg_rw,
  rw ←rhd_def_group,
  rw ←rhd_def_group,
  rw ←rhd_def_group,
  rw ←mul_assoc g h k,
  group,
  rw ←of_pow_eq_pow_of,
  repeat {rw rhd_of_eq_of_rhd},
  repeat {rw rhd_def_group},
  group,
end

end phi_ker

section center_LR_morph

variables {G : Type u} [group G]

def center_LR_morph_fun : subgroup.center (pq_group G) → subgroup.center (G) :=
begin
  intro x,
  cases x with x hx,
  fconstructor,
  exact counit x,
  intro y,
  specialize hx (of y),
  have hx1 := congr_arg counit hx,
  repeat {rw monoid_hom.map_mul at hx1},
  repeat {rw counit_of at hx1},
  exact hx1,
end

def center_LR_morph : subgroup.center (pq_group G) →* subgroup.center (G) := ⟨center_LR_morph_fun, begin
  have one_rw : (1 : subgroup.center (pq_group G)) = ⟨1, _⟩ := rfl,
  rw one_rw,
  unfold center_LR_morph_fun,
  ext1,
  simp only [subgroup.coe_one, subtype.coe_mk, monoid_hom.map_one],
end, begin
  intros x y,
  cases x with x hx,
  cases y with y hy,
  have prod_rw : (⟨x, hx⟩ * ⟨y, hy⟩ : subgroup.center (pq_group G)) = ⟨x * y, _⟩ := rfl,
  rw prod_rw,
  unfold center_LR_morph_fun,
  ext1,
  simp only [monoid_hom.map_mul, subgroup.coe_mul, subtype.coe_mk],
end⟩

noncomputable theorem counit_ker_iso_center_LR_morph_ker : (counit : pq_group G →* G).ker ≃* (center_LR_morph : subgroup.center (pq_group G) →* subgroup.center (G) ).ker :=
begin
  fapply mul_equiv.of_bijective,
  fconstructor,
  {
    intro x,
    cases x with x hx,
    fconstructor,
    fconstructor,
    exact x,

    apply counit_ker_sub_center,
    exact hx,
    ext1,
    exact hx,
  },
  {
    refl,
  },
  {
    intros x y,
    cases x with x hx,
    cases y with y hy,
    ext1,
    ext1,
    have prod_rw : (⟨x, hx⟩ * ⟨y, hy⟩ : ((counit : pq_group G →* G).ker)) = ⟨x * y, _⟩ := rfl,
    rw prod_rw,
    simp only [subgroup.coe_mul, subtype.coe_mk],
  },
  {
    split,
    {
      simp only [monoid_hom.coe_mk],
      intros x y,
      cases x with x hx,
      cases y with y hy,
      simp only [imp_self, subtype.mk_eq_mk],
    },
    {
      simp only [monoid_hom.coe_mk],
      intro x,
      cases x with x hx,
      cases x with x hx1,
      fconstructor,
      fconstructor,
      exact x,
      {
        have hx2 : center_LR_morph ⟨x, _⟩ = 1 := hx,
        injections_and_clear,
        exact h_1,
      },
      refl,
    },
  }
end

end center_LR_morph