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

! This file was ported from Lean 3 source module group_theory.group_action.fixing_subgroup
! leanprover-community/mathlib commit f93c11933efbc3c2f0299e47b8ff83e9b539cbf6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Subgroup.Actions
import Mathlib.GroupTheory.GroupAction.Basic

/-!

# Fixing submonoid, fixing subgroup of an action

In the presence of of an action of a monoid or a group,
this file defines the fixing submonoid or the fixing subgroup,
and relates it to the set of fixed points via a Galois connection.

## Main definitions

* `fixingSubmonoid M s` : in the presence of `MulAction M α` (with `monoid M`)
  it is the `Submonoid M` consisting of elements which fix `s : Set α` pointwise.

* `fixingSubmonoid_fixedPoints_gc M α` is the `GaloisConnection`
  that relates `fixingSubmonoid` with `fixedPoints`.

* `fixingSubgroup M s` : in the presence of `MulAction M α` (with `Group M`)
  it is the `Subgroup M` consisting of elements which fix `s : Set α` pointwise.

* `fixingSubgroup_fixedPoints_gc M α` is the `GaloisConnection`
  that relates `fixingSubgroup` with `fixedPoints`.

TODO :

* Maybe other lemmas are useful

* Treat semigroups ?

-/

section Monoid

open MulAction

variable (M : Type _) {α : Type _} [Monoid M] [MulAction M α]

/-- The submonoid fixing a set under a `MulAction`. -/
@[to_additive " The additive submonoid fixing a set under an `AddAction`. "]
def fixingSubmonoid (s : Set α) : Submonoid M
    where
  carrier := { ϕ : M | ∀ x : s, ϕ • (x : α) = x }
  one_mem' _ := one_smul _ _
  mul_mem' {x y} hx hy z := by rw [mul_smul, hy z, hx z]
#align fixing_submonoid fixingSubmonoid
#align fixing_add_submonoid fixingAddSubmonoid

theorem mem_fixingSubmonoid_iff {s : Set α} {m : M} :
    m ∈ fixingSubmonoid M s ↔ ∀ y ∈ s, m • y = y :=
  ⟨fun hg y hy => hg ⟨y, hy⟩, fun h ⟨y, hy⟩ => h y hy⟩
#align mem_fixing_submonoid_iff mem_fixingSubmonoid_iff

variable (α)

/-- The Galois connection between fixing submonoids and fixed points of a monoid action -/
theorem fixingSubmonoid_fixedPoints_gc :
    GaloisConnection (OrderDual.toDual ∘ fixingSubmonoid M)
      ((fun P : Submonoid M => fixedPoints P α) ∘ OrderDual.ofDual) :=
  fun _s _P => ⟨fun h s hs p => h p.2 ⟨s, hs⟩, fun h p hp s => h s.2 ⟨p, hp⟩⟩
#align fixing_submonoid_fixed_points_gc fixingSubmonoid_fixedPoints_gc

theorem fixingSubmonoid_antitone : Antitone fun s : Set α => fixingSubmonoid M s :=
  (fixingSubmonoid_fixedPoints_gc M α).monotone_l
#align fixing_submonoid_antitone fixingSubmonoid_antitone

theorem fixedPoints_antitone : Antitone fun P : Submonoid M => fixedPoints P α :=
  (fixingSubmonoid_fixedPoints_gc M α).monotone_u.dual_left
#align fixed_points_antitone fixedPoints_antitone

/-- Fixing submonoid of union is intersection -/
theorem fixingSubmonoid_union {s t : Set α} :
    fixingSubmonoid M (s ∪ t) = fixingSubmonoid M s ⊓ fixingSubmonoid M t :=
  (fixingSubmonoid_fixedPoints_gc M α).l_sup
#align fixing_submonoid_union fixingSubmonoid_union

/-- Fixing submonoid of unionᵢ is intersection -/
theorem fixingSubmonoid_unionᵢ {ι : Sort _} {s : ι → Set α} :
    fixingSubmonoid M (⋃ i, s i) = ⨅ i, fixingSubmonoid M (s i) :=
  (fixingSubmonoid_fixedPoints_gc M α).l_supᵢ
#align fixing_submonoid_Union fixingSubmonoid_unionᵢ

/-- Fixed points of sup of submonoids is intersection -/
theorem fixedPoints_submonoid_sup {P Q : Submonoid M} :
    fixedPoints (↥(P ⊔ Q)) α = fixedPoints P α ∩ fixedPoints Q α :=
  (fixingSubmonoid_fixedPoints_gc M α).u_inf
#align fixed_points_submonoid_sup fixedPoints_submonoid_sup

/-- Fixed points of supᵢ of submonoids is intersection -/
theorem fixedPoints_submonoid_supᵢ {ι : Sort _} {P : ι → Submonoid M} :
    fixedPoints (↥(supᵢ P)) α = ⋂ i, fixedPoints (P i) α :=
  (fixingSubmonoid_fixedPoints_gc M α).u_infᵢ
#align fixed_points_submonoid_supr fixedPoints_submonoid_supᵢ

end Monoid

section Group

open MulAction

variable (M : Type _) {α : Type _} [Group M] [MulAction M α]

