/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.nat.bitwise
import data.nat.parity
import data.nat.log
import ring_theory.int.basic
import algebra.big_operators.intervals

/-!

# Natural number multiplicity

This file contains lemmas about the multiplicity function
(the maximum prime power divding a number).

# Main results

There are natural number versions of some basic lemmas about multiplicity.

There are also lemmas about the multiplicity of primes in factorials and in binomial coefficients.
-/

open finset nat multiplicity
open_locale big_operators nat

namespace nat

/-- The multiplicity of a divisor `m` of `n`, is the cardinality of the set of
  positive natural numbers `i` such that `p ^ i` divides `n`. The set is expressed
  by filtering `Ico 1 b` where `b` is any bound greater than `log m n` -/
lemma multiplicity_eq_card_pow_dvd {m n b : ℕ} (hm1 : m ≠ 1) (hn0 : 0 < n) (hb : log m n < b):
  multiplicity m n = ↑((finset.Ico 1 b).filter (λ i, m ^ i ∣ n)).card :=
calc multiplicity m n = ↑(Ico 1 $ ((multiplicity m n).get (finite_nat_iff.2 ⟨hm1, hn0⟩) + 1)).card :
  by simp
... = ↑((finset.Ico 1 b).filter (λ i, m ^ i ∣ n)).card : congr_arg coe $ congr_arg card $
  finset.ext $ λ i,
  have hmn : ¬ m ^ (log m n).succ ∣ n,
    from if hm0 : m = 0
    then λ _, by cases n; simp [*, lt_irrefl, pow_succ'] at *
    else mt (le_of_dvd hn0) (not_le_of_lt $ pow_succ_log_gt_self m n
        (hm1.symm.le_iff_lt.mp (zero_lt_iff.mpr hm0.intro)) hn0),
  ⟨λ hi, begin
      simp only [Ico.mem, mem_filter, lt_succ_iff] at *,
      exact ⟨⟨hi.1, lt_of_le_of_lt hi.2 $
        lt_of_lt_of_le (by rw [← enat.coe_lt_coe, enat.coe_get,
            multiplicity_lt_iff_neg_dvd]; exact hmn)
          hb⟩,
        by rw [pow_dvd_iff_le_multiplicity];
          rw [← @enat.coe_le_coe i, enat.coe_get] at hi; exact hi.2⟩
    end,
  begin
    simp only [Ico.mem, mem_filter, lt_succ_iff, and_imp, true_and] { contextual := tt },
    assume h1i hib hmin,
    rwa [← enat.coe_le_coe, enat.coe_get, ← pow_dvd_iff_le_multiplicity]
  end⟩

namespace prime

lemma multiplicity_mul {p m n : ℕ} (hp : p.prime) :
  multiplicity p (m * n) = multiplicity p m + multiplicity p n :=
multiplicity.mul $ prime_iff_prime.mp hp

lemma multiplicity_pow {p m n : ℕ} (hp : p.prime) :
  multiplicity p (m ^ n) = n • (multiplicity p m) :=
multiplicity.pow $ prime_iff_prime.mp hp

lemma multiplicity_self {p : ℕ} (hp : p.prime) : multiplicity p p = 1 :=
multiplicity_self (prime_iff_prime.mp hp).not_unit hp.ne_zero

lemma multiplicity_pow_self {p n : ℕ} (hp : p.prime) : multiplicity p (p ^ n) = n :=
multiplicity_pow_self hp.ne_zero (prime_iff_prime.mp hp).not_unit n

/-- The multiplicity of a prime in `n!` is the sum of the quotients `n / p ^ i`.
  This sum is expressed over the set `Ico 1 b` where `b` is any bound greater than `log p n` -/
lemma multiplicity_factorial {p : ℕ} (hp : p.prime) :
  ∀ {n b : ℕ}, log p n < b → multiplicity p n! = (∑ i in Ico 1 b, n / p ^ i : ℕ)
| 0     b hb := by simp [Ico, hp.multiplicity_one]
| (n+1) b hb :=
  calc multiplicity p (n+1)! = multiplicity p n! + multiplicity p (n+1) :
    by rw [factorial_succ, hp.multiplicity_mul, add_comm]
  ... = (∑ i in Ico 1 b, n / p ^ i : ℕ) + ((finset.Ico 1 b).filter (λ i, p ^ i ∣ n+1)).card :
    by rw [multiplicity_factorial (lt_of_le_of_lt log_le_log_succ hb),
      ← multiplicity_eq_card_pow_dvd (ne_of_gt hp.one_lt) (succ_pos _) hb]
  ... = (∑ i in Ico 1 b, (n / p ^ i + if p^i ∣ n+1 then 1 else 0) : ℕ) :
    by rw [sum_add_distrib, sum_boole]; simp
  ... = (∑ i in Ico 1 b, (n + 1) / p ^ i : ℕ) :
    congr_arg coe $ finset.sum_congr rfl (by intros; simp [nat.succ_div]; congr)

/-- The multiplicity of `p` in `(p(n+1))!` is one more than the sum
  of the multiplicities of `p` in `(p * n)!` and `n + 1`. -/
lemma multiplicity_factorial_mul_succ {n p : ℕ} (hp : p.prime) :
  multiplicity p (p * (n + 1))! = multiplicity p (p * n)! + multiplicity p (n + 1) + 1 :=
begin
  have hp' := prime_iff_prime.mp hp,
  have h0 : 2 ≤ p := hp.two_le,
  have h1 : 1 ≤ p * n + 1 := le_add_left _ _,
  have h2 : p * n + 1 ≤ p * (n + 1), linarith,
  have h3 : p * n + 1 ≤ p * (n + 1) + 1, linarith,
  have hm : multiplicity p (p * n)! ≠ ⊤,
  { rw [ne.def, eq_top_iff_not_finite, not_not, finite_nat_iff],
    exact ⟨hp.ne_one, factorial_pos _⟩ },
  revert hm,
  have h4 : ∀ m ∈ Ico (p * n + 1) (p * (n + 1)), multiplicity p m = 0,
  { intros m hm, apply multiplicity_eq_zero_of_not_dvd,
    rw [← exists_lt_and_lt_iff_not_dvd _ (pos_iff_ne_zero.mpr hp.ne_zero)], rw [Ico.mem] at hm,
    exact ⟨n, lt_of_succ_le hm.1, hm.2⟩ },
  simp_rw [← prod_Ico_id_eq_factorial, multiplicity.finset.prod hp', ← sum_Ico_consecutive _ h1 h3,
    add_assoc], intro h,
  rw [enat.add_left_cancel_iff h, sum_Ico_succ_top h2, multiplicity.mul hp',
    hp.multiplicity_self, sum_congr rfl h4, sum_const_zero, zero_add,
    add_comm (1 : enat)]
end

/-- The multiplicity of `p` in `(pn)!` is `n` more than that of `n!`. -/
lemma multiplicity_factorial_mul {n p : ℕ} (hp : p.prime) :
  multiplicity p (p * n)! = multiplicity p n! + n :=
begin
  induction n with n ih,
  { simp },
  { simp only [succ_eq_add_one, multiplicity.mul, hp, prime_iff_prime.mp hp, ih,
      multiplicity_factorial_mul_succ, ←add_assoc, enat.coe_one, enat.coe_add, factorial_succ],
    congr' 1,
    rw [add_comm, add_assoc] }
end

/-- A prime power divides `n!` iff it is at most the sum of the quotients `n / p ^ i`.
  This sum is expressed over the set `Ico 1 b` where `b` is any bound greater than `log p n` -/
lemma pow_dvd_factorial_iff {p : ℕ} {n r b : ℕ} (hp : p.prime) (hbn : log p n < b) :
   p ^ r ∣ n! ↔ r ≤ ∑ i in Ico 1 b, n / p ^ i :=
by rw [← enat.coe_le_coe, ← hp.multiplicity_factorial hbn, ← pow_dvd_iff_le_multiplicity]

lemma multiplicity_choose_aux {p n b k : ℕ} (hp : p.prime) (hkn : k ≤ n) :
  ∑ i in finset.Ico 1 b, n / p ^ i =
  ∑ i in finset.Ico 1 b, k / p ^ i + ∑ i in finset.Ico 1 b, (n - k) / p ^ i +
  ((finset.Ico 1 b).filter (λ i, p ^ i ≤ k % p ^ i + (n - k) % p ^ i)).card :=
calc ∑ i in finset.Ico 1 b, n / p ^ i
    = ∑ i in finset.Ico 1 b, (k + (n - k)) / p ^ i :
    by simp only [nat.add_sub_cancel' hkn]
... = ∑ i in finset.Ico 1 b, (k / p ^ i + (n - k) / p ^ i +
      if p ^ i ≤ k % p ^ i + (n - k) % p ^ i then 1 else 0) :
    by simp only [nat.add_div (pow_pos hp.pos _)]
... = _ : by simp [sum_add_distrib, sum_boole]

/-- The multiplity of `p` in `choose n k` is the number of carries when `k` and `n - k`
  are added in base `p`. The set is expressed by filtering `Ico 1 b` where `b`
  is any bound greater than `log p n`. -/
lemma multiplicity_choose {p n k b : ℕ} (hp : p.prime) (hkn : k ≤ n) (hnb : log p n < b) :
  multiplicity p (choose n k) =
  ((Ico 1 b).filter (λ i, p ^ i ≤ k % p ^ i + (n - k) % p ^ i)).card :=
have h₁ : multiplicity p (choose n k) + multiplicity p (k! * (n - k)!) =
    ((finset.Ico 1 b).filter (λ i, p ^ i ≤ k % p ^ i + (n - k) % p ^ i)).card +
    multiplicity p (k! * (n - k)!),
  begin
    rw [← hp.multiplicity_mul, ← mul_assoc, choose_mul_factorial_mul_factorial hkn,
        hp.multiplicity_factorial hnb, hp.multiplicity_mul,
        hp.multiplicity_factorial ((log_le_log_of_le hkn).trans_lt hnb),
        hp.multiplicity_factorial (lt_of_le_of_lt (log_le_log_of_le (nat.sub_le_self _ _)) hnb),
        multiplicity_choose_aux hp hkn],
    simp [add_comm],
  end,
(enat.add_right_cancel_iff
  (enat.ne_top_iff_dom.2 $
    by exact finite_nat_iff.2
      ⟨ne_of_gt hp.one_lt, mul_pos (factorial_pos k) (factorial_pos (n - k))⟩)).1
  h₁

/-- A lower bound on the multiplicity of `p` in `choose n k`. -/
lemma multiplicity_le_multiplicity_choose_add {p : ℕ} (hp : p.prime) (n k : ℕ) :
  multiplicity p n ≤ multiplicity p (choose n k) + multiplicity p k :=
if hkn : n < k then by simp [choose_eq_zero_of_lt hkn]
else if hk0 : k = 0 then by simp [hk0]
else if hn0 : n = 0 then by cases k; simp [hn0, *] at *
else begin
  rw [multiplicity_choose hp (le_of_not_gt hkn) (lt_succ_self _),
    multiplicity_eq_card_pow_dvd (ne_of_gt hp.one_lt) (nat.pos_of_ne_zero hk0)
      (lt_succ_of_le (log_le_log_of_le (le_of_not_gt hkn))),
    multiplicity_eq_card_pow_dvd (ne_of_gt hp.one_lt) (nat.pos_of_ne_zero hn0) (lt_succ_self _),
    ← enat.coe_add, enat.coe_le_coe],
  calc ((Ico 1 (log p n).succ).filter (λ i, p ^ i ∣ n)).card
      ≤ ((Ico 1 (log p n).succ).filter (λ i, p ^ i ≤ k % p ^ i + (n - k) % p ^ i) ∪
        (Ico 1 (log p n).succ).filter (λ i, p ^ i ∣ k) ).card :
    card_le_of_subset $ λ i, begin
      have := @le_mod_add_mod_of_dvd_add_of_not_dvd k (n - k) (p ^ i),
      simp [nat.add_sub_cancel' (le_of_not_gt hkn)] at * {contextual := tt},
      tauto
    end
  ... ≤ ((Ico 1 (log p n).succ).filter (λ i, p ^ i ≤ k % p ^ i + (n - k) % p ^ i)).card +
        ((Ico 1 (log p n).succ).filter (λ i, p ^ i ∣ k)).card :
    card_union_le _ _
end

lemma multiplicity_choose_prime_pow {p n k : ℕ} (hp : p.prime)
  (hkn : k ≤ p ^ n) (hk0 : 0 < k) :
  multiplicity p (choose (p ^ n) k) + multiplicity p k = n :=
le_antisymm
  (have hdisj : disjoint
      ((Ico 1 n.succ).filter (λ i, p ^ i ≤ k % p ^ i + (p ^ n - k) % p ^ i))
      ((Ico 1 n.succ).filter (λ i, p ^ i ∣ k)),
    by simp [disjoint_right, *, dvd_iff_mod_eq_zero, nat.mod_lt _ (pow_pos hp.pos _)]
        {contextual := tt},
  begin
    rw [multiplicity_choose hp hkn (lt_succ_self _),
      multiplicity_eq_card_pow_dvd (ne_of_gt hp.one_lt) hk0
        (lt_succ_of_le (log_le_log_of_le hkn)),
      ← enat.coe_add, enat.coe_le_coe, log_pow _ _ hp.one_lt,
      ← card_disjoint_union hdisj, filter_union_right],
    have filter_le_Ico := (Ico 1 n.succ).card_filter_le _,
    rwa Ico.card 1 n.succ at filter_le_Ico,
  end)
  (by rw [← hp.multiplicity_pow_self];
    exact multiplicity_le_multiplicity_choose_add hp _ _)

end prime

lemma multiplicity_two_factorial_lt : ∀ {n : ℕ} (h : n ≠ 0), multiplicity 2 n! < n :=
begin
  have h2 := prime_iff_prime.mp prime_two,
  refine binary_rec _ _,
  { contradiction },
  { intros b n ih h,
    by_cases hn : n = 0,
    { subst hn, simp at h, simp [h, one_right h2.not_unit, enat.zero_lt_one] },
    have : multiplicity 2 (2 * n)! < (2 * n : ℕ),
    { rw [prime_two.multiplicity_factorial_mul],
      refine (enat.add_lt_add_right (ih hn) (enat.coe_ne_top _)).trans_le _,
      rw [two_mul], norm_cast },
    cases b,
    { simpa [bit0_eq_two_mul n] },
    { suffices : multiplicity 2 (2 * n + 1) + multiplicity 2 (2 * n)! < ↑(2 * n) + 1,
      { simpa [succ_eq_add_one, multiplicity.mul, h2, prime_two, nat.bit1_eq_succ_bit0,
          bit0_eq_two_mul n] },
      rw [multiplicity_eq_zero_of_not_dvd (two_not_dvd_two_mul_add_one n), zero_add],
      refine this.trans _, exact_mod_cast lt_succ_self _ }}
end

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

/-!
# 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₄) :=
(refl_trans_gen_lift (λL, L ++ L₂) (assume a b, step.append_right) h₁).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₂ := eqv_gen_mono (assume a b, join_red_of_step) h,
    (eqv_gen_iff_of_equivalence $ equivalence_join_red).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 [gpow_add] at ih ⊢; rw ih; refl),
  end,
  right_inv :=
    λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [gpow_add, ih])
    (λ i ih, by simp at ih; simp [gpow_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


/-
Copyright (c) 2021 François Sunatori. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: François Sunatori
-/
import analysis.complex.circle
import linear_algebra.determinant
import linear_algebra.matrix.general_linear_group

/-!
# Isometries of the Complex Plane

The lemma `linear_isometry_complex` states the classification of isometries in the complex plane.
Specifically, isometries with rotations but without translation.
The proof involves:
1. creating a linear isometry `g` with two fixed points, `g(0) = 0`, `g(1) = 1`
2. applying `linear_isometry_complex_aux` to `g`
The proof of `linear_isometry_complex_aux` is separated in the following parts:
1. show that the real parts match up: `linear_isometry.re_apply_eq_re`
2. show that I maps to either I or -I
3. every z is a linear combination of a + b * I

## References

* [Isometries of the Complex Plane](http://helmut.knaust.info/mediawiki/images/b/b5/Iso.pdf)
-/
noncomputable theory

open complex
open_locale complex_conjugate

local notation (name := complex.abs) `|` x `|` := complex.abs x

/-- An element of the unit circle defines a `linear_isometry_equiv` from `ℂ` to itself, by
rotation. -/
def rotation : circle →* (ℂ ≃ₗᵢ[ℝ] ℂ) :=
{ to_fun := λ a,
  { norm_map' := λ x, show |a * x| = |x|, by rw [map_mul, abs_coe_circle, one_mul],
    ..distrib_mul_action.to_linear_equiv ℝ ℂ a },
  map_one' := linear_isometry_equiv.ext $ one_smul _,
  map_mul' := λ _ _, linear_isometry_equiv.ext $ mul_smul _ _ }

@[simp] lemma rotation_apply (a : circle) (z : ℂ) : rotation a z = a * z := rfl

@[simp] lemma rotation_symm (a : circle) : (rotation a).symm = rotation a⁻¹ :=
linear_isometry_equiv.ext $ λ x, rfl

@[simp] lemma rotation_trans (a b : circle) :
  (rotation a).trans (rotation b) = rotation (b * a) :=
by { ext1, simp }

lemma rotation_ne_conj_lie (a : circle) : rotation a ≠ conj_lie :=
begin
  intro h,
  have h1 : rotation a 1 = conj 1 := linear_isometry_equiv.congr_fun h 1,
  have hI : rotation a I = conj I := linear_isometry_equiv.congr_fun h I,
  rw [rotation_apply, ring_hom.map_one, mul_one] at h1,
  rw [rotation_apply, conj_I, ← neg_one_mul, mul_left_inj' I_ne_zero, h1, eq_neg_self_iff] at hI,
  exact one_ne_zero hI,
end

/-- Takes an element of `ℂ ≃ₗᵢ[ℝ] ℂ` and checks if it is a rotation, returns an element of the
unit circle. -/
@[simps]
def rotation_of (e : ℂ ≃ₗᵢ[ℝ] ℂ) : circle :=
⟨(e 1) / complex.abs (e 1), by simp⟩

@[simp]
lemma rotation_of_rotation (a : circle) : rotation_of (rotation a) = a :=
subtype.ext $ by simp

lemma rotation_injective : function.injective rotation :=
function.left_inverse.injective rotation_of_rotation

lemma linear_isometry.re_apply_eq_re_of_add_conj_eq (f : ℂ →ₗᵢ[ℝ] ℂ)
  (h₃ : ∀ z, z + conj z = f z + conj (f z)) (z : ℂ) : (f z).re = z.re :=
by simpa [ext_iff, add_re, add_im, conj_re, conj_im, ←two_mul,
         (show (2 : ℝ) ≠ 0, by simp [two_ne_zero])] using (h₃ z).symm

lemma linear_isometry.im_apply_eq_im_or_neg_of_re_apply_eq_re {f : ℂ →ₗᵢ[ℝ] ℂ}
  (h₂ : ∀ z, (f z).re = z.re) (z : ℂ) :
  (f z).im = z.im ∨ (f z).im = -z.im :=
begin
  have h₁ := f.norm_map z,
  simp only [complex.abs_def, norm_eq_abs] at h₁,
  rwa [real.sqrt_inj (norm_sq_nonneg _) (norm_sq_nonneg _), norm_sq_apply (f z), norm_sq_apply z,
    h₂, add_left_cancel_iff, mul_self_eq_mul_self_iff] at h₁,
end

lemma linear_isometry.im_apply_eq_im {f : ℂ →ₗᵢ[ℝ] ℂ} (h : f 1 = 1) (z : ℂ) :
  z + conj z = f z + conj (f z) :=
begin
  have : ‖f z - 1‖ = ‖z - 1‖ := by rw [← f.norm_map (z - 1), f.map_sub, h],
  apply_fun λ x, x ^ 2 at this,
  simp only [norm_eq_abs, ←norm_sq_eq_abs] at this,
  rw [←of_real_inj, ←mul_conj, ←mul_conj] at this,
  rw [ring_hom.map_sub, ring_hom.map_sub] at this,
  simp only [sub_mul, mul_sub, one_mul, mul_one] at this,
  rw [mul_conj, norm_sq_eq_abs, ←norm_eq_abs, linear_isometry.norm_map] at this,
  rw [mul_conj, norm_sq_eq_abs, ←norm_eq_abs] at this,
  simp only [sub_sub, sub_right_inj, mul_one, of_real_pow, ring_hom.map_one, norm_eq_abs] at this,
  simp only [add_sub, sub_left_inj] at this,
  rw [add_comm, ←this, add_comm],
end

lemma linear_isometry.re_apply_eq_re {f : ℂ →ₗᵢ[ℝ] ℂ} (h : f 1 = 1) (z : ℂ) : (f z).re = z.re :=
begin
  apply linear_isometry.re_apply_eq_re_of_add_conj_eq,
  intro z,
  apply linear_isometry.im_apply_eq_im h,
end

lemma linear_isometry_complex_aux {f : ℂ ≃ₗᵢ[ℝ] ℂ} (h : f 1 = 1) :
  f = linear_isometry_equiv.refl ℝ ℂ ∨ f = conj_lie :=
begin
  have h0 : f I = I ∨ f I = -I,
  { have : |f I| = 1 := by simpa using f.norm_map complex.I,
    simp only [ext_iff, ←and_or_distrib_left, neg_re, I_re, neg_im, neg_zero],
    split,
    { rw ←I_re,
      exact @linear_isometry.re_apply_eq_re f.to_linear_isometry h I, },
    { apply @linear_isometry.im_apply_eq_im_or_neg_of_re_apply_eq_re f.to_linear_isometry,
      intro z, rw @linear_isometry.re_apply_eq_re f.to_linear_isometry h } },
  refine h0.imp (λ h' : f I = I, _) (λ h' : f I = -I, _);
  { apply linear_isometry_equiv.to_linear_equiv_injective,
    apply complex.basis_one_I.ext',
    intros i,
    fin_cases i; simp [h, h'] }
end

lemma linear_isometry_complex (f : ℂ ≃ₗᵢ[ℝ] ℂ) :
  ∃ a : circle, f = rotation a ∨ f = conj_lie.trans (rotation a) :=
begin
  let a : circle := ⟨f 1, by simpa using f.norm_map 1⟩,
  use a,
  have : (f.trans (rotation a).symm) 1 = 1,
  { simpa using rotation_apply a⁻¹ (f 1) },
  refine (linear_isometry_complex_aux this).imp (λ h₁, _) (λ h₂, _),
  { simpa using eq_mul_of_inv_mul_eq h₁ },
  { exact eq_mul_of_inv_mul_eq h₂ }
end

/-- The matrix representation of `rotation a` is equal to the conformal matrix
`!![re a, -im a; im a, re a]`. -/
lemma to_matrix_rotation (a : circle) :
  linear_map.to_matrix basis_one_I basis_one_I (rotation a).to_linear_equiv =
    matrix.plane_conformal_matrix (re a) (im a) (by simp [pow_two, ←norm_sq_apply]) :=
begin
  ext i j,
  simp [linear_map.to_matrix_apply],
  fin_cases i; fin_cases j; simp
end

/-- The determinant of `rotation` (as a linear map) is equal to `1`. -/
@[simp] lemma det_rotation (a : circle) : ((rotation a).to_linear_equiv : ℂ →ₗ[ℝ] ℂ).det = 1 :=
begin
  rw [←linear_map.det_to_matrix basis_one_I, to_matrix_rotation, matrix.det_fin_two],
  simp [←norm_sq_apply]
end

/-- The determinant of `rotation` (as a linear equiv) is equal to `1`. -/
@[simp] lemma linear_equiv_det_rotation (a : circle) : (rotation a).to_linear_equiv.det = 1 :=
by rw [←units.eq_iff, linear_equiv.coe_det, det_rotation, units.coe_one]


import topology.basic
open topological_space
open set filter classical
variables {X : Type} [topological_space X] {A E F U V : set X}

-- Example 2.1.1.
example : is_closed F → A ⊆ F → closure A ⊆ F :=
begin
  intros Fclosed AinF,
  unfold closure,
  /-
  this is not how closure is defined in the module.
  smallest closed set containing A? I guess it kinda makes sense.
  -/
  let T := {t : set X | is_closed t ∧ A ⊆ t},
  have : F ∈ T,
  apply and.intro,
  exact Fclosed,
  exact AinF,
  /-
  Since F is one of the closed set containing A,
  intersections of sets in T (including F) is obviously a subset of F.
  -/
  apply sInter_subset_of_mem,
  exact this,
end

example : is_open U → U ⊆ A → U ⊆ interior A :=
begin
  intros Uopen UinA,
  unfold interior,
  -- A° = largest open set within A?
  let T := {t : set X | is_open t ∧ t ⊆ A},
  have h1 : U ∈ T,
    exact and.intro Uopen UinA,
  -- I would assume there is a equivalent thing but I don't seem to be able to find it so,
  apply set.subset_sUnion_of_subset T U,
  {by refl},
  {exact h1},
end


import algebra.lattice.basic algebra.lattice.bounded_lattice algebra.lattice.complete_lattice
import data.set

universes u v w
open lattice
set_option old_structure_cmd true
set_option eqn_compiler.zeta true

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

private lemma exists_add_of_le : ∀ {m n : ℕ}, m ≤ n → ∃ k, n = m + k :=
  begin
   intros m n hle,
   existsi n - m,
   rw [nat.add_sub_of_le],
   assumption
  end

def is_directed [weak_order α] (s : set α) := ∀ a b ∈ s, ∃ c, c ∈ s ∧ a ≤ c ∧ b ≤ c
def is_chain [weak_order α] (s : set α)  := ∀ a b ∈ s, a ≤ b ∨ b ≤ a

def chain [weak_order α] := {s : set α // is_chain s}

def ascending_chain α [weak_order α] := { f : ℕ → α //  ∀ n, f n ≤ f (n + 1) }

namespace ascending_chain
variables [weak_order α]

protected
def mem (a : α)(f : ascending_chain α) : Prop := ∃ n : ℕ, a = f.1 n
instance : has_mem α (ascending_chain α) := ⟨ ascending_chain.mem ⟩

def monotone (f : ascending_chain α) {m n} : m ≤ n → f.1 m ≤ f.1 n :=
begin
intro hle,
cases (exists_add_of_le hle) with k hk,
rw hk,
clear hk,
induction k with k iH,
refl,
transitivity f.1 (m + k),
assumption,
rw nat.add_succ,
apply f.property
end

def is_stationary (f : ascending_chain α) : Prop := ∃ n, ∀ m, n ≤ m → f.1 n = f.1 m

end ascending_chain

def iter_n (f : α → α) (z : α) : ℕ → α
|  0 := z
|  (n + 1) := f $ iter_n n

namespace iter_n
variables [weak_order α] {f : α → α}

lemma single_step {z : α} : monotone f → z ≤ f z → ∀ {{n : ℕ}}, iter_n f z n ≤ iter_n f z (n+1) :=
  begin
    intros hmono hini n,
    induction n with n iH,
     assumption,
     apply hmono, assumption
  end

def to_ascending_chain {f} {z} : monotone f → z ≤ f z → ascending_chain α :=
  assume hmono hini, ⟨iter_n f z, take n, begin apply single_step, repeat {assumption} end⟩

lemma upper_bound (a : α) {z} : monotone f → z ≤ a → f a ≤ a → ∀ {{n}}, iter_n f z n ≤ a :=
assume hmono hini hle,
  take n,
    nat.rec_on n hini (take n, assume iH, calc iter_n f z (n+1) = f (iter_n f z n) : by refl
                                                            ... ≤ f a              : hmono iH
                                                            ... ≤ a                : hle
                      )

end iter_n

def iter_n₁ (f : α → α) : ℕ → α → α
| 0 := id
| (n+1) := λ a, iter_n₁ n $ f a

namespace iter_n₁
variables {f : α → α}

@[simp]
lemma iter_eq : ∀ {n}{z}, iter_n₁ f (n+1) z = f (iter_n₁ f n z)
| 0 _ := rfl
| (n+1) z := calc iter_n₁ f (n + 2) z = iter_n₁ f (n + 1) (f z) : by refl
                                 ...  = f (iter_n₁ f n (f z))   : by rw iter_eq
                                 ...  = f (iter_n₁ f (n+1) z)   : by refl

lemma single_step [weak_order α] {z} (hmono : monotone f) (hini : z ≤ f z) : ∀ n, iter_n₁ f n z ≤ iter_n₁ f (n+1) z
| 0     := hini
| (n+1) := calc iter_n₁ f (n+1) z = f (iter_n₁ f n z)     : iter_eq
                            ...   ≤ f (iter_n₁ f (n+1) z) : hmono (single_step n)
                            ...   = iter_n₁ f (n+2) z     : iter_eq.symm

def to_ascending_chain [weak_order α] {z} : monotone f → z ≤ f z → ascending_chain α :=
  assume hmono hini, ⟨_, single_step hmono hini⟩

end iter_n₁

namespace is_directed

lemma empty [weak_order α] : is_directed (∅ : set α) := take a b, false.elim

lemma univ  [semilattice_sup α] : is_directed (set.univ : set α) :=
    take a b, assume ha hb, ⟨a ⊔ b , true.intro ,le_sup_left  , le_sup_right⟩

lemma singleton [weak_order α] {a} : is_directed ({a} : set α) :=
   take x y, assume hx hy,
      have eqx : x = a, from or.resolve_right hx false.elim,
      have eqy : y = a, from or.resolve_right hy false.elim,
      by rw [eqx, eqy]; exact ⟨a, or.inl rfl, le_refl _ , le_refl _⟩

lemma of_is_chain [weak_order α] { s : set α } : is_chain s → is_directed s :=
   assume h, take x y, assume hx hy,
   or.elim  (h _ _ hx hy)
      (assume hxy, ⟨_, hy, hxy, by refl⟩)
      (assume hyx, ⟨_, hx, by refl, hyx⟩)

lemma of_ascending_chain [weak_order α](f : ascending_chain α) : is_directed { a : α | a ∈ f } :=
  take x y, assume ⟨m, hm⟩ ⟨n, hn⟩,
    eq.rec_on hm.symm
    (eq.rec_on hn.symm
      (match le_total m n with
       | or.inl hmn := ⟨f.1 n, ⟨_, rfl⟩, f.monotone hmn , by refl⟩
       | or.inr hnm := ⟨f.1 m, ⟨_, rfl⟩, by refl , f.monotone hnm⟩
       end
      )
    )
 lemma of_lower_set [weak_order α] (a : α) : is_directed ({ x | x ≤ a}) :=
   take x y, assume hx hy, ⟨a, le_refl _, hx, hy⟩

end is_directed

def directed α [weak_order α] := { s : set α // is_directed s }

instance [weak_order α] : has_mem α (directed α) := ⟨ λ a s, a ∈ s.1⟩
instance [weak_order α] : has_emptyc (directed α) := ⟨ ⟨_, is_directed.empty⟩ ⟩
instance [weak_order α] : has_subset (directed α) := ⟨ λ s t, s.1 ⊆ t.1 ⟩

def directed.of_ascending_chain [weak_order α] : ascending_chain α → directed α := λ seq, ⟨_, is_directed.of_ascending_chain seq⟩
def directed.of_lower_set [weak_order α] : α → directed α := λ a, ⟨_, is_directed.of_lower_set a⟩

class directed_complete_partial_order α extends weak_order α :=
  (dSup : directed α → α)
  (le_dSup : ∀ s, ∀ a ∈ s, a ≤ dSup s)
  (dSup_le : ∀ s a, (∀ b∈s, b ≤ a) → dSup s ≤ a)

def dSup [directed_complete_partial_order α] : directed α → α := directed_complete_partial_order.dSup

section
variables [directed_complete_partial_order α]{s t : directed α} {a b : α}

lemma le_dSup : a ∈ s → a ≤ dSup s := directed_complete_partial_order.le_dSup s a
lemma dSup_le : (∀ b ∈ s, b ≤ a) → dSup s ≤ a := directed_complete_partial_order.dSup_le s a
lemma le_dSup_of_le (hb : b ∈ s) (h : a ≤ b) : a ≤ dSup s := le_trans h (le_dSup hb)

lemma dSup_le_dSup (h : s ⊆ t) : dSup s ≤ dSup t :=
  dSup_le ( take a, assume ha : a ∈ s, le_dSup $ h ha)
end
namespace directed_complete_partial_order

variables [directed_complete_partial_order α] {a b : α}

def bot : α := dSup ∅
lemma bot_le : bot ≤ a :=
  dSup_le _ _ (take b, false.elim)

end directed_complete_partial_order

instance directed_complete_partial_order_bot [ ins : directed_complete_partial_order α] : order_bot α :=
{
  ins with
  bot := directed_complete_partial_order.bot,
  bot_le := @directed_complete_partial_order.bot_le _ _,
}

class directed_complete_partial_order_sup α extends semilattice_sup α , directed_complete_partial_order α

instance directed_complete_partial_order_sup_top [ ins : directed_complete_partial_order_sup α] : semilattice_sup_top α :=
{
  ins with
  top := dSup ⟨set.univ, take x y, assume hx hy, ⟨_ , true.intro, le_sup_left, le_sup_right⟩⟩,
  le_top := take _, le_dSup true.intro
}

instance complete_lattice_directed_complete_partial_order_sup [ins : complete_lattice α] : directed_complete_partial_order_sup α :=
{
    ins with
    dSup := λ s, Sup s.1,
    le_dSup := λ s a, assume ha, le_Sup ha,
    dSup_le := λ s a, assume h, Sup_le (take _ hb, h _ hb)
}

structure is_scott_continuous [directed_complete_partial_order α] [directed_complete_partial_order β] (f : α → β) : Prop :=
  (preserve_directed : ∀ s : directed α, is_directed (set.image f s.1))
  (preserve_dSup     : ∀ s : directed α, f (dSup s) = dSup ⟨_, preserve_directed s⟩)

namespace is_scott_continuous
variables [directed_complete_partial_order α] [directed_complete_partial_order β][directed_complete_partial_order γ]
   {f : α → β}{g : β → γ}

private lemma set_image_id {α : Type u} {s : set α} : set.image (@id α) s = s :=
  set.ext (take a, iff.intro (assume ⟨_, hx, eqx⟩, eq.rec_on eqx hx)
                             (assume ha, ⟨_, ha, rfl⟩ ))
protected
lemma id : is_scott_continuous (@id α) :=
  ⟨ λ s, begin rw set_image_id, apply s.2 end , take s, begin simp, apply congr_arg, symmetry, apply subtype.eq, apply set_image_id end ⟩

protected
lemma comp : is_scott_continuous g → is_scott_continuous f → is_scott_continuous (g ∘ f) :=
  assume hg hf,
    have pr_dir : ∀ s : directed α, is_directed (set.image (g ∘ f) s.1),
       from
          take sa, take c₁ c₂, assume ⟨a₁, ha₁, eqc₁⟩ ⟨a₂, ha₂, eqc₂⟩,
            let sb : directed β := ⟨_, hf.preserve_directed sa⟩ in
            match (hg.preserve_directed sb _ _ ⟨_, ⟨_, ha₁, rfl⟩, eqc₁⟩ ⟨_, ⟨_, ha₂, rfl⟩, eqc₂⟩) with
            | ⟨c, ⟨b, ⟨a, ha, hab⟩ , hbc ⟩, hfc₁c, hfc₂c⟩ :=
              ⟨c, ⟨a, ha, begin rw -hab at hbc, assumption end⟩  , hfc₁c , hfc₂c ⟩
            end,
    ⟨pr_dir,
      take sa,
        let sb : directed β := ⟨_, hf.preserve_directed sa⟩ in
        show g (f (dSup sa)) = dSup ⟨_, pr_dir sa⟩,
          from begin
                 rw hf.preserve_dSup,
                 rw hg.preserve_dSup,
                 apply congr_arg, apply subtype.eq,
                 apply set.ext,
                 intro c,
                 apply iff.intro,
                  {
                      intro h,
                      cases h with b hb,
                      cases hb with hb eqbc,
                      cases hb with a ha,
                      cases ha with ha eqab,
                      rw -eqab at eqbc,
                      exact ⟨_, ha, eqbc⟩
                  },
                  {
                      intro h,
                      cases h with a ha,
                      cases ha with ha eqac,
                      exact ⟨_, ⟨_, ha, rfl⟩, eqac⟩
                  }
               end
      ⟩

lemma monotone : is_scott_continuous f → monotone f :=
 assume hcont, take a b, assume hab,
    have ab_is_chain : is_chain ({a,b} : set α),
       from begin
             intros x y hx hy,
             cases hx with xb hx,
               rw xb,
               cases hy with yb hy,
               rw yb, simp,
               cases hy with ya hy,
               simph,
               apply false.elim, assumption,
            cases hx with xa hx,
               rw xa,
               cases hy with yb hy,
               rw yb, left, assumption,
               cases hy with ya hy,
               simph,
               apply false.elim, assumption,
            apply false.elim, assumption
            end,
    let s : directed α := ⟨_, is_directed.of_is_chain ab_is_chain⟩ in
    have H : dSup s = b,
      from begin
            apply le_antisymm,
             { apply dSup_le,
               intros x hx,
               cases hx with xb hx,
                 rw xb,
               cases hx with xa hx,
                 rw xa, assumption,
               apply false.elim, assumption
             },
             {
                 apply le_dSup,
                 apply or.inl, refl
             }
           end,
    let s_image : directed β := ⟨_, hcont.preserve_directed s⟩ in
    have fH : dSup s_image = f b,
      from begin
            rw -hcont.preserve_dSup,
            rw H
           end,
    show f a ≤ f b,
      from begin
            rw -fH,
            apply le_dSup,
            exact ⟨_, or.inr (or.inl rfl), rfl⟩
           end
  private lemma set_image_empty {α}{β} {f : α → β} : set.image f ∅ = ∅ :=
     set.ext (take x, ⟨ assume ⟨_, h, _⟩, h.elim, false.elim ⟩ )

  lemma is_strict : is_scott_continuous f → f ⊥ = ⊥ :=
    assume hcont, eq.trans (hcont.preserve_dSup ∅) (congr_arg dSup (subtype.eq set_image_empty))

end is_scott_continuous

def scott_continuous α β [directed_complete_partial_order α] [directed_complete_partial_order β] := { f : α → β // is_scott_continuous f }

namespace scott_continuous

variables [directed_complete_partial_order α] [directed_complete_partial_order β][directed_complete_partial_order γ]
 {f : scott_continuous α β} {g : scott_continuous β γ}
protected
def id : scott_continuous α α := ⟨ _, is_scott_continuous.id⟩
protected
def comp : scott_continuous β γ → scott_continuous α β → scott_continuous α γ := take g f, ⟨_, is_scott_continuous.comp g.2 f.2⟩
protected
def monotone (f : scott_continuous α β) : monotone f.1 := f.2.monotone

protected
def le (f g : scott_continuous α β) : Prop := ∀ a , f.1 a ≤ g.1 a

instance : has_le (scott_continuous α β) := ⟨ scott_continuous.le ⟩

@[refl]
protected
def le_refl (f : scott_continuous α β) : f ≤ f := take a : α, le_refl _

@[trans]
protected
def le_trans  (f g h : scott_continuous α β) : f ≤ g → g ≤ h → f ≤ h := take hfg hgh, take a, le_trans (hfg a) (hgh a)

protected
def le_antisymm (f g : scott_continuous α β) : f ≤ g → g ≤ f → f = g :=
  take hfg hgf, subtype.eq (funext (take a, le_antisymm (hfg a) (hgf a)))

instance scott_continuous_weak_order : weak_order (scott_continuous α β) :=
{
    le := scott_continuous.le,
    le_refl := scott_continuous.le_refl,
    le_trans := scott_continuous.le_trans,
    le_antisymm := scott_continuous.le_antisymm
}
/-
protected
def sup (f g : scott_continuous α β) : scott_continuous α β :=
  let h := λ a, f.1 a ⊔ g.1 a in
  have h_monotone : monotone h, from
    take a b, assume hab, sup_le_sup (f.monotone hab) (g.monotone hab),
  have pr_dir : ∀ s : directed α, is_directed (set.image h s.1),
    from take s, take b₁ b₂, assume ⟨a₁, ha₁, eqa₁⟩ ⟨a₂, ha₂, eqa₂⟩,
         match s.property _ _ ha₁ ha₂ with
         | ⟨b, bmem, ha₁b, ha₂b⟩ :=
           ⟨_, ⟨_, bmem, rfl⟩, eq.rec_on eqa₁ (h_monotone ha₁b), eq.rec_on eqa₂ (h_monotone ha₂b)⟩
         end,
   ⟨ _, pr_dir,
     take s,
     le_antisymm
       (begin
        apply sup_le,
        {
            rw f.2.preserve_dSup,
            apply dSup_le,
            intros b hb,
            cases hb with a ha,
            cases ha with ha eqab,
            rw -eqab,
            apply le_dSup_of_le,
              exact ⟨_ , ha, rfl⟩,
            apply le_sup_left
        },
        {
            rw g.2.preserve_dSup,
            apply dSup_le,
            intros b hb,
            cases hb with a ha,
            cases ha with ha eqab,
            rw -eqab,
            apply le_dSup_of_le,
            exact ⟨_ , ha, rfl⟩,
            apply le_sup_right
        }
        end)
       (dSup_le (take b,
         assume ⟨a, ha, eqa⟩,
         begin
         rw -eqa,
         apply h_monotone,
         apply le_dSup,
         assumption
         end
         ))
   ⟩

instance : has_sup (scott_continuous α β) := ⟨scott_continuous.sup⟩
protected
lemma le_sup_left (f g : scott_continuous α β) : f ≤ f ⊔ g :=
  take a, le_sup_left

protected
lemma le_sup_right (f g : scott_continuous α β) : g ≤ f ⊔ g :=
  take a, le_sup_right

protected
lemma sup_le (f g h : scott_continuous α β) : f ≤ h → g ≤ h → f ⊔ g ≤ h :=
  assume hfh hgh, take a, sup_le (hfh a) (hgh a)

instance scott_continuous_semilattice_sup : semilattice_sup (scott_continuous α β) :=
{
    le := scott_continuous.le,
    le_refl := scott_continuous.le_refl,
    le_trans := scott_continuous.le_trans,
    le_antisymm := scott_continuous.le_antisymm,
    sup := scott_continuous.sup,
    le_sup_left := scott_continuous.le_sup_left,
    le_sup_right := scott_continuous.le_sup_right,
    sup_le := scott_continuous.sup_le
}
-/
def sapply (f : scott_continuous α β) (s : directed α) : directed β := ⟨_, f.2.preserve_directed s⟩

protected
def dSup (fs : directed (scott_continuous α β)) : scott_continuous α β :=
  let s := λ a : α, {b : β | ∃ f : scott_continuous α β, f ∈ fs ∧ b = f.1 a} in
  have s_directed : ∀ a, is_directed (s a), from
    take a b₁ b₂, assume ⟨f₁, hf₁, eqb₁⟩  ⟨f₂, hf₂, eqb₂⟩,
      match fs.property _ _ hf₁ hf₂ with
      | ⟨f, hf, hf₁f, hf₂f⟩ := ⟨_, ⟨_, hf, rfl⟩,
          eq.rec_on eqb₁.symm (hf₁f _), eq.rec_on eqb₂.symm (hf₂f _)⟩
      end,
  let sup_fs := λ a : α, dSup ⟨_, s_directed a⟩ in
  have sup_fs_monotone : monotone sup_fs, from
     take a₁ a₂, assume h, dSup_le (take b, assume ⟨f, hf, eqf⟩, le_dSup_of_le ⟨_, hf, rfl⟩ (eq.rec_on eqf.symm (f.monotone h))),
  have pr_dir : ∀ s : directed α, is_directed (set.image sup_fs s.1),
    from take s, take b₁ b₂, assume ⟨a₁, ha₁, eqb₁⟩ ⟨a₂, ha₂, eqb₂⟩,
       match s.property _ _ ha₁ ha₂ with
       | ⟨a, ha, ha₁a, ha₂a⟩ := ⟨_, ⟨_, ha, rfl⟩,
         eq.rec_on eqb₁ (sup_fs_monotone ha₁a), eq.rec_on eqb₂ (sup_fs_monotone ha₂a)⟩
       end,
  ⟨_, pr_dir,
   take s,
     le_antisymm
       (dSup_le (take b, assume ⟨f, hf, eqf⟩,
        begin
        rw eqf,
        rw f.2.preserve_dSup,
        apply dSup_le,
        intros b hb,
        cases hb with a ha,
        cases ha with ha eqa,
        rw -eqa,
        apply le_dSup_of_le,
        exact ⟨_, ha, rfl⟩,
        apply le_dSup,
        exact ⟨_, hf, rfl⟩
        end
       ))
       (dSup_le (take b, assume ⟨a, ha, eqa⟩, eq.rec_on eqa (sup_fs_monotone (le_dSup ha) ) ))⟩

protected
lemma le_dSup (fs : directed (scott_continuous α β))(f : scott_continuous α β) : f ∈ fs → f ≤ scott_continuous.dSup fs :=
 assume hf, take a, le_dSup ⟨_, hf, rfl⟩

protected
lemma dSup_le (fs : directed (scott_continuous α β)) (f : scott_continuous α β) : (∀ g ∈ fs, g ≤ f) → scott_continuous.dSup fs ≤ f :=
  assume h, take a, dSup_le (take b, assume ⟨g, hg, eqg⟩, eq.rec_on eqg.symm (h _ hg _))

@[simp]
lemma is_strict (f : scott_continuous α β) : f.1 ⊥ = ⊥ := f.property.is_strict

end scott_continuous

instance scott_continuous_function [directed_complete_partial_order α][directed_complete_partial_order β] :
         has_coe (scott_continuous α β) (α → β) := ⟨ λ f, f.1 ⟩

instance scott_continuous_dcpo [directed_complete_partial_order α][directed_complete_partial_order β]
 : directed_complete_partial_order (scott_continuous α β) :=
 {
     scott_continuous.scott_continuous_weak_order with
     dSup := scott_continuous.dSup,
     le_dSup := scott_continuous.le_dSup,
     dSup_le := scott_continuous.dSup_le
 }

 -- fixedpoints
section
variables [directed_complete_partial_order α] [directed_complete_partial_order β]

lemma monotone_preserve_directed {f : α → β} : monotone f → ∀ s : directed α, is_directed (set.image f s.1) :=
begin
intros hmono s b₁ b₂ hb₁ hb₂,
cases hb₁ with a₁ ha₁,
cases ha₁ with ha₁ eqb₁,
cases hb₂ with a₂  ha₂,
cases ha₂ with ha₂ eqb₂,
rw [-eqb₁, -eqb₂],
cases s.property _ _ ha₁ ha₂ with a ha,
cases ha with ha h,
cases h with ha₁a ha₂a,
exact ⟨_, ⟨_, ha, rfl⟩, hmono ha₁a, hmono ha₂a⟩
end

def directed.map {f : α → β} : monotone f → directed α → directed β := assume hmono, take s, ⟨_, monotone_preserve_directed hmono s⟩

lemma monotone_dSup {f : α → β} (hmono : monotone f) : ∀ {{s : directed α}}, dSup (directed.map hmono s) ≤ f (dSup s)
:=
begin
intro s,
apply dSup_le,
intros b hb,
cases hb with a ha,
cases ha with ha eqa,
rw -eqa,
apply hmono,
apply le_dSup,
assumption
end

lemma ascending_chain_dSup {seq : ascending_chain α} :
  dSup (directed.of_ascending_chain seq) ∈ seq ↔ seq.is_stationary :=
  ⟨ assume ⟨n, eqn⟩ , ⟨n, take m, assume hnm : n ≤ m, le_antisymm (seq.monotone hnm) (eq.rec_on eqn (le_dSup ⟨_, rfl⟩ ))⟩ ,
    assume ⟨n, hn ⟩ , ⟨n, le_antisymm
                 (dSup_le (take b, assume ⟨m, hm⟩, eq.rec_on hm.symm (or.elim (le_total n m)
                     (assume h : n ≤ m, eq.rec_on (hn _ h) (le_refl _))
                     (seq.monotone))))
                 (le_dSup ⟨_, rfl⟩) ⟩ ⟩
end
namespace monotone
variables [directed_complete_partial_order α] [directed_complete_partial_order β]

def ascending_chain {α} [order_bot α] {f : α → α} : monotone f → ascending_chain α := assume hmono, iter_n.to_ascending_chain hmono bot_le

def lfp {f : α → α} : monotone f → α :=  assume hmono, dSup (directed.of_ascending_chain (ascending_chain hmono))

lemma lfp_le {f : α → α} (hmono : monotone f) : hmono.lfp ≤ f hmono.lfp :=
 begin
   apply dSup_le,
   intros b hb,
   cases hb with n hn,
   rw hn,
   cases n with n,
   apply bot_le,
   apply hmono,
   apply le_dSup,
   exact ⟨_, rfl⟩
 end

lemma le_lfp {f : α → α} (hmono : monotone f) :
    hmono.ascending_chain.is_stationary →
    f hmono.lfp ≤  hmono.lfp :=
 begin
  intro hst,
  rw -ascending_chain_dSup at hst,
  apply le_dSup,
  cases hst with n hn,
  assert H : hmono.lfp = iter_n f ⊥ n, apply hn,
  rw H,
  exact ⟨n+1, rfl⟩
 end

lemma lfp_eq {f : α → α} (hmono : monotone f) : hmono.ascending_chain.is_stationary → hmono.lfp = f hmono.lfp
:= assume hst, le_antisymm (lfp_le hmono) (le_lfp hmono hst)

end monotone

def fixed_point (f : α → α) : set α := { x | x = f x }

namespace scott_continuous
variables [directed_complete_partial_order α]

def lfp (f : scott_continuous α α) : α := f.monotone.lfp

variable {f : scott_continuous α α}

lemma lfp_le : f.lfp ≤ f.1 f.lfp :=
    begin
    unfold lfp,
    unfold monotone.lfp,
    rw f.2.preserve_dSup,
    apply dSup_le,
    intros a ha,
    cases ha with n hn,
    rw hn,
    cases n with n,
    apply bot_le,
    apply le_dSup,
    exact ⟨_, ⟨n, rfl⟩, rfl⟩
    end

lemma le_lfp : f.1 f.lfp ≤ f.lfp :=
   begin
   unfold lfp, unfold monotone.lfp,
   rw f.2.preserve_dSup,
   apply dSup_le_dSup,
   intros a ha,
   cases ha with a₁ ha₁,
   rw -ha₁.right,
   cases ha₁.left with n hn,
   rw hn,
   exact ⟨n+1, rfl⟩
   end

lemma lfp_eq : f.lfp = f.1 f.lfp := le_antisymm lfp_le le_lfp

lemma lfp_fixed_point : lfp f ∈ fixed_point f.1 := lfp_eq

lemma lfp_least : ∀ x ∈ fixed_point f.1, lfp f ≤ x :=
  take x, assume xeq, dSup_le
     (take a, assume ⟨n, hn⟩, eq.rec_on hn.symm
        (nat.rec_on n bot_le (λ n iH, eq.rec_on xeq.symm (f.monotone iH)) ))
end scott_continuous


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.n_ary
import data.set.sups

/-!
# Set family operations

This file defines a few binary operations on `finset α` for use in set family combinatorics.

## Main declarations

* `s ⊻ t`: Finset of elements of the form `a ⊔ b` where `a ∈ s`, `b ∈ t`.
* `s ⊼ t`: Finset of elements of the form `a ⊓ b` where `a ∈ s`, `b ∈ t`.
* `finset.disj_sups s t`: Finset of elements of the form `a ⊔ b` where `a ∈ s`, `b ∈ t` and `a`
  and `b` are disjoint.

## Notation

We define the following notation in locale `finset_family`:
* `s ⊻ t`
* `s ⊼ t`
* `s ○ t` for `finset.disj_sups s t`

## References

[B. Bollobás, *Combinatorics*][bollobas1986]
-/

open function
open_locale set_family

variables {α : Type*} [decidable_eq α]

namespace finset
section sups
variables [semilattice_sup α] (s s₁ s₂ t t₁ t₂ u v : finset α)

/-- `s ⊻ t` is the finset of elements of the form `a ⊔ b` where `a ∈ s`, `b ∈ t`. -/
protected def has_sups : has_sups (finset α) := ⟨image₂ (⊔)⟩

localized "attribute [instance] finset.has_sups" in finset_family

variables {s t} {a b c : α}

@[simp] lemma mem_sups : c ∈ s ⊻ t ↔ ∃ (a ∈ s) (b ∈ t), a ⊔ b = c := by simp [(⊻)]

variables (s t)

@[simp, norm_cast] lemma coe_sups : (↑(s ⊻ t) : set α) = s ⊻ t := coe_image₂ _ _ _

lemma card_sups_le : (s ⊻ t).card ≤ s.card * t.card := card_image₂_le _ _ _

lemma card_sups_iff :
  (s ⊻ t).card = s.card * t.card ↔ (s ×ˢ t : set (α × α)).inj_on (λ x, x.1 ⊔ x.2) :=
card_image₂_iff

variables {s s₁ s₂ t t₁ t₂ u}

lemma sup_mem_sups : a ∈ s → b ∈ t → a ⊔ b ∈ s ⊻ t := mem_image₂_of_mem
lemma sups_subset : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ ⊻ t₁ ⊆ s₂ ⊻ t₂ := image₂_subset
lemma sups_subset_left : t₁ ⊆ t₂ → s ⊻ t₁ ⊆ s ⊻ t₂ := image₂_subset_left
lemma sups_subset_right : s₁ ⊆ s₂ → s₁ ⊻ t ⊆ s₂ ⊻ t := image₂_subset_right

lemma image_subset_sups_left : b ∈ t → s.image (λ a, a ⊔ b) ⊆ s ⊻ t := image_subset_image₂_left
lemma image_subset_sups_right : a ∈ s → t.image ((⊔) a) ⊆ s ⊻ t := image_subset_image₂_right

lemma forall_sups_iff {p : α → Prop} : (∀ c ∈ s ⊻ t, p c) ↔ ∀ (a ∈ s) (b ∈ t), p (a ⊔ b) :=
forall_image₂_iff

@[simp] lemma sups_subset_iff : s ⊻ t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), a ⊔ b ∈ u := image₂_subset_iff

@[simp] lemma sups_nonempty : (s ⊻ t).nonempty ↔ s.nonempty ∧ t.nonempty := image₂_nonempty_iff

protected lemma nonempty.sups : s.nonempty → t.nonempty → (s ⊻ t).nonempty := nonempty.image₂
lemma nonempty.of_sups_left : (s ⊻ t).nonempty → s.nonempty := nonempty.of_image₂_left
lemma nonempty.of_sups_right : (s ⊻ t).nonempty → t.nonempty := nonempty.of_image₂_right

@[simp] lemma empty_sups : ∅ ⊻ t = ∅ := image₂_empty_left
@[simp] lemma sups_empty : s ⊻ ∅ = ∅ := image₂_empty_right
@[simp] lemma sups_eq_empty : s ⊻ t = ∅ ↔ s = ∅ ∨ t = ∅ := image₂_eq_empty_iff

@[simp] lemma singleton_sups : {a} ⊻ t = t.image (λ b, a ⊔ b) := image₂_singleton_left
@[simp] lemma sups_singleton : s ⊻ {b} = s.image (λ a, a ⊔ b) := image₂_singleton_right

lemma singleton_sups_singleton : ({a} ⊻ {b} : finset α) = {a ⊔ b} := image₂_singleton

lemma sups_union_left : (s₁ ∪ s₂) ⊻ t = s₁ ⊻ t ∪ s₂ ⊻ t := image₂_union_left
lemma sups_union_right : s ⊻ (t₁ ∪ t₂) = s ⊻ t₁ ∪ s ⊻ t₂ := image₂_union_right

lemma sups_inter_subset_left : (s₁ ∩ s₂) ⊻ t ⊆ s₁ ⊻ t ∩ s₂ ⊻ t := image₂_inter_subset_left
lemma sups_inter_subset_right : s ⊻ (t₁ ∩ t₂) ⊆ s ⊻ t₁ ∩ s ⊻ t₂ := image₂_inter_subset_right

lemma subset_sups {s t : set α} :
  ↑u ⊆ s ⊻ t → ∃ s' t' : finset α, ↑s' ⊆ s ∧ ↑t' ⊆ t ∧ u ⊆ s' ⊻ t' :=
subset_image₂

variables (s t u v)

lemma bUnion_image_sup_left : s.bUnion (λ a, t.image $ (⊔) a) = s ⊻ t := bUnion_image_left
lemma bUnion_image_sup_right : t.bUnion (λ b, s.image $ λ a, a ⊔ b) = s ⊻ t := bUnion_image_right

@[simp]

lemma sups_assoc : (s ⊻ t) ⊻ u = s ⊻ (t ⊻ u) := image₂_assoc $ λ _ _ _, sup_assoc
lemma sups_comm : s ⊻ t = t ⊻ s := image₂_comm $ λ _ _, sup_comm
lemma sups_left_comm : s ⊻ (t ⊻ u) = t ⊻ (s ⊻ u) := image₂_left_comm sup_left_comm
lemma sups_right_comm : (s ⊻ t) ⊻ u = (s ⊻ u) ⊻ t := image₂_right_comm sup_right_comm
lemma sups_sups_sups_comm : (s ⊻ t) ⊻ (u ⊻ v) = (s ⊻ u) ⊻ (t ⊻ v) :=
image₂_image₂_image₂_comm sup_sup_sup_comm

end sups

section infs
variables [semilattice_inf α] (s s₁ s₂ t t₁ t₂ u v : finset α)

/-- `s ⊼ t` is the finset of elements of the form `a ⊓ b` where `a ∈ s`, `b ∈ t`. -/
protected def has_infs : has_infs (finset α) := ⟨image₂ (⊓)⟩

localized "attribute [instance] finset.has_infs" in finset_family

variables {s t} {a b c : α}

@[simp] lemma mem_infs : c ∈ s ⊼ t ↔ ∃ (a ∈ s) (b ∈ t), a ⊓ b = c := by simp [(⊼)]

variables (s t)

@[simp, norm_cast] lemma coe_infs : (↑(s ⊼ t) : set α) = s ⊼ t := coe_image₂ _ _ _

lemma card_infs_le : (s ⊼ t).card ≤ s.card * t.card := card_image₂_le _ _ _

lemma card_infs_iff :
  (s ⊼ t).card = s.card * t.card ↔ (s ×ˢ t : set (α × α)).inj_on (λ x, x.1 ⊓ x.2) :=
card_image₂_iff

variables {s s₁ s₂ t t₁ t₂ u}

lemma inf_mem_infs : a ∈ s → b ∈ t → a ⊓ b ∈ s ⊼ t := mem_image₂_of_mem
lemma infs_subset : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ ⊼ t₁ ⊆ s₂ ⊼ t₂ := image₂_subset
lemma infs_subset_left : t₁ ⊆ t₂ → s ⊼ t₁ ⊆ s ⊼ t₂ := image₂_subset_left
lemma infs_subset_right : s₁ ⊆ s₂ → s₁ ⊼ t ⊆ s₂ ⊼ t := image₂_subset_right

lemma image_subset_infs_left : b ∈ t → s.image (λ a, a ⊓ b) ⊆ s ⊼ t := image_subset_image₂_left
lemma image_subset_infs_right : a ∈ s → t.image ((⊓) a) ⊆ s ⊼ t := image_subset_image₂_right

lemma forall_infs_iff {p : α → Prop} : (∀ c ∈ s ⊼ t, p c) ↔ ∀ (a ∈ s) (b ∈ t), p (a ⊓ b) :=
forall_image₂_iff

@[simp] lemma infs_subset_iff : s ⊼ t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), a ⊓ b ∈ u := image₂_subset_iff

@[simp] lemma infs_nonempty : (s ⊼ t).nonempty ↔ s.nonempty ∧ t.nonempty := image₂_nonempty_iff

protected lemma nonempty.infs : s.nonempty → t.nonempty → (s ⊼ t).nonempty := nonempty.image₂
lemma nonempty.of_infs_left : (s ⊼ t).nonempty → s.nonempty := nonempty.of_image₂_left
lemma nonempty.of_infs_right : (s ⊼ t).nonempty → t.nonempty := nonempty.of_image₂_right

@[simp] lemma empty_infs : ∅ ⊼ t = ∅ := image₂_empty_left
@[simp] lemma infs_empty : s ⊼ ∅ = ∅ := image₂_empty_right
@[simp] lemma infs_eq_empty : s ⊼ t = ∅ ↔ s = ∅ ∨ t = ∅ := image₂_eq_empty_iff

@[simp] lemma singleton_infs : {a} ⊼ t = t.image (λ b, a ⊓ b) := image₂_singleton_left
@[simp] lemma infs_singleton : s ⊼ {b} = s.image (λ a, a ⊓ b) := image₂_singleton_right

lemma singleton_infs_singleton : ({a} ⊼ {b} : finset α) = {a ⊓ b} := image₂_singleton

lemma infs_union_left : (s₁ ∪ s₂) ⊼ t = s₁ ⊼ t ∪ s₂ ⊼ t := image₂_union_left
lemma infs_union_right : s ⊼ (t₁ ∪ t₂) = s ⊼ t₁ ∪ s ⊼ t₂ := image₂_union_right

lemma infs_inter_subset_left : (s₁ ∩ s₂) ⊼ t ⊆ s₁ ⊼ t ∩ s₂ ⊼ t := image₂_inter_subset_left
lemma infs_inter_subset_right : s ⊼ (t₁ ∩ t₂) ⊆ s ⊼ t₁ ∩ s ⊼ t₂ := image₂_inter_subset_right

lemma subset_infs {s t : set α} :
  ↑u ⊆ s ⊼ t → ∃ s' t' : finset α, ↑s' ⊆ s ∧ ↑t' ⊆ t ∧ u ⊆ s' ⊼ t' :=
subset_image₂

variables (s t u v)

lemma bUnion_image_inf_left : s.bUnion (λ a, t.image $ (⊓) a) = s ⊼ t := bUnion_image_left
lemma bUnion_image_inf_right : t.bUnion (λ b, s.image $ λ a, a ⊓ b) = s ⊼ t := bUnion_image_right

@[simp] lemma image_inf_product (s t : finset α) : (s ×ˢ t).image (uncurry (⊓)) = s ⊼ t :=
image_uncurry_product _ _ _

lemma infs_assoc : (s ⊼ t) ⊼ u = s ⊼ (t ⊼ u) := image₂_assoc $ λ _ _ _, inf_assoc
lemma infs_comm : s ⊼ t = t ⊼ s := image₂_comm $ λ _ _, inf_comm
lemma infs_left_comm : s ⊼ (t ⊼ u) = t ⊼ (s ⊼ u) := image₂_left_comm inf_left_comm
lemma infs_right_comm : (s ⊼ t) ⊼ u = (s ⊼ u) ⊼ t := image₂_right_comm inf_right_comm
lemma infs_infs_infs_comm : (s ⊼ t) ⊼ (u ⊼ v) = (s ⊼ u) ⊼ (t ⊼ v) :=
image₂_image₂_image₂_comm inf_inf_inf_comm

end infs

open_locale finset_family

section distrib_lattice
variables [distrib_lattice α] (s t u : finset α)

lemma sups_infs_subset_left : s ⊻ (t ⊼ u) ⊆ (s ⊻ t) ⊼ (s ⊻ u) :=
image₂_distrib_subset_left $ λ _ _ _, sup_inf_left

lemma sups_infs_subset_right : (t ⊼ u) ⊻ s ⊆ (t ⊻ s) ⊼ (u ⊻ s) :=
image₂_distrib_subset_right $ λ _ _ _, sup_inf_right

lemma infs_sups_subset_left : s ⊼ (t ⊻ u) ⊆ (s ⊼ t) ⊻ (s ⊼ u) :=
image₂_distrib_subset_left $ λ _ _ _, inf_sup_left

lemma infs_sups_subset_right : (t ⊻ u) ⊼ s ⊆ (t ⊼ s) ⊻ (u ⊼ s) :=
image₂_distrib_subset_right $ λ _ _ _, inf_sup_right

end distrib_lattice

section disj_sups
variables [semilattice_sup α] [order_bot α] [@decidable_rel α disjoint]
  (s s₁ s₂ t t₁ t₂ u : finset α)

/-- The finset of elements of the form `a ⊔ b` where `a ∈ s`, `b ∈ t` and `a` and `b` are disjoint.
-/
def disj_sups : finset α :=
((s ×ˢ t).filter $ λ ab : α × α, disjoint ab.1 ab.2).image $ λ ab, ab.1 ⊔ ab.2

localized "infix (name := finset.disj_sups) ` ○ `:74 := finset.disj_sups" in finset_family

variables {s t u} {a b c : α}

@[simp] lemma mem_disj_sups : c ∈ s ○ t ↔ ∃ (a ∈ s) (b ∈ t), disjoint a b ∧ a ⊔ b = c :=
by simp [disj_sups, and_assoc]

lemma disj_sups_subset_sups : s ○ t ⊆ s ⊻ t :=
begin
  simp_rw [subset_iff, mem_sups, mem_disj_sups],
  exact λ c ⟨a, b, ha, hb, h, hc⟩, ⟨a, b, ha, hb, hc⟩,
end

variables (s t)

lemma card_disj_sups_le : (s ○ t).card ≤ s.card * t.card :=
(card_le_of_subset disj_sups_subset_sups).trans $ card_sups_le _ _

variables {s s₁ s₂ t t₁ t₂ u}

lemma disj_sups_subset (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) : s₁ ○ t₁ ⊆ s₂ ○ t₂ :=
image_subset_image $ filter_subset_filter _ $ product_subset_product hs ht

lemma disj_sups_subset_left (ht : t₁ ⊆ t₂) : s ○ t₁ ⊆ s ○ t₂ := disj_sups_subset subset.rfl ht
lemma disj_sups_subset_right (hs : s₁ ⊆ s₂) : s₁ ○ t ⊆ s₂ ○ t := disj_sups_subset hs subset.rfl

lemma forall_disj_sups_iff {p : α → Prop} :
  (∀ c ∈ s ○ t, p c) ↔ ∀ (a ∈ s) (b ∈ t), disjoint a b → p (a ⊔ b) :=
begin
  simp_rw mem_disj_sups,
  refine ⟨λ h a ha b hb hab, h _ ⟨_, ha, _, hb, hab, rfl⟩, _⟩,
  rintro h _ ⟨a, ha, b, hb, hab, rfl⟩,
  exact h _ ha _ hb hab,
end

@[simp] lemma disj_sups_subset_iff : s ○ t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), disjoint a b → a ⊔ b ∈ u :=
forall_disj_sups_iff

lemma nonempty.of_disj_sups_left : (s ○ t).nonempty → s.nonempty :=
by { simp_rw [finset.nonempty, mem_disj_sups], exact λ ⟨_, a, ha, _⟩, ⟨a, ha⟩ }

lemma nonempty.of_disj_sups_right : (s ○ t).nonempty → t.nonempty :=
by { simp_rw [finset.nonempty, mem_disj_sups], exact λ ⟨_, _, _, b, hb, _⟩, ⟨b, hb⟩ }

@[simp] lemma disj_sups_empty_left : ∅ ○ t = ∅ := by simp [disj_sups]
@[simp] lemma disj_sups_empty_right : s ○ ∅ = ∅ := by simp [disj_sups]

lemma disj_sups_singleton : ({a} ○ {b} : finset α) = if disjoint a b then {a ⊔ b} else ∅ :=
by split_ifs; simp [disj_sups, filter_singleton, h]

lemma disj_sups_union_left : (s₁ ∪ s₂) ○ t = s₁ ○ t ∪ s₂ ○ t :=
by simp [disj_sups, filter_union, image_union]
lemma disj_sups_union_right : s ○ (t₁ ∪ t₂) = s ○ t₁ ∪ s ○ t₂ :=
by simp [disj_sups, filter_union, image_union]

lemma disj_sups_inter_subset_left : (s₁ ∩ s₂) ○ t ⊆ s₁ ○ t ∩ s₂ ○ t :=
by simpa only [disj_sups, inter_product, filter_inter_distrib] using image_inter_subset _ _ _
lemma disj_sups_inter_subset_right : s ○ (t₁ ∩ t₂) ⊆ s ○ t₁ ∩ s ○ t₂ :=
by simpa only [disj_sups, product_inter, filter_inter_distrib] using image_inter_subset _ _ _

variables (s t)

lemma disj_sups_comm : s ○ t = t ○ s :=
by { ext, rw [mem_disj_sups, exists₂_comm], simp [sup_comm, disjoint.comm] }

end disj_sups

open_locale finset_family

section distrib_lattice
variables [distrib_lattice α] [order_bot α] [@decidable_rel α disjoint] (s t u v : finset α)

lemma disj_sups_assoc : ∀ s t u : finset α, (s ○ t) ○ u = s ○ (t ○ u) :=
begin
  refine associative_of_commutative_of_le disj_sups_comm _,
  simp only [le_eq_subset, disj_sups_subset_iff, mem_disj_sups],
  rintro s t u _ ⟨a, ha, b, hb, hab, rfl⟩ c hc habc,
  rw disjoint_sup_left at habc,
  exact ⟨a, ha, _, ⟨b, hb, c, hc, habc.2, rfl⟩, hab.sup_right habc.1, sup_assoc.symm⟩,
end

lemma disj_sups_left_comm : s ○ (t ○ u) = t ○ (s ○ u) :=
by simp_rw [←disj_sups_assoc, disj_sups_comm s]

lemma disj_sups_right_comm : (s ○ t) ○ u = (s ○ u) ○ t :=
by simp_rw [disj_sups_assoc, disj_sups_comm]

lemma disj_sups_disj_sups_disj_sups_comm : (s ○ t) ○ (u ○ v) = (s ○ u) ○ (t ○ v) :=
by simp_rw [←disj_sups_assoc, disj_sups_right_comm]

end distrib_lattice
end finset


/-
Collection of nat.sqrt lemmas
Author: Adrián Doña Mateo

These were contributed to mathlib in
[#5155](https://github.com/leanprover-community/mathlib/pull/5155/).

An apostrophe was added at the end of the names to avoid clashes.
-/

import data.nat.sqrt

-- These lemmas were added to src/data/nat/sqrt.lean.
namespace nat

theorem sqrt_mul_sqrt_lt_succ' (n : ℕ) : sqrt n * sqrt n < n + 1 :=
lt_succ_iff.mpr (sqrt_le _)

theorem succ_le_succ_sqrt' (n : ℕ) : n + 1 ≤ (sqrt n + 1) * (sqrt n + 1) :=
le_of_pred_lt (lt_succ_sqrt _)

/-- There are no perfect squares strictly between m² and (m+1)² -/
theorem not_exists_sq' {n m : ℕ} (hl : m * m < n) (hr : n < (m + 1) * (m + 1)) :
  ¬ ∃ t, t * t = n :=
begin
  rintro ⟨t, rfl⟩,
  have h1 : m < t, from nat.mul_self_lt_mul_self_iff.mpr hl,
  have h2 : t < m + 1, from nat.mul_self_lt_mul_self_iff.mpr hr,
  exact (not_lt_of_ge $ le_of_lt_succ h2) h1
end

end nat