/-- The subgroup fixing a set under a `MulAction`. -/
@[to_additive " The additive subgroup fixing a set under an `AddAction`. "]
def fixingSubgroup (s : Set α) : Subgroup M :=
  { fixingSubmonoid M s with inv_mem' := fun hx z => by rw [inv_smul_eq_iff, hx z] }
#align fixing_subgroup fixingSubgroup
#align fixing_add_subgroup fixingAddSubgroup

theorem mem_fixingSubgroup_iff {s : Set α} {m : M} : m ∈ fixingSubgroup M s ↔ ∀ y ∈ s, m • y = y :=
  ⟨fun hg y hy => hg ⟨y, hy⟩, fun h ⟨y, hy⟩ => h y hy⟩
#align mem_fixing_subgroup_iff mem_fixingSubgroup_iff

variable (α)

/-- The Galois connection between fixing subgroups and fixed points of a group action -/
theorem fixingSubgroup_fixedPoints_gc :
    GaloisConnection (OrderDual.toDual ∘ fixingSubgroup M)
      ((fun P : Subgroup M => fixedPoints P α) ∘ OrderDual.ofDual) :=
  fun _s _P => ⟨fun h s hs p => h p.2 ⟨s, hs⟩, fun h p hp s => h s.2 ⟨p, hp⟩⟩
#align fixing_subgroup_fixed_points_gc fixingSubgroup_fixedPoints_gc

theorem fixingSubgroup_antitone : Antitone (fixingSubgroup M : Set α → Subgroup M) :=
  (fixingSubgroup_fixedPoints_gc M α).monotone_l
#align fixing_subgroup_antitone fixingSubgroup_antitone

theorem fixedPoints_subgroup_antitone : Antitone fun P : Subgroup M => fixedPoints P α :=
  (fixingSubgroup_fixedPoints_gc M α).monotone_u.dual_left
#align fixed_points_subgroup_antitone fixedPoints_subgroup_antitone

/-- Fixing subgroup of union is intersection -/
theorem fixingSubgroup_union {s t : Set α} :
    fixingSubgroup M (s ∪ t) = fixingSubgroup M s ⊓ fixingSubgroup M t :=
  (fixingSubgroup_fixedPoints_gc M α).l_sup
#align fixing_subgroup_union fixingSubgroup_union

/-- Fixing subgroup of unionᵢ is intersection -/
theorem fixingSubgroup_unionᵢ {ι : Sort _} {s : ι → Set α} :
    fixingSubgroup M (⋃ i, s i) = ⨅ i, fixingSubgroup M (s i) :=
  (fixingSubgroup_fixedPoints_gc M α).l_supᵢ
#align fixing_subgroup_Union fixingSubgroup_unionᵢ

/-- Fixed points of sup of subgroups is intersection -/
theorem fixedPoints_subgroup_sup {P Q : Subgroup M} :
    fixedPoints (↥(P ⊔ Q)) α = fixedPoints P α ∩ fixedPoints Q α :=
  (fixingSubgroup_fixedPoints_gc M α).u_inf
#align fixed_points_subgroup_sup fixedPoints_subgroup_sup

/-- Fixed points of supᵢ of subgroups is intersection -/
theorem fixedPoints_subgroup_supᵢ {ι : Sort _} {P : ι → Subgroup M} :
    fixedPoints (↥(supᵢ P)) α = ⋂ i, fixedPoints (P i) α :=
  (fixingSubgroup_fixedPoints_gc M α).u_infᵢ
#align fixed_points_subgroup_supr fixedPoints_subgroup_supᵢ

end Group


/-
Copyright (c) 2021 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux
-/
import analysis.normed_space.operator_norm
import topology.metric_space.baire
import topology.algebra.module.basic
/-!
# The Banach-Steinhaus theorem: Uniform Boundedness Principle

Herein we prove the Banach-Steinhaus theorem: any collection of bounded linear maps
from a Banach space into a normed space which is pointwise bounded is uniformly bounded.

## TODO

For now, we only prove the standard version by appeal to the Baire category theorem.
Much more general versions exist (in particular, for maps from barrelled spaces to locally
convex spaces), but these are not yet in `mathlib`.
-/

open set

variables
{E F 𝕜 𝕜₂ : Type*}
[seminormed_add_comm_group E] [seminormed_add_comm_group F]
[nontrivially_normed_field 𝕜] [nontrivially_normed_field 𝕜₂]
[normed_space 𝕜 E] [normed_space 𝕜₂ F]
{σ₁₂ : 𝕜 →+* 𝕜₂} [ring_hom_isometric σ₁₂]

/-- This is the standard Banach-Steinhaus theorem, or Uniform Boundedness Principle.
If a family of continuous linear maps from a Banach space into a normed space is pointwise
bounded, then the norms of these linear maps are uniformly bounded. -/
theorem banach_steinhaus {ι : Type*} [complete_space E] {g : ι → E →SL[σ₁₂] F}
  (h : ∀ x, ∃ C, ∀ i, ‖g i x‖ ≤ C) :
  ∃ C', ∀ i, ‖g i‖ ≤ C' :=
begin
  /- sequence of subsets consisting of those `x : E` with norms `‖g i x‖` bounded by `n` -/
  let e : ℕ → set E := λ n, (⋂ i : ι, { x : E | ‖g i x‖ ≤ n }),
  /- each of these sets is closed -/
  have hc : ∀ n : ℕ, is_closed (e n), from λ i, is_closed_Inter (λ i,
    is_closed_le (continuous.norm (g i).cont) continuous_const),
  /- the union is the entire space; this is where we use `h` -/
  have hU : (⋃ n : ℕ, e n) = univ,
  { refine eq_univ_of_forall (λ x, _),
    cases h x with C hC,
    obtain ⟨m, hm⟩ := exists_nat_ge C,
    exact ⟨e m, mem_range_self m, mem_Inter.mpr (λ i, le_trans (hC i) hm)⟩ },
  /- apply the Baire category theorem to conclude that for some `m : ℕ`, `e m` contains some `x` -/
  rcases nonempty_interior_of_Union_of_closed hc hU with ⟨m, x, hx⟩,
  rcases metric.is_open_iff.mp is_open_interior x hx with ⟨ε, ε_pos, hε⟩,
  obtain ⟨k, hk⟩ := normed_field.exists_one_lt_norm 𝕜,
  /- show all elements in the ball have norm bounded by `m` after applying any `g i` -/
  have real_norm_le : ∀ z : E, z ∈ metric.ball x ε → ∀ i : ι, ‖g i z‖ ≤ m,
  { intros z hz i,
    replace hz := mem_Inter.mp (interior_Inter_subset _ (hε hz)) i,
    apply interior_subset hz },
  have εk_pos : 0 < ε / ‖k‖ := div_pos ε_pos (zero_lt_one.trans hk),
  refine ⟨(m + m : ℕ) / (ε / ‖k‖), λ i, continuous_linear_map.op_norm_le_of_shell ε_pos _ hk _⟩,
  { exact div_nonneg (nat.cast_nonneg _) εk_pos.le },
  intros y le_y y_lt,
  calc ‖g i y‖
      = ‖g i (y + x) - g i x‖   : by rw [continuous_linear_map.map_add, add_sub_cancel]
  ... ≤ ‖g i (y + x)‖ + ‖g i x‖ : norm_sub_le _ _
  ... ≤ m + m : add_le_add (real_norm_le (y + x) (by rwa [add_comm, add_mem_ball_iff_norm]) i)
          (real_norm_le x (metric.mem_ball_self ε_pos) i)
  ... = (m + m : ℕ) : (m.cast_add m).symm
  ... ≤ (m + m : ℕ) * (‖y‖ / (ε / ‖k‖))
      : le_mul_of_one_le_right (nat.cast_nonneg _)
          ((one_le_div $ div_pos ε_pos (zero_lt_one.trans hk)).2 le_y)
  ... = (m + m : ℕ) / (ε / ‖k‖) * ‖y‖ : (mul_comm_div _ _ _).symm,
end

open_locale ennreal
open ennreal

/-- This version of Banach-Steinhaus is stated in terms of suprema of `↑‖⬝‖₊ : ℝ≥0∞`
for convenience. -/
theorem banach_steinhaus_supr_nnnorm {ι : Type*} [complete_space E] {g : ι → E →SL[σ₁₂] F}
  (h : ∀ x, (⨆ i, ↑‖g i x‖₊) < ∞) :
  (⨆ i, ↑‖g i‖₊) < ∞ :=
begin
  have h' : ∀ x : E, ∃ C : ℝ, ∀ i : ι, ‖g i x‖ ≤ C,
  { intro x,
    rcases lt_iff_exists_coe.mp (h x) with ⟨p, hp₁, _⟩,
    refine ⟨p, (λ i, _)⟩,
    exact_mod_cast
    calc (‖g i x‖₊ : ℝ≥0∞) ≤ ⨆ j,  ‖g j x‖₊ : le_supr _ i
      ...                  = p              : hp₁ },
  cases banach_steinhaus h' with C' hC',
  refine (supr_le $ λ i, _).trans_lt (@coe_lt_top C'.to_nnreal),
  rw ←norm_to_nnreal,
  exact coe_mono (real.to_nnreal_le_to_nnreal $ hC' i),
end

open_locale topology
open filter

/-- Given a *sequence* of continuous linear maps which converges pointwise and for which the
domain is complete, the Banach-Steinhaus theorem is used to guarantee that the limit map
is a *continuous* linear map as well. -/
def continuous_linear_map_of_tendsto [complete_space E] [t2_space F]
  (g : ℕ → E →SL[σ₁₂] F) {f : E → F} (h : tendsto (λ n x, g n x) at_top (𝓝 f)) :
  E →SL[σ₁₂] F :=
{ to_fun := f,
  map_add' := (linear_map_of_tendsto _ _ h).map_add',
  map_smul' := (linear_map_of_tendsto _ _ h).map_smul',
  cont :=
    begin
      /- show that the maps are pointwise bounded and apply `banach_steinhaus`-/
      have h_point_bdd : ∀ x : E, ∃ C : ℝ, ∀ n : ℕ, ‖g n x‖ ≤ C,
      { intro x,
        rcases cauchy_seq_bdd (tendsto_pi_nhds.mp h x).cauchy_seq with ⟨C, C_pos, hC⟩,
        refine ⟨C + ‖g 0 x‖, (λ n, _)⟩,
        simp_rw dist_eq_norm at hC,
        calc ‖g n x‖ ≤ ‖g 0 x‖ + ‖g n x - g 0 x‖ : norm_le_insert' _ _
          ...        ≤ C + ‖g 0 x‖               : by linarith [hC n 0] },
      cases banach_steinhaus h_point_bdd with C' hC',
      /- show the uniform bound from `banach_steinhaus` is a norm bound of the limit map
         by allowing "an `ε` of room." -/
      refine add_monoid_hom_class.continuous_of_bound (linear_map_of_tendsto _ _ h) C'
        (λ x, le_of_forall_pos_lt_add (λ ε ε_pos, _)),
      cases metric.tendsto_at_top.mp (tendsto_pi_nhds.mp h x) ε ε_pos with n hn,
      have lt_ε : ‖g n x - f x‖ < ε, by {rw ←dist_eq_norm, exact hn n (le_refl n)},
      calc ‖f x‖ ≤ ‖g n x‖ + ‖g n x - f x‖ : norm_le_insert _ _
        ...      < ‖g n‖ * ‖x‖ + ε        : by linarith [lt_ε, (g n).le_op_norm x]
        ...      ≤ C' * ‖x‖ + ε           : by nlinarith [hC' n, norm_nonneg x],
    end }


/-
Copyright (c) 2020 Yury Kudryashov, Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Anne Baanen
-/
import data.fintype.big_operators
import data.fintype.fin
import data.list.fin_range
import logic.equiv.fin

/-!
# Big operators and `fin`

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

Some results about products and sums over the type `fin`.

The most important results are the induction formulas `fin.prod_univ_cast_succ`
and `fin.prod_univ_succ`, and the formula `fin.prod_const` for the product of a
constant function. These results have variants for sums instead of products.

-/

open_locale big_operators

open finset

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

namespace finset

@[to_additive]
theorem prod_range [comm_monoid β] {n : ℕ} (f : ℕ → β) :
  ∏ i in finset.range n, f i = ∏ i : fin n, f i :=
prod_bij'
  (λ k w, ⟨k, mem_range.mp w⟩)
  (λ a ha, mem_univ _)
  (λ a ha, congr_arg _ (fin.coe_mk _).symm)
  (λ a m, a)
  (λ a m, mem_range.mpr a.prop)
  (λ a ha, fin.coe_mk _)
  (λ a ha, fin.eta _ _)

end finset

namespace fin

@[to_additive]
theorem prod_univ_def [comm_monoid β] {n : ℕ} (f : fin n → β) :
  ∏ i, f i = ((list.fin_range n).map f).prod :=
by simp [univ_def]

@[to_additive]
theorem prod_of_fn [comm_monoid β] {n : ℕ} (f : fin n → β) :
  (list.of_fn f).prod = ∏ i, f i :=
by rw [list.of_fn_eq_map, prod_univ_def]

/-- A product of a function `f : fin 0 → β` is `1` because `fin 0` is empty -/
@[to_additive "A sum of a function `f : fin 0 → β` is `0` because `fin 0` is empty"]
theorem prod_univ_zero [comm_monoid β] (f : fin 0 → β) : ∏ i, f i = 1 := rfl

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f x`, for some `x : fin (n + 1)` times the remaining product -/
@[to_additive "A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)` is the sum of `f x`,
for some `x : fin (n + 1)` plus the remaining product"]

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f 0` plus the remaining product -/
@[to_additive "A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)` is the sum of `f 0`
plus the remaining product"]
theorem prod_univ_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = f 0 * ∏ i : fin n, f i.succ :=
prod_univ_succ_above f 0

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f (fin.last n)` plus the remaining product -/
@[to_additive "A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)` is the sum of
`f (fin.last n)` plus the remaining sum"]
theorem prod_univ_cast_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = (∏ i : fin n, f i.cast_succ) * f (last n) :=
by simpa [mul_comm] using prod_univ_succ_above f (last n)

@[to_additive] lemma prod_cons [comm_monoid β] {n : ℕ} (x : β) (f : fin n → β) :
  ∏ i : fin n.succ, (cons x f : fin n.succ → β) i = x * ∏ i : fin n, f i :=
by simp_rw [prod_univ_succ, cons_zero, cons_succ]

@[to_additive sum_univ_one] theorem prod_univ_one [comm_monoid β] (f : fin 1 → β) :
  ∏ i, f i = f 0 :=
by simp

@[simp, to_additive] theorem prod_univ_two [comm_monoid β] (f : fin 2 → β) :
  ∏ i, f i = f 0 * f 1 :=
by simp [prod_univ_succ]

@[to_additive] theorem prod_univ_three [comm_monoid β] (f : fin 3 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 :=
by { rw [prod_univ_cast_succ, prod_univ_two], refl }

@[to_additive] theorem prod_univ_four [comm_monoid β] (f : fin 4 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 * f 3 :=
by { rw [prod_univ_cast_succ, prod_univ_three], refl }

@[to_additive] theorem prod_univ_five [comm_monoid β] (f : fin 5 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 * f 3 * f 4 :=
by { rw [prod_univ_cast_succ, prod_univ_four], refl }

@[to_additive] theorem prod_univ_six [comm_monoid β] (f : fin 6 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 * f 3 * f 4 * f 5 :=
by { rw [prod_univ_cast_succ, prod_univ_five], refl }

@[to_additive] theorem prod_univ_seven [comm_monoid β] (f : fin 7 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 * f 3 * f 4 * f 5 * f 6 :=
by { rw [prod_univ_cast_succ, prod_univ_six], refl }

@[to_additive] theorem prod_univ_eight [comm_monoid β] (f : fin 8 → β) :
  ∏ i, f i = f 0 * f 1 * f 2 * f 3 * f 4 * f 5 * f 6 * f 7 :=
by { rw [prod_univ_cast_succ, prod_univ_seven], refl }

lemma sum_pow_mul_eq_add_pow {n : ℕ} {R : Type*} [comm_semiring R] (a b : R) :
  ∑ s : finset (fin n), a ^ s.card * b ^ (n - s.card) = (a + b) ^ n :=
by simpa using fintype.sum_pow_mul_eq_add_pow (fin n) a b

lemma prod_const [comm_monoid α] (n : ℕ) (x : α) : ∏ i : fin n, x = x ^ n := by simp

lemma sum_const [add_comm_monoid α] (n : ℕ) (x : α) : ∑ i : fin n, x = n • x := by simp

@[to_additive] lemma prod_Ioi_zero {M : Type*} [comm_monoid M] {n : ℕ} {v : fin n.succ → M} :
  ∏ i in Ioi 0, v i = ∏ j : fin n, v j.succ :=
by rw [Ioi_zero_eq_map, finset.prod_map, rel_embedding.coe_fn_to_embedding, coe_succ_embedding]

@[to_additive]
lemma prod_Ioi_succ {M : Type*} [comm_monoid M] {n : ℕ} (i : fin n) (v : fin n.succ → M) :
  ∏ j in Ioi i.succ, v j = ∏ j in Ioi i, v j.succ :=
by rw [Ioi_succ, finset.prod_map, rel_embedding.coe_fn_to_embedding, coe_succ_embedding]

@[to_additive]
lemma prod_congr' {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin b → M) (h : a = b) :
  ∏ (i : fin a), f (cast h i) = ∏ (i : fin b), f i :=
by { subst h, congr, ext, congr, ext, rw coe_cast, }

@[to_additive]
lemma prod_univ_add {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin (a+b) → M) :
  ∏ (i : fin (a+b)), f i =
  (∏ (i : fin a), f (cast_add b i)) * ∏ (i : fin b), f (nat_add a i) :=
begin
  rw fintype.prod_equiv fin_sum_fin_equiv.symm f (λ i, f (fin_sum_fin_equiv.to_fun i)), swap,
  { intro x,
    simp only [equiv.to_fun_as_coe, equiv.apply_symm_apply], },
  apply fintype.prod_sum_type,
end

@[to_additive]
lemma prod_trunc {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin (a+b) → M)
  (hf : ∀ (j : fin b), f (nat_add a j) = 1) :
  ∏ (i : fin (a+b)), f i =
  ∏ (i : fin a), f (cast_le (nat.le.intro rfl) i) :=
by simpa only [prod_univ_add, fintype.prod_eq_one _ hf, mul_one]

section partial_prod

variables [monoid α] {n : ℕ}

/-- For `f = (a₁, ..., aₙ)` in `αⁿ`, `partial_prod f` is `(1, a₁, a₁a₂, ..., a₁...aₙ)` in `αⁿ⁺¹`. -/
@[to_additive "For `f = (a₁, ..., aₙ)` in `αⁿ`, `partial_sum f` is
`(0, a₁, a₁ + a₂, ..., a₁ + ... + aₙ)` in `αⁿ⁺¹`."]
def partial_prod (f : fin n → α) (i : fin (n + 1)) : α :=
((list.of_fn f).take i).prod

@[simp, to_additive] lemma partial_prod_zero (f : fin n → α) :
  partial_prod f 0 = 1 :=
by simp [partial_prod]

@[to_additive] lemma partial_prod_succ (f : fin n → α) (j : fin n) :
  partial_prod f j.succ = partial_prod f j.cast_succ * (f j) :=
by simp [partial_prod, list.take_succ, list.of_fn_nth_val, dif_pos j.is_lt, ←option.coe_def]

@[to_additive] lemma partial_prod_succ' (f : fin (n + 1) → α) (j : fin (n + 1)) :
  partial_prod f j.succ = f 0 * partial_prod (fin.tail f) j :=
by simpa [partial_prod]

@[to_additive] lemma partial_prod_left_inv {G : Type*} [group G] (f : fin (n + 1) → G) :
  f 0 • partial_prod (λ i : fin n, (f i)⁻¹ * f i.succ) = f :=
funext $ λ x, fin.induction_on x (by simp) (λ x hx,
begin
  simp only [coe_eq_cast_succ, pi.smul_apply, smul_eq_mul] at hx ⊢,
  rw [partial_prod_succ, ←mul_assoc, hx, mul_inv_cancel_left],
end)

@[to_additive] lemma partial_prod_right_inv {G : Type*} [group G]
  (g : G) (f : fin n → G) (i : fin n) :
  ((g • partial_prod f) i)⁻¹ * (g • partial_prod f) i.succ = f i :=
begin
  cases i with i hn,
  induction i with i hi generalizing hn,
  { simp [←fin.succ_mk, partial_prod_succ] },
  { specialize hi (lt_trans (nat.lt_succ_self i) hn),
    simp only [mul_inv_rev, fin.coe_eq_cast_succ, fin.succ_mk, fin.cast_succ_mk,
      smul_eq_mul, pi.smul_apply] at hi ⊢,
    rw [←fin.succ_mk _ _ (lt_trans (nat.lt_succ_self _) hn), ←fin.succ_mk],
    simp only [partial_prod_succ, mul_inv_rev, fin.cast_succ_mk],
    assoc_rw [hi, inv_mul_cancel_left] }
end

end partial_prod

end fin

namespace list

section comm_monoid

variables [comm_monoid α]

@[to_additive]
lemma prod_take_of_fn {n : ℕ} (f : fin n → α) (i : ℕ) :
  ((of_fn f).take i).prod = ∏ j in finset.univ.filter (λ (j : fin n), j.val < i), f j :=
begin
  have A : ∀ (j : fin n), ¬ ((j : ℕ) < 0) := λ j, not_lt_bot,
  induction i with i IH, { simp [A] },
  by_cases h : i < n,
  { have : i < length (of_fn f), by rwa [length_of_fn f],
    rw prod_take_succ _ _ this,
    have A : ((finset.univ : finset (fin n)).filter (λ j, j.val < i + 1))
      = ((finset.univ : finset (fin n)).filter (λ j, j.val < i)) ∪ {(⟨i, h⟩ : fin n)},
        by { ext ⟨_, _⟩, simp [nat.lt_succ_iff_lt_or_eq] },
    have B : _root_.disjoint (finset.filter (λ (j : fin n), j.val < i) finset.univ)
      (singleton (⟨i, h⟩ : fin n)), by simp,
    rw [A, finset.prod_union B, IH],
    simp },
  { have A : (of_fn f).take i = (of_fn f).take i.succ,
    { rw ← length_of_fn f at h,
      have : length (of_fn f) ≤ i := not_lt.mp h,
      rw [take_all_of_le this, take_all_of_le (le_trans this (nat.le_succ _))] },
    have B : ∀ (j : fin n), ((j : ℕ) < i.succ) = ((j : ℕ) < i),
    { assume j,
      have : (j : ℕ) < i := lt_of_lt_of_le j.2 (not_lt.mp h),
      simp [this, lt_trans this (nat.lt_succ_self _)] },
    simp [← A, B, IH] }
end

@[to_additive]
lemma prod_of_fn {n : ℕ} {f : fin n → α} :
  (of_fn f).prod = ∏ i, f i :=
begin
  convert prod_take_of_fn f n,
  { rw [take_all_of_le (le_of_eq (length_of_fn f))] },
  { have : ∀ (j : fin n), (j : ℕ) < n := λ j, j.is_lt,
    simp [this] }
end

end comm_monoid

lemma alternating_sum_eq_finset_sum {G : Type*} [add_comm_group G] :
  ∀ (L : list G), alternating_sum L = ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.is_lt
| [] := by { rw [alternating_sum, finset.sum_eq_zero], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) := by simp
| (g :: h :: L) :=
calc g + -h + L.alternating_sum
    = g + -h + ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.2 :
      congr_arg _ (alternating_sum_eq_finset_sum _)
... = ∑ i : fin (L.length + 2), (-1 : ℤ) ^ (i : ℕ) • list.nth_le (g :: h :: L) i _ :
begin
  rw [fin.sum_univ_succ, fin.sum_univ_succ, add_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

@[to_additive]
lemma alternating_prod_eq_finset_prod {G : Type*} [comm_group G] :
  ∀ (L : list G), alternating_prod L = ∏ i : fin L.length, (L.nth_le i i.2) ^ ((-1 : ℤ) ^ (i : ℕ))
| [] := by { rw [alternating_prod, finset.prod_eq_one], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) :=
begin
  show g = ∏ i : fin 1, [g].nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ),
  rw [fin.prod_univ_succ], simp,
end
| (g :: h :: L) :=
calc g * h⁻¹ * L.alternating_prod
    = g * h⁻¹ * ∏ i : fin L.length, L.nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ) :
      congr_arg _ (alternating_prod_eq_finset_prod _)
... = ∏ i : fin (L.length + 2), list.nth_le (g :: h :: L) i _ ^ (-1 : ℤ) ^ (i : ℕ) :
begin
  rw [fin.prod_univ_succ, fin.prod_univ_succ, mul_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

end list


import data.set
import tactic
import logics
import definitions
import structures

local attribute [instance] classical.prop_decidable

--------------------------------
-- Commentaire deaduc : lignes à récupérer pour structurer la liste d'exercices
-- pendant les exos qui suivent, le logiciel affichera en titre :
-- Théorie des ensembles (1) Ensembles
-- Puis, plus loin,
-- Théorie des ensembles (2) Applications

section theorie_des_ensembles

-- Commentaire deaduc : les deux lignes qui suivent indiquent les boutons à intégrer dans les zones correspondantes
-- pour tous les exercices de la section
-- @DEFINITIONS theorie_des_ensembles
-- (inclure toutes les définitions de la section "théorie des ensemble",
-- i.e. celles dont le nom commence par "definitions.theorie_des_ensembles")
-- @LOGIQUE ∀, ∃, →, ↔, ET, OU, NON, contradiction

-----------------------------------------
-----------------------------------------
section unions_et_intersections  -- sous-section 1
-----------------------------------------
-----------------------------------------

variables {X : Type} {A B C : set X}

/- @EXERCICE : L'intersection est distributive par rapport à l'union -/
lemma union_distributive_inter : A ∩ (B ∪ C)  = (A ∩ B) ∪ (A ∩ C) :=
begin
    defi double_inclusion, ET,
    defi inclusion, qqs a, implique,
    defi intersection_deux at H,
    ET H,
    defi union at HB,
    OU HB,
      defi union, OU gauche,
      ET HA HA_1,
      defi intersection_deux at H,
      assumption,
    defi union, OU droite,
    defi intersection_deux, ET, assumption, assumption,
  defi inclusion, qqs a, implique,
  defi union at H,
  OU H,
    defi intersection_deux at HA,
    ET HA,
    OUd HB a ∈ C,  -- évitable en travaillant sur le but
    defi union at H,
    ET HA_1 H,
  defi intersection_deux at H_1,
  assumption,
  defi intersection_deux at HB,
  ET HB,
  defi intersection_deux,
  ET,
  assumption,
  defi union,
  tautology,
end

/- @EXERCICE L'union est distributive par rapport à l'intersection -/
lemma inter_distributive_union : A ∪ (B ∩ C)  = (A ∪ B) ∩ (A ∪ C) :=
begin
    sorry
end

end unions_et_intersections

-----------------------------------------
-----------------------------------------
section complementaire -- sous-section 2
-----------------------------------------
-----------------------------------------
variables {X : Type} {A B : set X}
variables {I : Type} {E F : I → set X}
-- notation X `\` A := @has_neg.neg (set X) _ A
-- notation  ` \` Z := has_neg.neg Z
-- notation `\ ` Z := -Z

/- @EXERCICE Tout ensemble est égal au complémentaire de son complémentaire-/
lemma complement_complement : - - A =A :=
begin
    sorry
end

/- @EXERCICE Le complémentaire de l'union de deux ensembles égale l'intersection des complémentaires -/
lemma complement_union_deux : @has_neg.neg (set X) _ (A ∪ B) = (- A) ∩ (- B) :=
begin
    hypo_analysis,
    goals_analysis,
    sorry
end

/- @EXERCICE Le complémentaire d'une réunion quelconque égale l'intersection des complémentaires -/
open set
-- set_option pp.all true
lemma complement_union_quelconque  (H : ∀ i, F i = - E i) : - (Union E) = Inter F :=

begin
    hypo_analysis,
    goals_analysis,
    sorry
end

/- @EXERCICE Le complémentaire d'une intersection quelconque égale l'union des complémentaires -/
-- set_option pp.all true
lemma complement_intersection_quelconque  (H : ∀ i, F i = - E i) : - (Inter E) = Union F :=
begin
    sorry
end
/- @EXERCICE Le complémentaire du vide est X ??? -/

/- @EXERCICE A est inclus dans B ssi le complémentaire de A contient le complémentaire de B -/
lemma inclus_ssi_complement_contient : A ⊆ B ↔ - B ⊆ - A :=
begin
    hypo_analysis,
    goals_analysis,
    defi double_implication,    ET,
        implique,
        defi inclusion, qqs a, implique,
        defi complement,
        by_contradiction,
        -- alternative : defi inclusion at H, qqselim H a, impliqueelim H_2 a_1,
        applique H a_1,
        -- alternative : tautology, -- le contexte contient P et non P
        applique H_1 H_2, assumption,
    implique,
    defi inclusion, qqs a, implique,
    by_contradiction,
    applique H a_1,
    applique H_2 H_1, assumption,
    -- alternative :  defi inclusion at H, qqselim H a, impliqueelim H_3 H_2,
    -- tautology -- a remplacer : trop puissant !
end

/- -/
example : A ⊆ B ↔ B - A = ∅ :=
begin
    hypo_analysis,
    goals_analysis,
    sorry
end

-- Comment manipuler l'ensemble vide dans un type ?

/- Autres : différence symétrique-/

end complementaire

-- Ajouter : 3. produit cartésien, 4. relations ?
-- comment définit-on un produit cartésien d'ensembles ?

-----------------------------------------
-----------------------------------------
section applications  -- sous-section 5
-----------------------------------------
-----------------------------------------
notation f `⟮` A `⟯` := f '' A
notation f `⁻¹⟮` A `⟯` := f  ⁻¹' A

variables {X : Type} (A A': set X)
variables {Y: Type} {f: X → Y} (B B': set Y)
variables {I : Type} {E : I → set X} {F : I → set Y}

/- @EXERCICE -/
lemma image_de_reciproque : f '' (f ⁻¹' B)  ⊆ B :=
begin
    hypo_analysis,
    goals_analysis,
    sorry
end

/- @EXERCICE -/
lemma reciproque_de_image : A ⊆ f ⁻¹' (f '' A) :=
begin
    sorry
end

/- @EXERCICE -/
lemma image_reciproque_inter :  f ⁻¹'  (B∩B') = f ⁻¹'  (B) ∩ f ⁻¹'  (B') :=
begin
    sorry
end

/- @EXERCICE -/
lemma  image_reciproque_union  : f ⁻¹' (B ∪ B') = f ⁻¹' B ∪ f ⁻¹' B'  :=
begin
    defi double_inclusion,
    ET,
        defi inclusion,
        qqs x,
        implique,
        defi image_reciproque at H,
        defi union,
        defi union at H,
        OU H,
        defi image_reciproque at HA,
        OUd HA (f x ∈ B),
            OU gauche, assumption,
        OU droite, assumption,
-- ici assumption en fait un peu trop,
-- on voudrait obliger à avoir appliqué la def de l'image réciproque avant
    defi inclusion,
    qqs x,
    implique,
    defi image_reciproque,
    defi union,
    defi union at H,
    OU H,
        OU gauche, assumption,
    OU droite, assumption,
end

/- Idem union, intersection quelconques -/

/- @EXERCICE -/
lemma image_reciproque_inter_quelconque  (H : ∀ i:I,  (E i = f ⁻¹' (F i))) :  (f ⁻¹'  (set.Inter F)) = set.Inter E :=
begin
    defi double_inclusion, ET,
    {defi inclusion, qqs x,
    implique,
    defi image_reciproque at H_1,
    defi intersection_quelconque at H_1,
    defi intersection_quelconque,
    qqs i,
    applique H_1 i,
    defi image_reciproque at H_2,
    applique H i,
    rw ← H_3 at H_2,
    assumption},
    {

    }
end

/- @EXERCICE -/
lemma image_inter_inclus_inter_images   :
        f '' (A∩A') ⊆ f '' (A) ∩ f '' (A') :=
begin
    -- Soit b un élément de  f(A'∩A)
    defi inclusion,
    qqsintro b,
    impliqueintro,
    -- ligne non indispensable :
    defi image at H,
    hypo_analysis,
    goals_analysis,
    existeelim a H, ET H,
    defi intersection_deux at HA, ET HA,
    defi intersection_deux, ET,
    defi image,
    existeintro a, ET,
    assumption, assumption,
    existeintro a, ET,
    assumption, assumption,
end

end applications

end theorie_des_ensembles


import Mathlib.Data.List.Sort
import Mathlib.Tactic.Linarith

section timedSort

universe u

variable {α : Type u} (r : α → α → Prop) [DecidableRel r]
local infixl:50 " ≼ " => r

@[simp] def orderedInsert (a : α) : List α → (List α × Nat)
  | []      => ([a], 0)
  | b :: l => if a ≼ b then (a :: b :: l, 1)
              else let (l', n) := orderedInsert a l
                   (b :: l', n + 1)

#eval orderedInsert (· ≤ ·) 2 [5, 3, 1, 4]
-- ([2, 5, 3, 1, 4], 1)

#eval orderedInsert (· ≤ ·) 9 [1, 0, 8]
-- ([1, 0, 8, 9], 3)

@[simp] def insertionSort : List α → (List α × Nat)
  | [] => ([], 0)
  | (h :: t) => let (l', n)  := insertionSort t
                let (l'', m) := orderedInsert r h l'
                (l'', n + m)

#eval insertionSort (· ≤ ·) [1, 2, 3, 4, 5]
-- ([1, 2, 3, 4, 5], 4)

#eval insertionSort (· ≤ ·) [5, 4, 3, 2, 1]
-- ([1, 2, 3, 4, 5], 10)

theorem orderedInsert_complexity (a : α) :
  ∀ l : List α, (orderedInsert r a l).snd ≤ l.length := fun l =>
  match l with
  | []     => by simp
  | b :: l' => by
    simp
    split_ifs with h
    { simp; apply Nat.succ_le_succ; exact Nat.zero_le (List.length l') }
    simp
    have ih := orderedInsert_complexity a l'
    exact Nat.add_le_add ih le_rfl

theorem orderedInsert_equivalence (a : α) : ∀ l : List α,
  (orderedInsert r a l).fst = List.orderedInsert r a l := fun l =>
  match l with
  | [] => by simp
  | b :: l' => by
    simp
    split_ifs with h
    { rfl }
    simp
    exact orderedInsert_equivalence a l'

theorem orderedInsert_increases_length (a : α) : ∀ l : List α,
  (orderedInsert r a l).fst.length = l.length + 1 := fun l =>
  match l with
  | [] => by simp
  | b :: l' => by
    simp
    split_ifs with h
    { rfl }
    simp
    exact orderedInsert_increases_length a l'

theorem insertionSort_preserves_length : ∀ l : List α,
  (insertionSort r l).fst.length = l.length := fun l =>
  match l with
  | [] => by simp
  | a :: l' => by
    simp
    rw [orderedInsert_increases_length r a (insertionSort r l').fst]
    simp
    exact insertionSort_preserves_length l'

#check add_le_add

theorem insertionSort_complexity :
  ∀ l : List α, (insertionSort r l).snd ≤ l.length * l.length := fun l =>
  match l with
  | [] => by simp
  | a :: l' => by
    simp
    have same_lengths := insertionSort_preserves_length r l'
    have mid :
      (insertionSort r l').snd + (orderedInsert r a (insertionSort r l').fst).snd ≤
      l'.length * l'.length + (orderedInsert r a (insertionSort r l').fst).snd :=
        add_le_add (insertionSort_complexity l') le_rfl
    have mid₂ :
      l'.length * l'.length + (orderedInsert r a (insertionSort r l').fst).snd ≤
      l'.length * l'.length + l'.length := by
        apply add_le_add le_rfl
        have orderedInsert_compl :=
          orderedInsert_complexity r a (insertionSort r l').fst
        rw [same_lengths] at orderedInsert_compl
        exact orderedInsert_compl
    apply le_trans mid
    apply le_trans mid₂
    linarith

theorem insertionSort_equivalence : ∀ l : List α,
  (insertionSort r l).fst = List.insertionSort r l := fun l =>
  match l with
  | [] => by simp
  | a :: l' => by
    simp
    rw [orderedInsert_equivalence, insertionSort_equivalence l']

end timedSort


import GMLInit.Data.Nat.Basic

namespace Nat

class IsPos (n : Nat) : Prop where
  protected is_pos : n > 0

def is_pos (n : Nat) [self : IsPos n] : n > 0 := self.is_pos

def is_nonzero (n : Nat) [IsPos n] : n ≠ 0 := (Nat.ne_of_lt (is_pos n)).symm

namespace IsPos

instance (n : Nat) : IsPos (Nat.succ n) where
  is_pos := Nat.succ_pos n

instance (m n : Nat) [IsPos m] : IsPos (m + n) where
  is_pos := Nat.lt_of_lt_of_le (is_pos m) (Nat.le_add_right m n)

instance (m n : Nat) [IsPos n] : IsPos (m + n) where
  is_pos := Nat.lt_of_lt_of_le (is_pos n) (Nat.le_add_left n m)

instance (m n : Nat) [IsPos m] [IsPos n] : IsPos (m * n) where
  is_pos := Nat.mul_pos (is_pos m) (is_pos n)

instance (n : Nat) : IsPos (n ^ 0) where
  is_pos := is_pos 1

instance (m n : Nat) [IsPos m] : IsPos (m ^ n) where
  is_pos := Nat.pos_pow_of_pos n (is_pos m)

end IsPos

theorem pos_of_nonzero {n : Nat} : n ≠ 0 → n > 0 := by
  cases n with
  | zero => intro; contradiction
  | succ n => intro; exact is_pos _

macro "nat_is_pos" : tactic => `(tactic| (show ((_ : Nat) > 0); first | assumption | exact Nat.is_pos _))

macro "nat_is_nonzero" : tactic => `(tactic| (show ((_ : Nat) ≠ 0); first | assumption | symmetry; assumption | exact Nat.is_nonzero _))

protected theorem pred_lt_self (n : Nat) (h : n > 0 := by nat_is_pos) : n.pred < n := by
  cases n with
  | zero => contradiction
  | succ _ => exact Nat.lt_succ_self ..

end Nat


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.fintype.basic
import group_theory.subgroup.basic

/-!
# Free groups

This file defines free groups over a type. Furthermore, it is shown that the free group construction
is an instance of a monad. For the result that `free_group` is the left adjoint to the forgetful
functor from groups to types, see `algebra/category/Group/adjunctions`.

## Main definitions

* `free_group`: the free group associated to a type `α` defined as the words over `a : α × bool `
  modulo the relation `a * x * x⁻¹ * b = a * b`.
* `mk`: the canonical quotient map `list (α × bool) → free_group α`.
* `of`: the canoical injection `α → free_group α`.
* `lift f`: the canonical group homomorphism `free_group α →* G` given a group `G` and a
  function `f : α → G`.

## Main statements

* `church_rosser`: The Church-Rosser theorem for word reduction (also known as Newman's diamond
  lemma).
* `free_group_unit_equiv_int`: The free group over the one-point type is isomorphic to the integers.
* The free group construction is an instance of a monad.

## Implementation details

First we introduce the one step reduction relation `free_group.red.step`:
`w * x * x⁻¹ * v   ~>   w * v`, its reflexive transitive closure `free_group.red.trans`
and prove that its join is an equivalence relation. Then we introduce `free_group α` as a quotient
over `free_group.red.step`.

## Tags

free group, Newman's diamond lemma, Church-Rosser theorem
-/

open relation

universes u v w

variables {α : Type u}

local attribute [simp] list.append_eq_has_append

namespace free_group
variables {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- Reduction step: `w * x * x⁻¹ * v ~> w * v` -/
inductive red.step : list (α × bool) → list (α × bool) → Prop
| bnot {L₁ L₂ x b} : red.step (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂)
attribute [simp] red.step.bnot

/-- Reflexive-transitive closure of red.step -/
def red : list (α × bool) → list (α × bool) → Prop := refl_trans_gen red.step

@[refl] lemma red.refl : red L L := refl_trans_gen.refl
@[trans] lemma red.trans : red L₁ L₂ → red L₂ L₃ → red L₁ L₃ := refl_trans_gen.trans

namespace red

/-- Predicate asserting that word `w₁` can be reduced to `w₂` in one step, i.e. there are words
`w₃ w₄` and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
theorem step.length : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.length + 2 = L₁.length
| _ _ (@red.step.bnot _ L1 L2 x b) := by rw [list.length_append, list.length_append]; refl

@[simp] lemma step.bnot_rev {x b} : step (L₁ ++ (x, bnot b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
by cases b; from step.bnot

@[simp] lemma step.cons_bnot {x b} : red.step ((x, b) :: (x, bnot b) :: L) L :=
@step.bnot _ [] _ _ _

@[simp] lemma step.cons_bnot_rev {x b} : red.step ((x, bnot b) :: (x, b) :: L) L :=
@red.step.bnot_rev _ [] _ _ _

theorem step.append_left : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₂ L₃ → step (L₁ ++ L₂) (L₁ ++ L₃)
| _ _ _ red.step.bnot := by rw [← list.append_assoc, ← list.append_assoc]; constructor

theorem step.cons {x} (H : red.step L₁ L₂) : red.step (x :: L₁) (x :: L₂) :=
@step.append_left _ [x] _ _ H

theorem step.append_right : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₁ L₂ → step (L₁ ++ L₃) (L₂ ++ L₃)
| _ _ _ red.step.bnot := by simp

lemma not_step_nil : ¬ step [] L :=
begin
  generalize h' : [] = L',
  assume h,
  cases h with L₁ L₂,
  simp [list.nil_eq_append_iff] at h',
  contradiction
end

lemma step.cons_left_iff {a : α} {b : bool} :
  step ((a, b) :: L₁) L₂ ↔ (∃L, step L₁ L ∧ L₂ = (a, b) :: L) ∨ (L₁ = (a, bnot b)::L₂) :=
begin
  split,
  { generalize hL : ((a, b) :: L₁ : list _) = L,
    assume h,
    rcases h with ⟨_ | ⟨p, s'⟩, e, a', b'⟩,
    { simp at hL, simp [*] },
    { simp at hL,
      rcases hL with ⟨rfl, rfl⟩,
      refine or.inl ⟨s' ++ e, step.bnot, _⟩,
      simp } },
  { assume h,
    rcases h with ⟨L, h, rfl⟩ | rfl,
    { exact step.cons h },
    { exact step.cons_bnot } }
end

lemma not_step_singleton : ∀ {p : α × bool}, ¬ step [p] L
| (a, b) := by simp [step.cons_left_iff, not_step_nil]

lemma step.cons_cons_iff : ∀{p : α × bool}, step (p :: L₁) (p :: L₂) ↔ step L₁ L₂ :=
by simp [step.cons_left_iff, iff_def, or_imp_distrib] {contextual := tt}

lemma step.append_left_iff : ∀L, step (L ++ L₁) (L ++ L₂) ↔ step L₁ L₂
| [] := by simp
| (p :: l) := by simp [step.append_left_iff l, step.cons_cons_iff]

private theorem step.diamond_aux : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)} {x1 b1 x2 b2},
  L₁ ++ (x1, b1) :: (x1, bnot b1) :: L₂ = L₃ ++ (x2, b2) :: (x2, bnot b2) :: L₄ →
  L₁ ++ L₂ = L₃ ++ L₄ ∨ ∃ L₅, red.step (L₁ ++ L₂) L₅ ∧ red.step (L₃ ++ L₄) L₅
| []        _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []        _ [(x3,b3)] _ _ _ _ _ H := by injections; subst_vars; simp
| [(x3,b3)] _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []                     _ ((x3,b3)::(x4,b4)::tl) _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.bnot, red.step.cons_bnot⟩
| ((x3,b3)::(x4,b4)::tl) _ []                     _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.cons_bnot, red.step.bnot⟩
| ((x3,b3)::tl) _ ((x4,b4)::tl2) _ _ _ _ _ H :=
  let ⟨H1, H2⟩ := list.cons.inj H in
  match step.diamond_aux H2 with
    | or.inl H3 := or.inl $ by simp [H1, H3]
    | or.inr ⟨L₅, H3, H4⟩ := or.inr
      ⟨_, step.cons H3, by simpa [H1] using step.cons H4⟩
  end

theorem step.diamond : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red.step L₁ L₃ → red.step L₂ L₄ → L₁ = L₂ →
  L₃ = L₄ ∨ ∃ L₅, red.step L₃ L₅ ∧ red.step L₄ L₅
| _ _ _ _ red.step.bnot red.step.bnot H := step.diamond_aux H

lemma step.to_red : step L₁ L₂ → red L₁ L₂ :=
refl_trans_gen.single

/-- **Church-Rosser theorem** for word reduction: If `w1 w2 w3` are words such that `w1` reduces
to `w2` and `w3` respectively, then there is a word `w4` such that `w2` and `w3` reduce to `w4`
respectively. This is also known as Newman's diamond lemma. -/
theorem church_rosser : red L₁ L₂ → red L₁ L₃ → join red L₂ L₃ :=
relation.church_rosser (assume a b c hab hac,
match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, hcd.to_red⟩
end)

lemma cons_cons {p} : red L₁ L₂ → red (p :: L₁) (p :: L₂) :=
refl_trans_gen.lift (list.cons p) (assume a b, step.cons)

lemma cons_cons_iff (p) : red (p :: L₁) (p :: L₂) ↔ red L₁ L₂ :=
iff.intro
  begin
    generalize eq₁ : (p :: L₁ : list _) = LL₁,
    generalize eq₂ : (p :: L₂ : list _) = LL₂,
    assume h,
    induction h using relation.refl_trans_gen.head_induction_on
      with L₁ L₂ h₁₂ h ih
      generalizing L₁ L₂,
    { subst_vars, cases eq₂, constructor },
    { subst_vars,
      cases p with a b,
      rw [step.cons_left_iff] at h₁₂,
      rcases h₁₂ with ⟨L, h₁₂, rfl⟩ | rfl,
      { exact (ih rfl rfl).head h₁₂ },
      { exact (cons_cons h).tail step.cons_bnot_rev } }
  end
  cons_cons

lemma append_append_left_iff : ∀L, red (L ++ L₁) (L ++ L₂) ↔ red L₁ L₂
| []       := iff.rfl
| (p :: L) := by simp [append_append_left_iff L, cons_cons_iff]

lemma append_append (h₁ : red L₁ L₃) (h₂ : red L₂ L₄) : red (L₁ ++ L₂) (L₃ ++ L₄) :=
(h₁.lift (λL, L ++ L₂) (assume a b, step.append_right)).trans ((append_append_left_iff _).2 h₂)

lemma to_append_iff : red L (L₁ ++ L₂) ↔ (∃L₃ L₄, L = L₃ ++ L₄ ∧ red L₃ L₁ ∧ red L₄ L₂) :=
iff.intro
  begin
    generalize eq : L₁ ++ L₂ = L₁₂,
    assume h,
    induction h with L' L₁₂ hLL' h ih generalizing L₁ L₂,
    { exact ⟨_, _, eq.symm, by refl, by refl⟩ },
    { cases h with s e a b,
      rcases list.append_eq_append_iff.1 eq with ⟨s', rfl, rfl⟩ | ⟨e', rfl, rfl⟩,
      { have : L₁ ++ (s' ++ ((a, b) :: (a, bnot b) :: e)) =
                 (L₁ ++ s') ++ ((a, b) :: (a, bnot b) :: e),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁, h₂.tail step.bnot⟩ },
      { have : (s ++ ((a, b) :: (a, bnot b) :: e')) ++ L₂ =
                 s ++ ((a, b) :: (a, bnot b) :: (e' ++ L₂)),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁.tail step.bnot, h₂⟩ }, }
  end
  (assume ⟨L₃, L₄, eq, h₃, h₄⟩, eq.symm ▸ append_append h₃ h₄)

/-- The empty word `[]` only reduces to itself. -/
theorem nil_iff : red [] L ↔ L = [] :=
refl_trans_gen_iff_eq (assume l, red.not_step_nil)

/-- A letter only reduces to itself. -/
theorem singleton_iff {x} : red [x] L₁ ↔ L₁ = [x] :=
refl_trans_gen_iff_eq (assume l, not_step_singleton)

/-- If `x` is a letter and `w` is a word such that `xw` reduces to the empty word, then `w` reduces
to `x⁻¹` -/
theorem cons_nil_iff_singleton {x b} : red ((x, b) :: L) [] ↔ red L [(x, bnot b)] :=
iff.intro
  (assume h,
    have h₁ : red ((x, bnot b) :: (x, b) :: L) [(x, bnot b)], from cons_cons h,
    have h₂ : red ((x, bnot b) :: (x, b) :: L) L, from refl_trans_gen.single step.cons_bnot_rev,
    let ⟨L', h₁, h₂⟩ := church_rosser h₁ h₂ in
    by rw [singleton_iff] at h₁; subst L'; assumption)
  (assume h, (cons_cons h).tail step.cons_bnot)

theorem red_iff_irreducible {x1 b1 x2 b2} (h : (x1, b1) ≠ (x2, b2)) :
  red [(x1, bnot b1), (x2, b2)] L ↔ L = [(x1, bnot b1), (x2, b2)] :=
begin
  apply refl_trans_gen_iff_eq,
  generalize eq : [(x1, bnot b1), (x2, b2)] = L',
  assume L h',
  cases h',
  simp [list.cons_eq_append_iff, list.nil_eq_append_iff] at eq,
  rcases eq with ⟨rfl, ⟨rfl, rfl⟩, ⟨rfl, rfl⟩, rfl⟩, subst_vars,
  simp at h,
  contradiction
end

/-- If `x` and `y` are distinct letters and `w₁ w₂` are words such that `xw₁` reduces to `yw₂`, then
`w₁` reduces to `x⁻¹yw₂`. -/
theorem inv_of_red_of_ne {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2))
  (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) :
  red L₁ ((x1, bnot b1) :: (x2, b2) :: L₂) :=
begin
  have : red ((x1, b1) :: L₁) ([(x2, b2)] ++ L₂), from H2,
  rcases to_append_iff.1 this with ⟨_ | ⟨p, L₃⟩, L₄, eq, h₁, h₂⟩,
  { simp [nil_iff] at h₁, contradiction },
  { cases eq,
    show red (L₃ ++ L₄) ([(x1, bnot b1), (x2, b2)] ++ L₂),
    apply append_append _ h₂,
    have h₁ : red ((x1, bnot b1) :: (x1, b1) :: L₃) [(x1, bnot b1), (x2, b2)],
    { exact cons_cons h₁ },
    have h₂ : red ((x1, bnot b1) :: (x1, b1) :: L₃) L₃,
    { exact step.cons_bnot_rev.to_red },
    rcases church_rosser h₁ h₂ with ⟨L', h₁, h₂⟩,
    rw [red_iff_irreducible H1] at h₁,
    rwa [h₁] at h₂ }
end

theorem step.sublist (H : red.step L₁ L₂) : L₂ <+ L₁ :=
by cases H; simp; constructor; constructor; refl

/-- If `w₁ w₂` are words such that `w₁` reduces to `w₂`, then `w₂` is a sublist of `w₁`. -/
theorem sublist : red L₁ L₂ → L₂ <+ L₁ :=
refl_trans_gen_of_transitive_reflexive
  (λl, list.sublist.refl l) (λa b c hab hbc, list.sublist.trans hbc hab) (λa b, red.step.sublist)

theorem sizeof_of_step : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.sizeof < L₁.sizeof
| _ _ (@step.bnot _ L1 L2 x b) :=
  begin
    induction L1 with hd tl ih,
    case list.nil
    { dsimp [list.sizeof],
      have H : 1 + sizeof (x, b) + (1 + sizeof (x, bnot b) + list.sizeof L2)
        = (list.sizeof L2 + 1) + (sizeof (x, b) + sizeof (x, bnot b) + 1),
      { ac_refl },
      rw H,
      exact nat.le_add_right _ _ },
    case list.cons
    { dsimp [list.sizeof],
      exact nat.add_lt_add_left ih _ }
  end

theorem length (h : red L₁ L₂) : ∃ n, L₁.length = L₂.length + 2 * n :=
begin
  induction h with L₂ L₃ h₁₂ h₂₃ ih,
  { exact ⟨0, rfl⟩ },
  { rcases ih with ⟨n, eq⟩,
    existsi (1 + n),
    simp [mul_add, eq, (step.length h₂₃).symm, add_assoc] }
end

theorem antisymm (h₁₂ : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ :=
match L₁, h₁₂.cases_head with
| _,  or.inl rfl            := assume h, rfl
| L₁, or.inr ⟨L₃, h₁₃, h₃₂⟩ := assume h₂₁,
  let ⟨n, eq⟩ := length (h₃₂.trans h₂₁) in
  have list.length L₃ + 0 = list.length L₃ + (2 * n + 2),
    by simpa [(step.length h₁₃).symm, add_comm, add_assoc] using eq,
  (nat.no_confusion $ nat.add_left_cancel this)
end

end red

theorem equivalence_join_red : equivalence (join (@red α)) :=
equivalence_join_refl_trans_gen $ assume a b c hab hac,
(match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, refl_trans_gen.single hcd⟩
end)

theorem join_red_of_step (h : red.step L₁ L₂) : join red L₁ L₂ :=
join_of_single reflexive_refl_trans_gen h.to_red

theorem eqv_gen_step_iff_join_red : eqv_gen red.step L₁ L₂ ↔ join red L₁ L₂ :=
iff.intro
  (assume h,
    have eqv_gen (join red) L₁ L₂ := h.mono (assume a b, join_red_of_step),
    equivalence_join_red.eqv_gen_iff.1 this)
  (join_of_equivalence (eqv_gen.is_equivalence _) $ assume a b,
    refl_trans_gen_of_equivalence (eqv_gen.is_equivalence _) eqv_gen.rel)

end free_group

/-- The free group over a type, i.e. the words formed by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group (α : Type u) : Type u :=
quot $ @free_group.red.step α

namespace free_group

variables {α} {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- The canonical map from `list (α × bool)` to the free group on `α`. -/
def mk (L) : free_group α := quot.mk red.step L

@[simp] lemma quot_mk_eq_mk : quot.mk red.step L = mk L := rfl

@[simp] lemma quot_lift_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift f H (mk L) = f L := rfl

@[simp] lemma quot_lift_on_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift_on (mk L) f H = f L := rfl

instance : has_one (free_group α) := ⟨mk []⟩
lemma one_eq_mk : (1 : free_group α) = mk [] := rfl

instance : inhabited (free_group α) := ⟨1⟩

instance : has_mul (free_group α) :=
⟨λ x y, quot.lift_on x
    (λ L₁, quot.lift_on y (λ L₂, mk $ L₁ ++ L₂) (λ L₂ L₃ H, quot.sound $ red.step.append_left H))
    (λ L₁ L₂ H, quot.induction_on y $ λ L₃, quot.sound $ red.step.append_right H)⟩
@[simp] lemma mul_mk : mk L₁ * mk L₂ = mk (L₁ ++ L₂) := rfl

instance : has_inv (free_group α) :=
⟨λx, quot.lift_on x (λ L, mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse)
  (assume a b h, quot.sound $ by cases h; simp)⟩
@[simp] lemma inv_mk : (mk L)⁻¹ = mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse := rfl

instance : group (free_group α) :=
{ mul := (*),
  one := 1,
  inv := has_inv.inv,
  mul_assoc := by rintros ⟨L₁⟩ ⟨L₂⟩ ⟨L₃⟩; simp,
  one_mul := by rintros ⟨L⟩; refl,
  mul_one := by rintros ⟨L⟩; simp [one_eq_mk],
  mul_left_inv := by rintros ⟨L⟩; exact (list.rec_on L rfl $
    λ ⟨x, b⟩ tl ih, eq.trans (quot.sound $ by simp [one_eq_mk]) ih) }

/-- `of` is the canonical injection from the type to the free group over that type by sending each
element to the equivalence class of the letter that is the element. -/
def of (x : α) : free_group α :=
mk [(x, tt)]

theorem red.exact : mk L₁ = mk L₂ ↔ join red L₁ L₂ :=
calc (mk L₁ = mk L₂) ↔ eqv_gen red.step L₁ L₂ : iff.intro (quot.exact _) quot.eqv_gen_sound
  ... ↔ join red L₁ L₂ : eqv_gen_step_iff_join_red

/-- The canonical injection from the type to the free group is an injection. -/
theorem of_injective : function.injective (@of α) :=
λ _ _ H, let ⟨L₁, hx, hy⟩ := red.exact.1 H in
  by simp [red.singleton_iff] at hx hy; cc

section lift

variables {β : Type v} [group β] (f : α → β) {x y : free_group α}

/-- Given `f : α → β` with `β` a group, the canonical map `list (α × bool) → β` -/
def lift.aux : list (α × bool) → β :=
λ L, list.prod $ L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹

theorem red.step.lift {f : α → β} (H : red.step L₁ L₂) :
  lift.aux f L₁ = lift.aux f L₂ :=
by cases H with _ _ _ b; cases b; simp [lift.aux]

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
@[simps symm_apply]
def lift : (α → β) ≃ (free_group α →* β) :=
{ to_fun := λ f,
    monoid_hom.mk' (quot.lift (lift.aux f) $ λ L₁ L₂, red.step.lift) $ begin
      rintros ⟨L₁⟩ ⟨L₂⟩, simp [lift.aux],
    end,
  inv_fun := λ g, g ∘ of,
  left_inv := λ f, one_mul _,
  right_inv := λ g, monoid_hom.ext $ begin
    rintros ⟨L⟩,
    apply list.rec_on L,
    { exact g.map_one.symm, },
    { rintros ⟨x, _ | _⟩ t (ih : _ = g (mk t)),
      { show _ = g ((of x)⁻¹ * mk t),
        simpa [lift.aux] using ih },
      { show _ = g (of x * mk t),
        simpa [lift.aux] using ih }, },
  end }
variable {f}

@[simp] lemma lift.mk : lift f (mk L) =
  list.prod (L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹) :=
rfl

@[simp] lemma lift.of {x} : lift f (of x) = f x :=
one_mul _

theorem lift.unique (g : free_group α →* β)
  (hg : ∀ x, g (of x) = f x) : ∀{x}, g x = lift f x :=
monoid_hom.congr_fun $ (lift.symm_apply_eq).mp (funext hg : g ∘ of = f)

/-- Two homomorphisms out of a free group are equal if they are equal on generators.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma ext_hom {G : Type*} [group G] (f g : free_group α →* G) (h : ∀ a, f (of a) = g (of a)) :
  f = g :=
lift.symm.injective $ funext h

theorem lift.of_eq (x : free_group α) : lift of x = x :=
monoid_hom.congr_fun (lift.apply_symm_apply (monoid_hom.id _)) x

theorem lift.range_subset {s : subgroup β} (H : set.range f ⊆ s) :
  set.range (lift f) ⊆ s :=
by rintros _ ⟨⟨L⟩, rfl⟩; exact list.rec_on L s.one_mem
(λ ⟨x, b⟩ tl ih, bool.rec_on b
    (by simp at ih ⊢; from s.mul_mem
      (s.inv_mem $ H ⟨x, rfl⟩) ih)
    (by simp at ih ⊢; from s.mul_mem (H ⟨x, rfl⟩) ih))

theorem closure_subset {G : Type*} [group G] {s : set G} {t : subgroup G}
  (h : s ⊆ t) : subgroup.closure s ≤ t :=
begin
  simp only [h, subgroup.closure_le],
end

theorem lift.range_eq_closure :
  set.range (lift f) = subgroup.closure (set.range f) :=
set.subset.antisymm
  (lift.range_subset subgroup.subset_closure)
  begin
    suffices : (subgroup.closure (set.range f)) ≤ monoid_hom.range (lift f),
      simpa,
    rw subgroup.closure_le,
    rintros y ⟨x, hx⟩,
    exact ⟨of x, by simpa⟩
  end

end lift

section map

variables {β : Type v} (f : α → β) {x y : free_group α}

/-- Given `f : α → β`, the canonical map `list (α × bool) → list (β × bool)`. -/
def map.aux (L : list (α × bool)) : list (β × bool) :=
L.map $ λ x, (f x.1, x.2)

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
over `α` to the free group over `β`. Note that this is the bare function;
for the group homomorphism use `map`. -/
def map.to_fun (x : free_group α) : free_group β :=
x.lift_on (λ L, mk $ map.aux f L) $
λ L₁ L₂ H, quot.sound $ by cases H; simp [map.aux]

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map : free_group α →* free_group β := monoid_hom.mk' (map.to_fun f)
begin
  rintros ⟨L₁⟩ ⟨L₂⟩,
  simp [map.to_fun, map.aux]
end

--by rintros ⟨L₁⟩ ⟨L₂⟩; simp [map, map.aux]

variable {f}

@[simp] lemma map.mk : map f (mk L) = mk (L.map (λ x, (f x.1, x.2))) :=
rfl

@[simp] lemma map.id : map id x = x :=
have H1 : (λ (x : α × bool), x) = id := rfl,
by rcases x with ⟨L⟩; simp [H1]

@[simp] lemma map.id' : map (λ z, z) x = x := map.id

theorem map.comp {γ : Type w} {f : α → β} {g : β → γ} {x} :
  map g (map f x) = map (g ∘ f) x :=
by rcases x with ⟨L⟩; simp

@[simp] lemma map.of {x} : map f (of x) = of (f x) := rfl

theorem map.unique (g : free_group α →* free_group β)
  (hg : ∀ x, g (of x) = of (f x)) : ∀{x}, g x = map f x :=
by rintros ⟨L⟩; exact list.rec_on L g.map_one
(λ ⟨x, b⟩ t (ih : g (mk t) = map f (mk t)), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = map f ((of x)⁻¹ * mk t),
     by simp [g.map_mul, g.map_inv, hg, ih])
  (show g (of x * mk t) = map f (of x * mk t),
     by simp [g.map_mul, hg, ih]))

/-- Equivalent types give rise to equivalent free groups. -/
def free_group_congr {α β} (e : α ≃ β) : free_group α ≃ free_group β :=
⟨map e, map e.symm,
 λ x, by simp [function.comp, map.comp],
 λ x, by simp [function.comp, map.comp]⟩

theorem map_eq_lift : map f x = lift (of ∘ f) x :=
eq.symm $ map.unique _ $ λ x, by simp

end map

section prod

variables [group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod : free_group α →* α := lift id

variables {x y}

@[simp] lemma prod_mk :
  prod (mk L) = list.prod (L.map $ λ x, cond x.2 x.1 x.1⁻¹) :=
rfl

@[simp] lemma prod.of {x : α} : prod (of x) = x :=
lift.of

lemma prod.unique (g : free_group α →* α)
  (hg : ∀ x, g (of x) = x) {x} :
  g x = prod x :=
lift.unique g hg

end prod

theorem lift_eq_prod_map {β : Type v} [group β] {f : α → β} {x} :
  lift f x = prod (map f x) :=
begin
  rw ←lift.unique (prod.comp (map f)),
  { refl },
  { simp }
end

section sum

variables [add_group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum : α :=
@prod (multiplicative _) _ x

variables {x y}

@[simp] lemma sum_mk :
  sum (mk L) = list.sum (L.map $ λ x, cond x.2 x.1 (-x.1)) :=
rfl

@[simp] lemma sum.of {x : α} : sum (of x) = x :=
prod.of

-- note: there are no bundled homs with different notation in the domain and codomain, so we copy
-- these manually
@[simp] lemma sum.map_mul : sum (x * y) = sum x + sum y :=
(@prod (multiplicative _) _).map_mul _ _

@[simp] lemma sum.map_one : sum (1:free_group α) = 0 :=
(@prod (multiplicative _) _).map_one

@[simp] lemma sum.map_inv : sum x⁻¹ = -sum x :=
(@prod (multiplicative _) _).map_inv _

end sum

/-- The bijection between the free group on the empty type, and a type with one element. -/
def free_group_empty_equiv_unit : free_group empty ≃ unit :=
{ to_fun    := λ _, (),
  inv_fun   := λ _, 1,
  left_inv  := by rintros ⟨_ | ⟨⟨⟨⟩, _⟩, _⟩⟩; refl,
  right_inv := λ ⟨⟩, rfl }

/-- The bijection between the free group on a singleton, and the integers. -/
def free_group_unit_equiv_int : free_group unit ≃ ℤ :=
{ to_fun    := λ x,
   sum begin revert x, apply monoid_hom.to_fun,
    apply map (λ _, (1 : ℤ)),
  end,
  inv_fun   := λ x, of () ^ x,
  left_inv  :=
  begin
    rintros ⟨L⟩,
    refine list.rec_on L rfl _,
    exact (λ ⟨⟨⟩, b⟩ tl ih, by cases b; simp [zpow_add] at ih ⊢; rw ih; refl),
  end,
  right_inv :=
    λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [zpow_add, ih])
    (λ i ih, by simp at ih; simp [zpow_add, ih, sub_eq_add_neg, -int.add_neg_one]) }

section category

variables {β : Type u}

instance : monad free_group.{u} :=
{ pure := λ α, of,
  map := λ α β f, (map f),
  bind := λ α β x f, lift f x }

@[elab_as_eliminator]
protected theorem induction_on
  {C : free_group α → Prop}
  (z : free_group α)
  (C1 : C 1)
  (Cp : ∀ x, C $ pure x)
  (Ci : ∀ x, C (pure x) → C (pure x)⁻¹)
  (Cm : ∀ x y, C x → C y → C (x * y)) : C z :=
quot.induction_on z $ λ L, list.rec_on L C1 $ λ ⟨x, b⟩ tl ih,
bool.rec_on b (Cm _ _ (Ci _ $ Cp x) ih) (Cm _ _ (Cp x) ih)

@[simp] lemma map_pure (f : α → β) (x : α) : f <$> (pure x : free_group α) = pure (f x) :=
map.of

@[simp] lemma map_one (f : α → β) : f <$> (1 : free_group α) = 1 :=
(map f).map_one

@[simp] lemma map_mul (f : α → β) (x y : free_group α) : f <$> (x * y) = f <$> x * f <$> y :=
(map f).map_mul x y

@[simp] lemma map_inv (f : α → β) (x : free_group α) : f <$> (x⁻¹) = (f <$> x)⁻¹ :=
(map f).map_inv x

@[simp] lemma pure_bind (f : α → free_group β) (x) : pure x >>= f = f x :=
lift.of

@[simp] lemma one_bind (f : α → free_group β) : 1 >>= f = 1 :=
(lift f).map_one

@[simp] lemma mul_bind (f : α → free_group β) (x y : free_group α) :
  x * y >>= f = (x >>= f) * (y >>= f) :=
(lift f).map_mul _ _

@[simp] lemma inv_bind (f : α → free_group β) (x : free_group α) : x⁻¹ >>= f = (x >>= f)⁻¹ :=
(lift f).map_inv _

instance : is_lawful_monad free_group.{u} :=
{ id_map := λ α x, free_group.induction_on x (map_one id) (λ x, map_pure id x)
    (λ x ih, by rw [map_inv, ih]) (λ x y ihx ihy, by rw [map_mul, ihx, ihy]),
  pure_bind := λ α β x f, pure_bind f x,
  bind_assoc := λ α β γ x f g, free_group.induction_on x
    (by iterate 3 { rw one_bind }) (λ x, by iterate 2 { rw pure_bind })
    (λ x ih, by iterate 3 { rw inv_bind }; rw ih)
    (λ x y ihx ihy, by iterate 3 { rw mul_bind }; rw [ihx, ihy]),
  bind_pure_comp_eq_map := λ α β f x, free_group.induction_on x
    (by rw [one_bind, map_one]) (λ x, by rw [pure_bind, map_pure])
    (λ x ih, by rw [inv_bind, map_inv, ih]) (λ x y ihx ihy, by rw [mul_bind, map_mul, ihx, ihy]) }

end category

section reduce

variable [decidable_eq α]

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce (L : list (α × bool)) : list (α × bool) :=
list.rec_on L [] $ λ hd1 tl1 ih,
list.cases_on ih [hd1] $ λ hd2 tl2,
if hd1.1 = hd2.1 ∧ hd1.2 = bnot hd2.2 then tl2
else hd1 :: hd2 :: tl2

@[simp] lemma reduce.cons (x) : reduce (x :: L) =
  list.cases_on (reduce L) [x] (λ hd tl,
  if x.1 = hd.1 ∧ x.2 = bnot hd.2 then tl
  else x :: hd :: tl) := rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red : red L (reduce L) :=
begin
  induction L with hd1 tl1 ih,
  case list.nil
  { constructor },
  case list.cons
  { dsimp,
    revert ih,
    generalize htl : reduce tl1 = TL,
    intro ih,
    cases TL with hd2 tl2,
    case list.nil
    { exact red.cons_cons ih },
    case list.cons
    { dsimp,
      by_cases h : hd1.fst = hd2.fst ∧ hd1.snd = bnot (hd2.snd),
      { rw [if_pos h],
        transitivity,
        { exact red.cons_cons ih },
        { cases hd1, cases hd2, cases h,
          dsimp at *, subst_vars,
          exact red.step.cons_bnot_rev.to_red } },
      { rw [if_neg h],
        exact red.cons_cons ih } } }
end

theorem reduce.not {p : Prop} :
  ∀ {L₁ L₂ L₃ : list (α × bool)} {x b}, reduce L₁ = L₂ ++ (x, b) :: (x, bnot b) :: L₃ → p
| [] L2 L3 _ _ := λ h, by cases L2; injections
| ((x,b)::L1) L2 L3 x' b' := begin
  dsimp,
  cases r : reduce L1,
  { dsimp, intro h,
    have := congr_arg list.length h,
    simp [-add_comm] at this,
    exact absurd this dec_trivial },
  cases hd with y c,
  by_cases x = y ∧ b = bnot c; simp [h]; intro H,
  { rw H at r,
    exact @reduce.not L1 ((y,c)::L2) L3 x' b' r },
  rcases L2 with _|⟨a, L2⟩,
  { injections, subst_vars,
    simp at h, cc },
  { refine @reduce.not L1 L2 L3 x' b' _,
    injection H with _ H,
    rw [r, H], refl }
end

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min (H : red (reduce L₁) L₂) : reduce L₁ = L₂ :=
begin
  induction H with L1 L' L2 H1 H2 ih,
  { refl },
  { cases H1 with L4 L5 x b,
    exact reduce.not H2 }
end

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem : reduce (reduce L) = reduce L :=
eq.symm $ reduce.min reduce.red

theorem reduce.step.eq (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (reduce.red.head H) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red (H : red L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (red.trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, H13, H23⟩ := red.exact.1 H in
(reduce.eq_of_red H13).trans (reduce.eq_of_red H23).symm

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
red.exact.2 ⟨reduce L₂, H ▸ reduce.red, reduce.red⟩

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self : mk (reduce L) = mk L :=
reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev (H : red L₁ L₂) : red L₂ (reduce L₁) :=
(reduce.eq_of_red H).symm ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word : free_group α → list (α × bool) :=
quot.lift reduce $ λ L₁ L₂ H, reduce.step.eq H

lemma to_word.mk : ∀{x : free_group α}, mk (to_word x) = x :=
by rintros ⟨L⟩; exact reduce.self

lemma to_word.inj : ∀(x y : free_group α), to_word x = to_word y → x = y :=
by rintros ⟨L₁⟩ ⟨L₂⟩; exact reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser (H12 : red L₁ L₂) (H13 : red L₁ L₃) :
  { L₄ // red L₂ L₄ ∧ red L₃ L₄ } :=
⟨reduce L₁, reduce.rev H12, reduce.rev H13⟩

instance : decidable_eq (free_group α) :=
function.injective.decidable_eq to_word.inj

instance red.decidable_rel : decidable_rel (@red α)
| [] []          := is_true red.refl
| [] (hd2::tl2)  := is_false $ λ H, list.no_confusion (red.nil_iff.1 H)
| ((x,b)::tl) [] := match red.decidable_rel tl [(x, bnot b)] with
  | is_true H  := is_true $ red.trans (red.cons_cons H) $
    (@red.step.bnot _ [] [] _ _).to_red
  | is_false H := is_false $ λ H2, H $ red.cons_nil_iff_singleton.1 H2
  end
| ((x1,b1)::tl1) ((x2,b2)::tl2) := if h : (x1, b1) = (x2, b2)
  then match red.decidable_rel tl1 tl2 with
    | is_true H  := is_true $ h ▸ red.cons_cons H
    | is_false H := is_false $ λ H2, H $ h ▸ (red.cons_cons_iff _).1 $ H2
    end
  else match red.decidable_rel tl1 ((x1,bnot b1)::(x2,b2)::tl2) with
    | is_true H  := is_true $ (red.cons_cons H).tail red.step.cons_bnot
    | is_false H := is_false $ λ H2, H $ red.inv_of_red_of_ne h H2
    end

/-- A list containing every word that `w₁` reduces to. -/
def red.enum (L₁ : list (α × bool)) : list (list (α × bool)) :=
list.filter (λ L₂, red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
list.of_mem_filter H

theorem red.enum.complete (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
list.mem_filter_of_mem (list.mem_sublists.2 $ red.sublist H) H

instance : fintype { L₂ // red L₁ L₂ } :=
fintype.subtype (list.to_finset $ red.enum L₁) $
λ L₂, ⟨λ H, red.enum.sound $ list.mem_to_finset.1 H,
  λ H, list.mem_to_finset.2 $ red.enum.complete H⟩

end reduce

end free_group


variables p q r : Prop

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := begin
apply iff.intro, all_goals {intro h, exact ⟨h.2, h.1⟩ }
end
example : p ∨ q ↔ q ∨ p := begin
apply iff.intro, all_goals {intro h, cases h, {right, assumption}, {left, assumption} }
end

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := begin
apply iff.intro, {
  intro h, rw [and_assoc] at h, exact h
}, {
  intro h,
  rw [and_assoc], exact h
}
end

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := begin
apply iff.intro, {
  intro h, rw [or_assoc] at h, exact h
}, {
  intro h, rw [or_assoc], exact h
}
end

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := begin
apply iff.intro, {
  intro h,
  have hp: p := h.1,
  cases h.2,
  all_goals {
    {left, constructor, repeat {assumption}} <|> {right, constructor, repeat {assumption}}
  }
}, {
  intro h,
  cases h,
  all_goals { exact ⟨h.1, or.inl h.2⟩ <|> exact ⟨h.1, or.inr h.2⟩}
}
end

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := begin
apply iff.intro, {
  intro h,
  cases h with hp hqr,
    exact ⟨or.inl hp, or.inl hp⟩,
    exact ⟨or.inr hqr.1, or.inr hqr.2⟩,
}, {
  intro h,
  apply or.elim h.1,
    intro, left, assumption,
    intro, cases h.2 with hp hr,
      left, assumption,
      right, constructor, repeat{assumption}
}
end

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := begin
apply iff.intro, {
  intros, exact a a_1.1 a_1.2
}, {
  intros, exact a ⟨a_1, a_2⟩
}
end

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := begin
apply iff.intro, {
  intro h,
  exact ⟨λ hp, h $ or.inl hp, λ hq, h $ or.inr hq⟩
}, {
  intro h,
  intro hpq, cases hpq,
    exact h.1 hpq,
    exact h.2 hpq,
}
end

example : ¬p ∨ ¬q → ¬(p ∧ q) := begin
intro h,
intro hpq,
cases h,
  exact h hpq.1,
  exact h hpq.2,
end

example : ¬(p ∧ ¬p) := begin
intro h, exact h.2 h.1
end

example : p ∧ ¬q → ¬(p → q) := begin
  intro h1, intro h2, exact (h1.2 $ h2 h1.1)
end

example : ¬p → (p → q) := begin
intros, contradiction
end

example : (¬p ∨ q) → (p → q) := begin
intros, cases a,
  contradiction,
  assumption
end

example : p ∨ false ↔ p := begin
apply iff.intro, {
  intro h, cases h,
    assumption,
    contradiction,
}, {
  intro h, left, assumption
}
end

example : p ∧ false ↔ false := begin
apply iff.intro, {
  intro h, exact h.2
}, {
  intro, contradiction
}
end

example : ¬(p ↔ ¬p) := begin
intro hc, simp at hc, assumption
end

example : (p → q) → (¬q → ¬p) := begin
intro h, intro hnq, exact (λ hp, hnq $ h hp)
end


/- One liner -/

example (p q r : Prop) (hp : p)
      : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  constructor <;> try constructor <;> (first | apply Or.inr; apply Or.inl; assumption | repeat apply Or.inr) <;> assumption

/- Propositions and Proofs -/

variable (p q r : Prop)

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := by
  apply Iff.intro <;> intros <;> simp [*]

example : p ∨ q ↔ q ∨ p := by
  apply Iff.intro <;> intro h <;> cases h <;> simp [*]

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := by
  apply Iff.intro <;>
  intros <;>
  simp [*]

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := by
  apply Iff.intro
  . intro
    | Or.inl (Or.inl _) => simp [*]
    | Or.inl (Or.inr _) => simp [*]
    | Or.inr _ => simp [*]
  . intro
    | Or.inl _ => simp [*]
    | Or.inr (Or.inr _) => simp [*]
    | Or.inr (Or.inl _) => simp [*]

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := by
  apply Iff.intro
  . intro
    | And.intro _ (Or.inl _) => simp [*]
    | And.intro _ (Or.inr _) => simp [*]
  . intro
    | Or.inl _ => simp [*]
    | Or.inr _ => simp [*]

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := by
  apply Iff.intro
  . intro
    | Or.inl _ => simp [*]
    | Or.inr _ => simp [*]
  . intro
    | And.intro hpq hpr =>
      cases hpq with
      | inl _ => simp [*]
      | inr _ =>
        cases hpr with
        | inl _ => simp [*]
        | inr _ => simp [*]

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := by
  apply Iff.intro
  . intros; simp [*]
  . intros
    have : p ∧ q := by simp [*]
    simp [*]

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) := by
  apply Iff.intro
  . intros
    constructor <;> intros <;> simp [*]
  . intro
    intro
    | Or.inl _ => simp [*]
    | Or.inr _ => simp [*]

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := by
  apply Iff.intro
  . intro h
    have : ¬ p := by
      intro; show False; apply h; apply Or.inl; assumption
    have : ¬ q := by
      intro; show False; apply h; apply Or.inr; assumption
    simp [*]
  . intros
    cases (Classical.em (p ∨ q)) with
    | inl h => cases h <;> simp [*]
    | inr => assumption

example : ¬p ∨ ¬q → ¬(p ∧ q) := by
  intro h
  have : ¬ (p ∧ q) := by
    intro
    | And.intro hp hq =>
      cases h with
      | inl hn => exact hn hp
      | inr hn => exact hn hq
  assumption

example : ¬(p ∧ ¬p) := by
  intro
  | And.intro h hn => exact hn h

example : p ∧ ¬q → ¬(p → q) := by
  intro
  | And.intro _ hn =>
    intro h
    have : q := by apply h; assumption
    apply hn; assumption

example : ¬p → (p → q) := by
  intros
  contradiction

example : (¬p ∨ q) → (p → q) := by
  intro h _
  cases h with
  | inl => show q; contradiction
  | inr => assumption

example : p ∨ False ↔ p := by
  apply Iff.intro
  . intro h
    cases h with
    | inl => assumption
    | inr => apply False.elim; assumption
  . intros; simp [*]

example : p ∧ False ↔ False := by
  apply Iff.intro
  . intros
    simp [*]
  . intros
    apply False.elim
    assumption

example : (p → q) → (¬q → ¬p) := by
  intros
  intro
  have : q := by simp [*]
  show False; contradiction

variable (p q r s : Prop)

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) := by
  intros
  cases (Classical.em p)
  . have : r ∨ s := by simp [*]
    cases this with
    | inl hr => apply Or.inl; exact (fun assumption => hr)
    | inr hs => apply Or.inr; exact (fun assumption => hs)
  . have : p → r := by
      intro
      show r; contradiction
    apply Or.inl; assumption

example : ¬(p ∧ q) → ¬p ∨ ¬q := by
  intro
  cases (Classical.em p) with
  | inl hp => cases (Classical.em q) with
    | inl hq => apply absurd; exact And.intro hp hq; assumption
    | inr => apply Or.inr; assumption
  | inr => apply Or.inl; assumption

example : ¬(p → q) → p ∧ ¬q := by
  intro h
  cases (Classical.em p) with
  | inl hp => cases (Classical.em q) with
    | inl hq => apply absurd; exact (fun hp : p => hq); assumption
    | inr => constructor <;> assumption
  | inr => cases (Classical.em q) with
    | inl =>
      have : p → q := by intro; assumption
      contradiction
    | inr =>
      have : p → q := by intro; contradiction
      contradiction

example : (p → q) → (¬p ∨ q) := by
  intro
  cases (Classical.em p) with
  | inl => simp [*]
  | inr => simp [*]

example : (¬q → ¬p) → (p → q) := by
  intros
  apply Classical.byContradiction
  intro
  have : ¬ p := by simp [*]
  apply this; assumption

example : p ∨ ¬p := by
  cases (Classical.em p) with
  | inl => simp [*]
  | inr => simp [*]

example : (((p → q) → p) → p) := by
  intro h
  cases (Classical.em (p → q)) with
  | inl => apply h; assumption
  | inr hn =>
    apply Classical.byContradiction
    intro
    have : p → q := by simp [*]
    apply hn; exact this

/- Quantifiers and Equality -/

variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : (∃ x : α, r) → r := by
  intro
  | Exists.intro _ _ => assumption

example (a : α) : r → (∃ x : α, r) := by
  intro
  constructor <;> assumption

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r := by
  apply Iff.intro
  . intro
    | Exists.intro _ (And.intro _ _) =>
      constructor; constructor <;> assumption; assumption
  . intro
    | And.intro (Exists.intro _ _) _ =>
      constructor; constructor <;> assumption

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) := by
  apply Iff.intro
  . intro
    | Exists.intro _ h => cases h with
      | inl => apply Or.inl; constructor; assumption
      | inr => apply Or.inr; constructor; assumption
  . intro h
    cases h with
    | inl he =>
      let (Exists.intro _ _) := he
      constructor; apply Or.inl; assumption
    | inr he =>
      let (Exists.intro _ _) := he
      constructor; apply Or.inr; assumption

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := by
  apply Iff.intro
  . intro
    cases (Classical.em (∃ x, ¬ p x)) with
    | inl h =>
      let (Exists.intro x _) := h
      have : p x := by simp [*]
      contradiction
    | inr => assumption
  . intro
    intro x
    cases (Classical.em (p x)) with
    | inl => assumption
    | inr =>
      have : ∃ x, ¬ p x := by constructor <;> assumption
      contradiction

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) := by
  apply Iff.intro
  . intro
    | Exists.intro x _ =>
      intro
      have : ¬ p x := by simp [*]
      contradiction
  . intro
    apply Classical.byContradiction
    intro
    have : ∀ x, ¬ p x := by
      intro
      intro
      have : ∃ x, p x := by constructor <;> assumption
      contradiction
    contradiction

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) := by
  apply Iff.intro
  . repeat intro
    have : ∃ x, p x := by constructor <;> assumption
    contradiction
  . intro
    cases (Classical.em (∃ x, p x)) with
    | inl he =>
      let (Exists.intro x _) := he
      have : ¬ p x := by simp [*]
      contradiction
    | inr => assumption

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := by
  apply Iff.intro
  . intro
    apply Classical.byContradiction
    intro
    have : ∀ x, p x := by
      intro
      apply Classical.byContradiction
      intro
      have : ∃ x, ¬ p x := by constructor <;> assumption
      contradiction
    contradiction
  . intro
    | Exists.intro x _ =>
      cases (Classical.em (∀ x, p x)) with
      | inl =>
        have : p x := by simp [*]
        contradiction
      | inr => assumption

example : (∀ x, p x → r) ↔ (∃ x, p x) → r := by
  apply Iff.intro
  . intro h
    intro
    | Exists.intro x _ =>
      have : p x → r := h x
      simp [*]
  . intros
    have : ∃ x, p x := by constructor <;> assumption
    simp [*]

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r := by
  apply Iff.intro
  . intro
    | Exists.intro _ _ =>
      intro
      simp [*]
  . intro
    cases (Classical.em (∀ x, p x)) with
    | inl =>
      have : p a := by simp [*]
      exists a; simp [*]
    | inr =>
      apply Classical.byContradiction
      intro
      have : ∀ x, p x := by
        intro x
        apply Classical.byContradiction
        intro
        have : ∃ x, p x → r := by exists x; intro; contradiction
        contradiction
      contradiction

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) := by
  apply Iff.intro
  . intro
    | (Exists.intro x _), _ =>
      have : p x := by simp [*]
      constructor <;> assumption
  . intro
    cases (Classical.em r) with
    | inl =>
      have : ∃ x, p x := by simp [*]
      let (Exists.intro x _) := this
      exists x; simp [*]
    | inr =>
      have : r → p a := by intro; contradiction
      constructor <;> assumption

variable (α : Type) (p q : α → Prop)

example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=  by
  apply Iff.intro
  . intro
    constructor <;> intro <;> simp [*]
  . intros
    constructor <;> simp [*]

example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) := by
  intros
  simp [*]

example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x := by
  intro
  | Or.inl _, _ => apply Or.inl; simp [*]
  | Or.inr _, _ => apply Or.inr; simp [*]

variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : α → ((∀ x : α, r) ↔ r) := by
  intro
  apply Iff.intro
  . intro h; apply h; assumption
  . intro; intro; assumption

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r := by
  apply Iff.intro
  . intro h
    cases (Classical.em r) with
    | inl => simp [*]
    | inr =>
      have : ∀ x, p x := by
        intro x;
        have : p x ∨ r := h x
        cases this with
          | inl => assumption
          | inr => contradiction
      simp [*]
  . intro
    | Or.inl _, x => apply Or.inl; simp [*]
    | Or.inr _, x => apply Or.inr; assumption

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) := by
  apply Iff.intro
  . intros
    simp [*]
  . intros
    simp [*]

variable (men : Type) (barber : men)
variable  (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False := by
  cases (Classical.em (shaves barber barber)) with
  | inl hb => exact ((h barber).mp hb) hb
  | inr hnb => exact hnb ((h barber).mpr hnb)


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen, Patrick Massot
-/

import data.fintype.basic
import data.set.finite
import data.setoid.basic
import order.partition.finpartition

/-!
# Equivalence relations: partitions

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

This file comprises properties of equivalence relations viewed as partitions.
There are two implementations of partitions here:
* A collection `c : set (set α)` of sets is a partition of `α` if `∅ ∉ c` and each element `a : α`
  belongs to a unique set `b ∈ c`. This is expressed as `is_partition c`
* An indexed partition is a map `s : ι → α` whose image is a partition. This is
  expressed as `indexed_partition s`.

Of course both implementations are related to `quotient` and `setoid`.

`setoid.is_partition.partition` and `finpartition.is_partition_parts` furnish
a link between `setoid.is_partition` and `finpartition`.

## TODO

Could the design of `finpartition` inform the one of `setoid.is_partition`? Maybe bundling it and
changing it from `set (set α)` to `set α` where `[lattice α] [order_bot α]` would make it more
usable.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation, partition, equivalence class
-/

namespace setoid

variables {α : Type*}

/-- If x ∈ α is in 2 elements of a set of sets partitioning α, those 2 sets are equal. -/
lemma eq_of_mem_eqv_class {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b)
  {x b b'} (hc : b ∈ c) (hb : x ∈ b) (hc' : b' ∈ c) (hb' : x ∈ b') :
  b = b' :=
(H x).unique2 hc hb hc' hb'

/-- Makes an equivalence relation from a set of sets partitioning α. -/
def mk_classes (c : set (set α)) (H : ∀ a, ∃! b ∈ c, a ∈ b) :
  setoid α :=
⟨λ x y, ∀ s ∈ c, x ∈ s → y ∈ s, ⟨λ _ _ _ hx, hx,
 λ x y h s hs hy, (H x).elim2 $ λ t ht hx _,
   have s = t, from eq_of_mem_eqv_class H hs hy ht (h t ht hx),
   this.symm ▸ hx,
 λ x y z h1 h2 s hs hx, (H y).elim2 $ λ t ht hy _, (H z).elim2 $ λ t' ht' hz _,
   have hst : s = t, from eq_of_mem_eqv_class H hs (h1 _ hs hx) ht hy,
   have htt' : t = t', from eq_of_mem_eqv_class H ht (h2 _ ht hy) ht' hz,
   (hst.trans htt').symm ▸ hz⟩⟩

/-- Makes the equivalence classes of an equivalence relation. -/
def classes (r : setoid α) : set (set α) :=
{s | ∃ y, s = {x | r.rel x y}}

lemma mem_classes (r : setoid α) (y) : {x | r.rel x y} ∈ r.classes := ⟨y, rfl⟩

lemma classes_ker_subset_fiber_set {β : Type*} (f : α → β) :
  (setoid.ker f).classes ⊆ set.range (λ y, {x | f x = y}) :=
by { rintro s ⟨x, rfl⟩, rw set.mem_range, exact ⟨f x, rfl⟩ }

lemma finite_classes_ker {α β : Type*} [finite β] (f : α → β) :
  (setoid.ker f).classes.finite :=
(set.finite_range _).subset $ classes_ker_subset_fiber_set f

lemma card_classes_ker_le {α β : Type*} [fintype β]
  (f : α → β) [fintype (setoid.ker f).classes] :
  fintype.card (setoid.ker f).classes ≤ fintype.card β :=
begin
  classical,
  exact le_trans (set.card_le_of_subset (classes_ker_subset_fiber_set f)) (fintype.card_range_le _)
end

/-- Two equivalence relations are equal iff all their equivalence classes are equal. -/
lemma eq_iff_classes_eq {r₁ r₂ : setoid α} :
  r₁ = r₂ ↔ ∀ x, {y | r₁.rel x y} = {y | r₂.rel x y} :=
⟨λ h x, h ▸ rfl, λ h, ext' $ λ x, set.ext_iff.1 $ h x⟩

lemma rel_iff_exists_classes (r : setoid α) {x y} :
  r.rel x y ↔ ∃ c ∈ r.classes, x ∈ c ∧ y ∈ c :=
⟨λ h, ⟨_, r.mem_classes y, h, r.refl' y⟩,
  λ ⟨c, ⟨z, hz⟩, hx, hy⟩, by { subst c, exact r.trans' hx (r.symm' hy) }⟩

/-- Two equivalence relations are equal iff their equivalence classes are equal. -/
lemma classes_inj {r₁ r₂ : setoid α} :
  r₁ = r₂ ↔ r₁.classes = r₂.classes :=
⟨λ h, h ▸ rfl, λ h, ext' $ λ a b, by simp only [rel_iff_exists_classes, exists_prop, h] ⟩

/-- The empty set is not an equivalence class. -/
lemma empty_not_mem_classes {r : setoid α} : ∅ ∉ r.classes :=
λ ⟨y, hy⟩, set.not_mem_empty y $ hy.symm ▸ r.refl' y

/-- Equivalence classes partition the type. -/
lemma classes_eqv_classes {r : setoid α} (a) : ∃! b ∈ r.classes, a ∈ b :=
exists_unique.intro2 {x | r.rel x a} (r.mem_classes a) (r.refl' _) $
begin
  rintros _ ⟨y, rfl⟩ ha,
  ext x,
  exact ⟨λ hx, r.trans' hx (r.symm' ha), λ hx, r.trans' hx ha⟩
end

/-- If x ∈ α is in 2 equivalence classes, the equivalence classes are equal. -/
lemma eq_of_mem_classes {r : setoid α} {x b} (hc : b ∈ r.classes)
  (hb : x ∈ b) {b'} (hc' : b' ∈ r.classes) (hb' : x ∈ b') : b = b' :=
eq_of_mem_eqv_class classes_eqv_classes hc hb hc' hb'

/-- The elements of a set of sets partitioning α are the equivalence classes of the
    equivalence relation defined by the set of sets. -/
lemma eq_eqv_class_of_mem {c : set (set α)}
  (H : ∀ a, ∃! b ∈ c, a ∈ b) {s y} (hs : s ∈ c) (hy : y ∈ s) :
  s = {x | (mk_classes c H).rel x y} :=
set.ext $ λ x,
  ⟨λ hs', symm' (mk_classes c H) $ λ b' hb' h', eq_of_mem_eqv_class H hs hy hb' h' ▸ hs',
   λ hx, (H x).elim2 $ λ b' hc' hb' h',
     (eq_of_mem_eqv_class H hs hy hc' $ hx b' hc' hb').symm ▸ hb'⟩

/-- The equivalence classes of the equivalence relation defined by a set of sets
    partitioning α are elements of the set of sets. -/
lemma eqv_class_mem {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) {y} :
  {x | (mk_classes c H).rel x y} ∈ c :=
(H y).elim2 $ λ b hc hy hb, eq_eqv_class_of_mem H hc hy ▸ hc

lemma eqv_class_mem' {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) {x} :
  {y : α | (mk_classes c H).rel x y} ∈ c :=
by { convert setoid.eqv_class_mem H, ext, rw setoid.comm' }

/-- Distinct elements of a set of sets partitioning α are disjoint. -/
lemma eqv_classes_disjoint {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) :
  c.pairwise_disjoint id :=
λ b₁ h₁ b₂ h₂ h, set.disjoint_left.2 $
  λ x hx1 hx2, (H x).elim2 $ λ b hc hx hb, h $ eq_of_mem_eqv_class H h₁ hx1 h₂ hx2

/-- A set of disjoint sets covering α partition α (classical). -/
lemma eqv_classes_of_disjoint_union {c : set (set α)}
  (hu : set.sUnion c = @set.univ α) (H : c.pairwise_disjoint id) (a) :
  ∃! b ∈ c, a ∈ b :=
let ⟨b, hc, ha⟩ := set.mem_sUnion.1 $ show a ∈ _, by rw hu; exact set.mem_univ a in
  exists_unique.intro2 b hc ha $ λ b' hc' ha', H.elim_set hc' hc a ha' ha

/-- Makes an equivalence relation from a set of disjoints sets covering α. -/
def setoid_of_disjoint_union {c : set (set α)} (hu : set.sUnion c = @set.univ α)
  (H : c.pairwise_disjoint id) : setoid α :=
setoid.mk_classes c $ eqv_classes_of_disjoint_union hu H

/-- The equivalence relation made from the equivalence classes of an equivalence
    relation r equals r. -/
theorem mk_classes_classes (r : setoid α) :
  mk_classes r.classes classes_eqv_classes = r :=
ext' $ λ x y, ⟨λ h, r.symm' (h {z | r.rel z x} (r.mem_classes x) $ r.refl' x),
  λ h b hb hx, eq_of_mem_classes (r.mem_classes x) (r.refl' x) hb hx ▸ r.symm' h⟩

@[simp] theorem sUnion_classes (r : setoid α) : ⋃₀ r.classes = set.univ :=
set.eq_univ_of_forall $ λ x, set.mem_sUnion.2 ⟨{ y | r.rel y x }, ⟨x, rfl⟩, setoid.refl _⟩

section partition

/-- A collection `c : set (set α)` of sets is a partition of `α` into pairwise
disjoint sets if `∅ ∉ c` and each element `a : α` belongs to a unique set `b ∈ c`. -/
def is_partition (c : set (set α)) :=
∅ ∉ c ∧ ∀ a, ∃! b ∈ c, a ∈ b

/-- A partition of `α` does not contain the empty set. -/
lemma nonempty_of_mem_partition {c : set (set α)} (hc : is_partition c) {s} (h : s ∈ c) :
  s.nonempty :=
set.nonempty_iff_ne_empty.2 $ λ hs0, hc.1 $ hs0 ▸ h

lemma is_partition_classes (r : setoid α) : is_partition r.classes :=
⟨empty_not_mem_classes, classes_eqv_classes⟩

lemma is_partition.pairwise_disjoint {c : set (set α)} (hc : is_partition c) :
  c.pairwise_disjoint id :=
eqv_classes_disjoint hc.2

lemma is_partition.sUnion_eq_univ {c : set (set α)} (hc : is_partition c) :
  ⋃₀ c = set.univ :=
set.eq_univ_of_forall $ λ x, set.mem_sUnion.2 $
  let ⟨t, ht⟩ := hc.2 x in ⟨t, by { simp only [exists_unique_iff_exists] at ht, tauto }⟩

/-- All elements of a partition of α are the equivalence class of some y ∈ α. -/
lemma exists_of_mem_partition {c : set (set α)} (hc : is_partition c) {s} (hs : s ∈ c) :
  ∃ y, s = {x | (mk_classes c hc.2).rel x y} :=
let ⟨y, hy⟩ := nonempty_of_mem_partition hc hs in
  ⟨y, eq_eqv_class_of_mem hc.2 hs hy⟩

/-- The equivalence classes of the equivalence relation defined by a partition of α equal
    the original partition. -/
theorem classes_mk_classes (c : set (set α)) (hc : is_partition c) :
  (mk_classes c hc.2).classes = c :=
set.ext $ λ s,
  ⟨λ ⟨y, hs⟩, (hc.2 y).elim2 $ λ b hm hb hy,
    by rwa (show s = b, from hs.symm ▸ set.ext
      (λ x, ⟨λ hx, symm' (mk_classes c hc.2) hx b hm hb,
             λ hx b' hc' hx', eq_of_mem_eqv_class hc.2 hm hx hc' hx' ▸ hb⟩)),
   exists_of_mem_partition hc⟩

/-- Defining `≤` on partitions as the `≤` defined on their induced equivalence relations. -/
instance partition.le : has_le (subtype (@is_partition α)) :=
⟨λ x y, mk_classes x.1 x.2.2 ≤ mk_classes y.1 y.2.2⟩

/-- Defining a partial order on partitions as the partial order on their induced
    equivalence relations. -/
instance partition.partial_order : partial_order (subtype (@is_partition α)) :=
{ le := (≤),
  lt := λ x y, x ≤ y ∧ ¬y ≤ x,
  le_refl := λ _, @le_refl (setoid α) _ _,
  le_trans := λ _ _ _, @le_trans (setoid α) _ _ _ _,
  lt_iff_le_not_le := λ _ _, iff.rfl,
  le_antisymm := λ x y hx hy, let h := @le_antisymm (setoid α) _ _ _ hx hy in by
    rw [subtype.ext_iff_val, ←classes_mk_classes x.1 x.2, ←classes_mk_classes y.1 y.2, h] }

variables (α)

/-- The order-preserving bijection between equivalence relations on a type `α`, and
  partitions of `α` into subsets. -/
protected def partition.order_iso :
  setoid α ≃o {C : set (set α) // is_partition C} :=
{ to_fun := λ r, ⟨r.classes, empty_not_mem_classes, classes_eqv_classes⟩,
  inv_fun := λ C, mk_classes C.1 C.2.2,
  left_inv := mk_classes_classes,
  right_inv := λ C, by rw [subtype.ext_iff_val, ←classes_mk_classes C.1 C.2],
  map_rel_iff' := λ r s,
    by { conv_rhs { rw [←mk_classes_classes r, ←mk_classes_classes s] }, refl } }

variables {α}

/-- A complete lattice instance for partitions; there is more infrastructure for the
    equivalent complete lattice on equivalence relations. -/
instance partition.complete_lattice : complete_lattice (subtype (@is_partition α)) :=
galois_insertion.lift_complete_lattice $ @order_iso.to_galois_insertion
_ (subtype (@is_partition α)) _ (partial_order.to_preorder _) $ partition.order_iso α

end partition

/-- A finite setoid partition furnishes a finpartition -/
@[simps]
def is_partition.finpartition {c : finset (set α)}
  (hc : setoid.is_partition (c : set (set α))) : finpartition (set.univ : set α) :=
{ parts := c,
  sup_indep := finset.sup_indep_iff_pairwise_disjoint.mpr $ eqv_classes_disjoint hc.2,
  sup_parts := c.sup_id_set_eq_sUnion.trans hc.sUnion_eq_univ,
  not_bot_mem := hc.left }

end setoid

/-- A finpartition gives rise to a setoid partition -/
theorem finpartition.is_partition_parts {α} (f : finpartition (set.univ : set α)) :
  setoid.is_partition (f.parts : set (set α)) :=
⟨f.not_bot_mem, setoid.eqv_classes_of_disjoint_union
  (f.parts.sup_id_set_eq_sUnion.symm.trans f.sup_parts) f.sup_indep.pairwise_disjoint⟩

/-- Constructive information associated with a partition of a type `α` indexed by another type `ι`,
`s : ι → set α`.

`indexed_partition.index` sends an element to its index, while `indexed_partition.some` sends
an index to an element of the corresponding set.

This type is primarily useful for definitional control of `s` - if this is not needed, then
`setoid.ker index` by itself may be sufficient. -/
structure indexed_partition {ι α : Type*} (s : ι → set α) :=
(eq_of_mem : ∀ {x i j}, x ∈ s i → x ∈ s j → i = j)
(some : ι → α)
(some_mem : ∀ i, some i ∈ s i)
(index : α → ι)
(mem_index : ∀ x, x ∈ s (index x))

/-- The non-constructive constructor for `indexed_partition`. -/
noncomputable
def indexed_partition.mk' {ι α : Type*} (s : ι → set α) (dis : ∀ i j, i ≠ j → disjoint (s i) (s j))
  (nonempty : ∀ i, (s i).nonempty) (ex : ∀ x, ∃ i, x ∈ s i) : indexed_partition s :=
{ eq_of_mem := λ x i j hxi hxj, classical.by_contradiction $ λ h, (dis _ _ h).le_bot ⟨hxi, hxj⟩,
  some := λ i, (nonempty i).some,
  some_mem := λ i, (nonempty i).some_spec,
  index := λ x, (ex x).some,
  mem_index := λ x, (ex x).some_spec }

namespace indexed_partition

open set

variables {ι α : Type*} {s : ι → set α} (hs : indexed_partition s)

/-- On a unique index set there is the obvious trivial partition -/
instance [unique ι] [inhabited α] :
  inhabited (indexed_partition (λ i : ι, (set.univ : set α))) :=
⟨{ eq_of_mem := λ x i j hi hj, subsingleton.elim _ _,
   some := default,
   some_mem := set.mem_univ,
   index := default,
   mem_index := set.mem_univ }⟩

attribute [simp] some_mem mem_index

include hs

lemma exists_mem (x : α) : ∃ i, x ∈ s i := ⟨hs.index x, hs.mem_index x⟩

lemma Union : (⋃ i, s i) = univ :=
by { ext x, simp [hs.exists_mem x] }

lemma disjoint : ∀ {i j}, i ≠ j → disjoint (s i) (s j) :=
λ i j h, disjoint_left.mpr $ λ x hxi hxj, h (hs.eq_of_mem hxi hxj)

lemma mem_iff_index_eq {x i} : x ∈ s i ↔ hs.index x = i :=
⟨λ hxi, (hs.eq_of_mem hxi (hs.mem_index x)).symm, λ h, h ▸ hs.mem_index _⟩

lemma eq (i) : s i = {x | hs.index x = i} :=
set.ext $ λ _, hs.mem_iff_index_eq

/-- The equivalence relation associated to an indexed partition. Two
elements are equivalent if they belong to the same set of the partition. -/
protected abbreviation setoid (hs : indexed_partition s) : setoid α :=
setoid.ker hs.index

@[simp]

lemma some_index (x : α) : hs.setoid.rel (hs.some (hs.index x)) x :=
hs.index_some (hs.index x)

/-- The quotient associated to an indexed partition. -/
protected def quotient := quotient hs.setoid

/-- The projection onto the quotient associated to an indexed partition. -/
def proj : α → hs.quotient := quotient.mk'

instance [inhabited α] : inhabited (hs.quotient) := ⟨hs.proj default⟩

lemma proj_eq_iff {x y : α} : hs.proj x = hs.proj y ↔ hs.index x = hs.index y :=
quotient.eq_rel

@[simp] lemma proj_some_index (x : α) : hs.proj (hs.some (hs.index x)) = hs.proj x :=
quotient.eq'.2 (hs.some_index x)

/-- The obvious equivalence between the quotient associated to an indexed partition and
the indexing type. -/
def equiv_quotient : ι ≃ hs.quotient :=
(setoid.quotient_ker_equiv_of_right_inverse hs.index hs.some $ hs.index_some).symm

@[simp] lemma equiv_quotient_index_apply (x : α) : hs.equiv_quotient (hs.index x) = hs.proj x :=
hs.proj_eq_iff.mpr (some_index hs x)

@[simp] lemma equiv_quotient_symm_proj_apply (x : α) :
  hs.equiv_quotient.symm (hs.proj x) = hs.index x :=
rfl

lemma equiv_quotient_index : hs.equiv_quotient ∘ hs.index = hs.proj :=
funext hs.equiv_quotient_index_apply

/-- A map choosing a representative for each element of the quotient associated to an indexed
partition. This is a computable version of `quotient.out'` using `indexed_partition.some`. -/
def out : hs.quotient ↪ α :=
hs.equiv_quotient.symm.to_embedding.trans ⟨hs.some, function.left_inverse.injective hs.index_some⟩

/-- This lemma is analogous to `quotient.mk_out'`. -/
@[simp]
lemma out_proj (x : α) : hs.out (hs.proj x) = hs.some (hs.index x) :=
rfl

/-- The indices of `quotient.out'` and `indexed_partition.out` are equal. -/
lemma index_out' (x : hs.quotient) : hs.index (x.out') = hs.index (hs.out x) :=
quotient.induction_on' x $ λ x, (setoid.ker_apply_mk_out' x).trans (hs.index_some _).symm

/-- This lemma is analogous to `quotient.out_eq'`. -/
@[simp] lemma proj_out (x : hs.quotient) : hs.proj (hs.out x) = x :=
quotient.induction_on' x $ λ x, quotient.sound' $ hs.some_index x

lemma class_of {x : α} : set_of (hs.setoid.rel x) = s (hs.index x) :=
set.ext $ λ y, eq_comm.trans hs.mem_iff_index_eq.symm

lemma proj_fiber (x : hs.quotient) : hs.proj ⁻¹' {x} = s (hs.equiv_quotient.symm x) :=
quotient.induction_on' x $ λ x, begin
  ext y,
  simp only [set.mem_preimage, set.mem_singleton_iff, hs.mem_iff_index_eq],
  exact quotient.eq',
end

end indexed_partition


/-
Justin Cai, jc5pz
Read and reread the chapters on implication and
bi-implication. Be sure to understand that a proof
of an implication is a function from proofs of the
premise to proofs of the conclusion, and that you
use such a function by applying it to a proof of a
premise to derive a proof of a conclusion. To build
your understanding, prove each of the following
conjectures using first a tactic script and then
in term-style.
-/

/- 1. -/
example : ∀ (P Q : Prop), P → Q → P ∧ Q :=
begin
    assume P Q,
    assume PimpQ,
    assume Q,
    exact and.intro PimpQ Q,
end

example : ∀ (P Q : Prop), P → Q → P ∧ Q :=
assume P Q,
assume PimpQ,
assume Q,
and.intro PimpQ Q

/- 2. -/
example : ∀ (P Q R : Prop), (P ∧ Q) → R → (P ∧ R) :=
begin
    assume P Q R,
    assume PQimpR,
    assume R,
    exact and.intro (and.elim_left PQimpR) R,
end

example : ∀ (P Q R : Prop), (P ∧ Q) → R → (P ∧ R) :=
    assume P Q R,
    assume PQimpR,
    assume R,
    and.intro (and.elim_left PQimpR) R

/- 3. -/
example : ∀ (P Q R : Prop), (P ∧ Q) → (Q ∧ R) → (P ∧ R) :=
begin
    assume P Q R,
    assume PQ,
    assume QR,
    exact and.intro (and.elim_left PQ) (and.elim_right QR),
end

example : ∀ (P Q R : Prop), (P ∧ Q) → (Q ∧ R) → (P ∧ R) :=
assume P Q R,
assume PQ,
assume QR,
and.intro (and.elim_left PQ) (and.elim_right QR)

/- 4. -/
theorem and_comm' :
    ∀ (P Q : Prop), P ∧ Q ↔ Q ∧ P :=
begin
    assume P Q,
    apply iff.intro,
        assume PQ,
        exact and.intro (and.elim_right PQ) (and.elim_left PQ),
        assume QP,
        exact and.intro (and.elim_right QP) (and.elim_left QP)
end

theorem and_comm'' :
    ∀ (P Q : Prop), P ∧ Q ↔ Q ∧ P :=
    assume P Q,
    iff.intro
    (assume PQ,
        and.intro (and.elim_right PQ) (and.elim_left PQ))
    (assume QP,
        and.intro (and.elim_right QP) (and.elim_left QP))

/- 5. -/
example : ∀ (P : Prop), P ∧ false → 0 = 1 :=
begin
    assume P,
    assume Pf,
    exact false.elim (and.elim_right Pf)
end

example : ∀ (P : Prop), P ∧ false → 0 = 1 :=
    assume P,
    assume Pf,
    false.elim (and.elim_right Pf)

/- 6. -/
example : ∀ (P : Prop), true ∧ P → P :=
begin
    assume P,
    assume Pt,
    exact and.elim_right Pt
end

example : ∀ (P : Prop), true ∧ P → P :=
    assume P,
    assume Pt,
    and.elim_right Pt

/- 7. Try using the rw tactic. -/
example : ∀ (n m k : ℕ), n = m → m = k → n = k :=
begin
    intros n m k,
    assume nm mk,
    rw nm,
    assumption,
end

example : ∀ (n m k : ℕ), n = m → m = k → n = k :=
    assume n m k,
    assume nm,
    assume mk,
    eq.trans nm mk

/- 8. -/
example : ∀ (s t : string), s = t ↔ t = s :=
begin
    assume s t,
    apply iff.intro,
        assume st,
        rw st,
        assume ts,
        exact eq.symm ts
end

example : ∀ (s t : string), s = t ↔ t = s :=
    assume s t,
    iff.intro
        (assume st,
        eq.symm st)
        (assume ts,
        eq.symm ts)

/- 9. -/
example :
    ∀ (T : Type) (t1 t2 : T) (P : T → Prop),
        P t1 ∧ t1 = t2 → P t2 :=
begin
    assume T,
    assume t1 t2,
    assume P,
    assume Pt1t2,
    have Pt1 := and.elim_left Pt1t2,
    have t1t2 := and.elim_right Pt1t2,
    exact eq.subst t1t2 Pt1
end

example :
    ∀ (T : Type) (t1 t2 : T) (P : T → Prop),
        P t1 ∧ t1 = t2 → P t2 :=
    λ T : Type,
        λ t1 t2 : T,
            λ P : T → Prop,
                assume Pt1t2 : P t1 ∧ t1 = t2,
                    let Pt1 := Pt1t2.left in
                        let t1t2 := Pt1t2.right in
                            eq.subst (t1t2) (Pt1)

#reduce let x : ℕ := 5 in let y : ℕ := 6 in x + y

/- 10. -/
theorem and_assoc' :
    ∀ (P Q R : Prop),
        P ∧ Q ∧ R ↔ (P ∧ Q) ∧ R :=
begin
    assume P Q R,
    apply iff.intro,
        assume PQR,
        have P := and.elim_left PQR,
        have QR := and.elim_right PQR,
        have Q := and.elim_left QR,
        have R := and.elim_right QR,
        exact (and.intro (and.intro P Q) R),
        assume PaQR,
        have PQ := and.elim_left PaQR,
        have R := and.elim_right PaQR,
        have P := and.elim_left PQ,
        have Q := and.elim_right PQ,
        have QR := and.intro Q R,
        exact (and.intro P QR)
end

theorem and_assoc'' :
    ∀ (P Q R : Prop),
        P ∧ Q ∧ R ↔ (P ∧ Q) ∧ R :=
assume P Q R,
    iff.intro
        (assume PQR : P ∧ Q ∧ R,
        let P := PQR.1 in
        let QR := PQR.2 in
        let Q := QR.1 in
        let R := QR.2 in
        and.intro (and.intro P Q) (R))
        (assume PaQR : (P ∧ Q) ∧ R,
        let PQ := PaQR.1 in
        let R := PaQR.2 in
        let P := PQ.1 in
        let Q := PQ.2 in
        and.intro P (and.intro Q R))

theorem and_assoc''' :
    ∀ (P Q R : Prop),
        P ∧ Q ∧ R ↔ (P ∧ Q) ∧ R :=
begin
    assume P Q R,
    split,
    assume h,
    have p := h.left,
    have qr := h.right,
    have q := h.right.left,
    have r := h.right.right,
    exact ((p, q), r),
        assume PaQR,
        have PQ := and.elim_left PaQR,
        have R := and.elim_right PaQR,
        have P := and.elim_left PQ,
        have Q := and.elim_right PQ,
        have QR := and.intro Q R,
        exact (and.intro P QR)
end