/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
import data.list.erase_dup
import data.list.lattice
import data.list.permutation
import data.list.zip
import logic.relation

/-!
# List Permutations

This file introduces the `list.perm` relation, which is true if two lists are permutations of one
another.

## Notation

The notation `~` is used for permutation equivalence.
-/

open_locale nat

universes uu vv

namespace list
variables {α : Type uu} {β : Type vv}

/-- `perm l₁ l₂` or `l₁ ~ l₂` asserts that `l₁` and `l₂` are permutations
  of each other. This is defined by induction using pairwise swaps. -/
inductive perm : list α → list α → Prop
| nil   : perm [] []
| cons  : Π (x : α) {l₁ l₂ : list α}, perm l₁ l₂ → perm (x::l₁) (x::l₂)
| swap  : Π (x y : α) (l : list α), perm (y::x::l) (x::y::l)
| trans : Π {l₁ l₂ l₃ : list α}, perm l₁ l₂ → perm l₂ l₃ → perm l₁ l₃

open perm (swap)

infix ` ~ `:50 := perm

@[refl] protected theorem perm.refl : ∀ (l : list α), l ~ l
| []      := perm.nil
| (x::xs) := (perm.refl xs).cons x

@[symm] protected theorem perm.symm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₂ ~ l₁ :=
perm.rec_on p
  perm.nil
  (λ x l₁ l₂ p₁ r₁, r₁.cons x)
  (λ x y l, swap y x l)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, r₂.trans r₁)

theorem perm_comm {l₁ l₂ : list α} : l₁ ~ l₂ ↔ l₂ ~ l₁ := ⟨perm.symm, perm.symm⟩

theorem perm.swap'
  (x y : α) {l₁ l₂ : list α} (p : l₁ ~ l₂) : y::x::l₁ ~ x::y::l₂ :=
(swap _ _ _).trans ((p.cons _).cons _)

attribute [trans] perm.trans

theorem perm.eqv (α) : equivalence (@perm α) :=
mk_equivalence (@perm α) (@perm.refl α) (@perm.symm α) (@perm.trans α)

instance is_setoid (α) : setoid (list α) :=
setoid.mk (@perm α) (perm.eqv α)

theorem perm.subset {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₁ ⊆ l₂ :=
λ a, perm.rec_on p
  (λ h, h)
  (λ x l₁ l₂ p₁ r₁ i, or.elim i
    (λ ax, by simp [ax])
    (λ al₁, or.inr (r₁ al₁)))
  (λ x y l ayxl, or.elim ayxl
    (λ ay, by simp [ay])
    (λ axl, or.elim axl
      (λ ax, by simp [ax])
      (λ al, or.inr (or.inr al))))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ ainl₁, r₂ (r₁ ainl₁))

theorem perm.mem_iff {a : α} {l₁ l₂ : list α} (h : l₁ ~ l₂) : a ∈ l₁ ↔ a ∈ l₂ :=
iff.intro (λ m, h.subset m) (λ m, h.symm.subset m)

theorem perm.append_right {l₁ l₂ : list α} (t₁ : list α) (p : l₁ ~ l₂) : l₁++t₁ ~ l₂++t₁ :=
perm.rec_on p
  (perm.refl ([] ++ t₁))
  (λ x l₁ l₂ p₁ r₁, r₁.cons x)
  (λ x y l, swap x y _)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, r₁.trans r₂)

theorem perm.append_left {t₁ t₂ : list α} : ∀ (l : list α), t₁ ~ t₂ → l++t₁ ~ l++t₂
| []      p := p
| (x::xs) p := (perm.append_left xs p).cons x

theorem perm.append {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁++t₁ ~ l₂++t₂ :=
(p₁.append_right t₁).trans (p₂.append_left l₂)

theorem perm.append_cons (a : α) {h₁ h₂ t₁ t₂ : list α}
  (p₁ : h₁ ~ h₂) (p₂ : t₁ ~ t₂) : h₁ ++ a::t₁ ~ h₂ ++ a::t₂ :=
p₁.append (p₂.cons a)

@[simp] theorem perm_middle {a : α} : ∀ {l₁ l₂ : list α}, l₁++a::l₂ ~ a::(l₁++l₂)
| []      l₂ := perm.refl _
| (b::l₁) l₂ := ((@perm_middle l₁ l₂).cons _).trans (swap a b _)

@[simp] theorem perm_append_singleton (a : α) (l : list α) : l ++ [a] ~ a::l :=
perm_middle.trans $ by rw [append_nil]

theorem perm_append_comm : ∀ {l₁ l₂ : list α}, (l₁++l₂) ~ (l₂++l₁)
| []     l₂ := by simp
| (a::t) l₂ := (perm_append_comm.cons _).trans perm_middle.symm

theorem concat_perm (l : list α) (a : α) : concat l a ~ a :: l :=
by simp

theorem perm.length_eq {l₁ l₂ : list α} (p : l₁ ~ l₂) : length l₁ = length l₂ :=
perm.rec_on p
  rfl
  (λ x l₁ l₂ p r, by simp[r])
  (λ x y l, by simp)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂)

theorem perm.eq_nil {l : list α} (p : l ~ []) : l = [] :=
eq_nil_of_length_eq_zero p.length_eq

theorem perm.nil_eq {l : list α} (p : [] ~ l) : [] = l :=
p.symm.eq_nil.symm

@[simp]
theorem perm_nil {l₁ : list α} : l₁ ~ [] ↔ l₁ = [] :=
⟨λ p, p.eq_nil, λ e, e ▸ perm.refl _⟩

@[simp]
theorem nil_perm {l₁ : list α} : [] ~ l₁ ↔ l₁ = [] :=
perm_comm.trans perm_nil

theorem not_perm_nil_cons (x : α) (l : list α) : ¬ [] ~ x::l
| p := by injection p.symm.eq_nil

@[simp] theorem reverse_perm : ∀ (l : list α), reverse l ~ l
| []     := perm.nil
| (a::l) := by { rw reverse_cons,
  exact (perm_append_singleton _ _).trans ((reverse_perm l).cons a) }

theorem perm_cons_append_cons {l l₁ l₂ : list α} (a : α) (p : l ~ l₁++l₂) :
  a::l ~ l₁++(a::l₂) :=
(p.cons a).trans perm_middle.symm

@[simp] theorem perm_repeat {a : α} {n : ℕ} {l : list α} : l ~ repeat a n ↔ l = repeat a n :=
⟨λ p, (eq_repeat.2
  ⟨p.length_eq.trans $ length_repeat _ _,
   λ b m, eq_of_mem_repeat $ p.subset m⟩),
 λ h, h ▸ perm.refl _⟩

@[simp] theorem repeat_perm {a : α} {n : ℕ} {l : list α} : repeat a n ~ l ↔ repeat a n = l :=
(perm_comm.trans perm_repeat).trans eq_comm

@[simp] theorem perm_singleton {a : α} {l : list α} : l ~ [a] ↔ l = [a] :=
@perm_repeat α a 1 l

@[simp] theorem singleton_perm {a : α} {l : list α} : [a] ~ l ↔ [a] = l :=
@repeat_perm α a 1 l

theorem perm.eq_singleton {a : α} {l : list α} (p : l ~ [a]) : l = [a] :=
perm_singleton.1 p

theorem perm.singleton_eq {a : α} {l : list α} (p : [a] ~ l) : [a] = l :=
p.symm.eq_singleton.symm

theorem singleton_perm_singleton {a b : α} : [a] ~ [b] ↔ a = b :=
by simp

theorem perm_cons_erase [decidable_eq α] {a : α} {l : list α} (h : a ∈ l) :
  l ~ a :: l.erase a :=
let ⟨l₁, l₂, _, e₁, e₂⟩ := exists_erase_eq h in
e₂.symm ▸ e₁.symm ▸ perm_middle

@[elab_as_eliminator] theorem perm_induction_on
    {P : list α → list α → Prop} {l₁ l₂ : list α} (p : l₁ ~ l₂)
    (h₁ : P [] [])
    (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂))
    (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (y::x::l₁) (x::y::l₂))
    (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → P l₁ l₂ → P l₂ l₃ → P l₁ l₃) :
  P l₁ l₂ :=
have P_refl : ∀ l, P l l, from
  assume l,
  list.rec_on l h₁ (λ x xs ih, h₂ x xs xs (perm.refl xs) ih),
perm.rec_on p h₁ h₂ (λ x y l, h₃ x y l l (perm.refl l) (P_refl l)) h₄

@[congr] theorem perm.filter_map (f : α → option β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  filter_map f l₁ ~ filter_map f l₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp only [filter_map], cases f x with a; simp [filter_map, IH, perm.cons] },
  { simp only [filter_map], cases f x with a; cases f y with b; simp [filter_map, swap] },
  { exact IH₁.trans IH₂ }
end

@[congr] theorem perm.map (f : α → β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  map f l₁ ~ map f l₂ :=
filter_map_eq_map f ▸ p.filter_map _

theorem perm.pmap {p : α → Prop} (f : Π a, p a → β)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) {H₁ H₂} : pmap f l₁ H₁ ~ pmap f l₂ H₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp [IH, perm.cons] },
  { simp [swap] },
  { refine IH₁.trans IH₂,
    exact λ a m, H₂ a (p₂.subset m) }
end

theorem perm.filter (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : filter p l₁ ~ filter p l₂ :=
by rw ← filter_map_eq_filter; apply s.filter_map _

theorem exists_perm_sublist {l₁ l₂ l₂' : list α}
  (s : l₁ <+ l₂) (p : l₂ ~ l₂') : ∃ l₁' ~ l₁, l₁' <+ l₂' :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂ generalizing l₁ s,
  { exact ⟨[], eq_nil_of_sublist_nil s ▸ perm.refl _, nil_sublist _⟩ },
  { cases s with _ _ _ s l₁ _ _ s,
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨l₁', p', s'.cons _ _ _⟩ },
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨x::l₁', p'.cons x, s'.cons2 _ _ _⟩ } },
  { cases s with _ _ _ s l₁ _ _ s; cases s with _ _ _ s l₁ _ _ s,
    { exact ⟨l₁, perm.refl _, (s.cons _ _ _).cons _ _ _⟩ },
    { exact ⟨x::l₁, perm.refl _, (s.cons _ _ _).cons2 _ _ _⟩ },
    { exact ⟨y::l₁, perm.refl _, (s.cons2 _ _ _).cons _ _ _⟩ },
    { exact ⟨x::y::l₁, perm.swap _ _ _, (s.cons2 _ _ _).cons2 _ _ _⟩ } },
  { exact let ⟨m₁, pm, sm⟩ := IH₁ s, ⟨r₁, pr, sr⟩ := IH₂ sm in
          ⟨r₁, pr.trans pm, sr⟩ }
end

theorem perm.sizeof_eq_sizeof [has_sizeof α] {l₁ l₂ : list α} (h : l₁ ~ l₂) :
  l₁.sizeof = l₂.sizeof :=
begin
  induction h with hd l₁ l₂ h₁₂ h_sz₁₂ a b l l₁ l₂ l₃ h₁₂ h₂₃ h_sz₁₂ h_sz₂₃,
  { refl },
  { simp only [list.sizeof, h_sz₁₂] },
  { simp only [list.sizeof, add_left_comm] },
  { simp only [h_sz₁₂, h_sz₂₃] }
end

section rel
open relator
variables {γ : Type*} {δ : Type*} {r : α → β → Prop} {p : γ → δ → Prop}

local infixr ` ∘r ` : 80 := relation.comp

lemma perm_comp_perm : (perm ∘r perm : list α → list α → Prop) = perm :=
begin
  funext a c, apply propext,
  split,
  { exact assume ⟨b, hab, hba⟩, perm.trans hab hba },
  { exact assume h, ⟨a, perm.refl a, h⟩ }
end

lemma perm_comp_forall₂ {l u v} (hlu : perm l u) (huv : forall₂ r u v) : (forall₂ r ∘r perm) l v :=
begin
  induction hlu generalizing v,
  case perm.nil { cases huv, exact ⟨[], forall₂.nil, perm.nil⟩ },
  case perm.cons : a l u hlu ih
  { cases huv with _ b _ v hab huv',
    rcases ih huv' with ⟨l₂, h₁₂, h₂₃⟩,
    exact ⟨b::l₂, forall₂.cons hab h₁₂, h₂₃.cons _⟩ },
  case perm.swap : a₁ a₂ l₁ l₂ h₂₃
  { cases h₂₃ with _ b₁ _ l₂ h₁ hr_₂₃,
    cases hr_₂₃ with _ b₂ _ l₂ h₂ h₁₂,
    exact ⟨b₂::b₁::l₂, forall₂.cons h₂ (forall₂.cons h₁ h₁₂), perm.swap _ _ _⟩ },
  case perm.trans : la₁ la₂ la₃ _ _ ih₁ ih₂
  { rcases ih₂ huv with ⟨lb₂, hab₂, h₂₃⟩,
    rcases ih₁ hab₂ with ⟨lb₁, hab₁, h₁₂⟩,
    exact ⟨lb₁, hab₁, perm.trans h₁₂ h₂₃⟩ }
end

lemma forall₂_comp_perm_eq_perm_comp_forall₂ : forall₂ r ∘r perm = perm ∘r forall₂ r :=
begin
  funext l₁ l₃, apply propext,
  split,
  { assume h, rcases h with ⟨l₂, h₁₂, h₂₃⟩,
    have : forall₂ (flip r) l₂ l₁, from h₁₂.flip ,
    rcases perm_comp_forall₂ h₂₃.symm this with ⟨l', h₁, h₂⟩,
    exact ⟨l', h₂.symm, h₁.flip⟩ },
  { exact assume ⟨l₂, h₁₂, h₂₃⟩, perm_comp_forall₂ h₁₂ h₂₃ }
end

lemma rel_perm_imp (hr : right_unique r) : (forall₂ r ⇒ forall₂ r ⇒ implies) perm perm :=
assume a b h₁ c d h₂ h,
have (flip (forall₂ r) ∘r (perm ∘r forall₂ r)) b d, from ⟨a, h₁, c, h, h₂⟩,
have ((flip (forall₂ r) ∘r forall₂ r) ∘r perm) b d,
  by rwa [← forall₂_comp_perm_eq_perm_comp_forall₂, ← relation.comp_assoc] at this,
let ⟨b', ⟨c', hbc, hcb⟩, hbd⟩ := this in
have b' = b, from right_unique_forall₂' hr hcb hbc,
this ▸ hbd

lemma rel_perm (hr : bi_unique r) : (forall₂ r ⇒ forall₂ r ⇒ (↔)) perm perm :=
assume a b hab c d hcd, iff.intro
  (rel_perm_imp hr.2 hab hcd)
  (rel_perm_imp hr.left.flip hab.flip hcd.flip)

end rel

section subperm

/-- `subperm l₁ l₂`, denoted `l₁ <+~ l₂`, means that `l₁` is a sublist of
  a permutation of `l₂`. This is an analogue of `l₁ ⊆ l₂` which respects
  multiplicities of elements, and is used for the `≤` relation on multisets. -/
def subperm (l₁ l₂ : list α) : Prop := ∃ l ~ l₁, l <+ l₂

infix ` <+~ `:50 := subperm

theorem nil_subperm {l : list α} : [] <+~ l :=
⟨[], perm.nil, by simp⟩

theorem perm.subperm_left {l l₁ l₂ : list α} (p : l₁ ~ l₂) : l <+~ l₁ ↔ l <+~ l₂ :=
suffices ∀ {l₁ l₂ : list α}, l₁ ~ l₂ → l <+~ l₁ → l <+~ l₂,
from ⟨this p, this p.symm⟩,
λ l₁ l₂ p ⟨u, pu, su⟩,
  let ⟨v, pv, sv⟩ := exists_perm_sublist su p in
  ⟨v, pv.trans pu, sv⟩

theorem perm.subperm_right {l₁ l₂ l : list α} (p : l₁ ~ l₂) : l₁ <+~ l ↔ l₂ <+~ l :=
⟨λ ⟨u, pu, su⟩, ⟨u, pu.trans p, su⟩,
 λ ⟨u, pu, su⟩, ⟨u, pu.trans p.symm, su⟩⟩

theorem sublist.subperm {l₁ l₂ : list α} (s : l₁ <+ l₂) : l₁ <+~ l₂ :=
⟨l₁, perm.refl _, s⟩

theorem perm.subperm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₁ <+~ l₂ :=
⟨l₂, p.symm, sublist.refl _⟩

@[refl] theorem subperm.refl (l : list α) : l <+~ l := (perm.refl _).subperm

@[trans] theorem subperm.trans {l₁ l₂ l₃ : list α} : l₁ <+~ l₂ → l₂ <+~ l₃ → l₁ <+~ l₃
| s ⟨l₂', p₂, s₂⟩ :=
  let ⟨l₁', p₁, s₁⟩ := p₂.subperm_left.2 s in ⟨l₁', p₁, s₁.trans s₂⟩

theorem subperm.length_le {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₁ ≤ length l₂
| ⟨l, p, s⟩ := p.length_eq ▸ length_le_of_sublist s

theorem subperm.perm_of_length_le {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₂ ≤ length l₁ → l₁ ~ l₂
| ⟨l, p, s⟩ h :=
  suffices l = l₂, from this ▸ p.symm,
  eq_of_sublist_of_length_le s $ p.symm.length_eq ▸ h

theorem subperm.antisymm {l₁ l₂ : list α} (h₁ : l₁ <+~ l₂) (h₂ : l₂ <+~ l₁) : l₁ ~ l₂ :=
h₁.perm_of_length_le h₂.length_le

theorem subperm.subset {l₁ l₂ : list α} : l₁ <+~ l₂ → l₁ ⊆ l₂
| ⟨l, p, s⟩ := subset.trans p.symm.subset s.subset

lemma subperm.filter (p : α → Prop) [decidable_pred p]
  ⦃l l' : list α⦄ (h : l <+~ l') : filter p l <+~ filter p l' :=
begin
  obtain ⟨xs, hp, h⟩ := h,
  exact ⟨_, hp.filter p, h.filter p⟩
end

end subperm

theorem sublist.exists_perm_append : ∀ {l₁ l₂ : list α}, l₁ <+ l₂ → ∃ l, l₂ ~ l₁ ++ l
| ._ ._ sublist.slnil            := ⟨nil, perm.refl _⟩
| ._ ._ (sublist.cons l₁ l₂ a s) :=
  let ⟨l, p⟩ := sublist.exists_perm_append s in
  ⟨a::l, (p.cons a).trans perm_middle.symm⟩
| ._ ._ (sublist.cons2 l₁ l₂ a s) :=
  let ⟨l, p⟩ := sublist.exists_perm_append s in
  ⟨l, p.cons a⟩

theorem perm.countp_eq (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : countp p l₁ = countp p l₂ :=
by rw [countp_eq_length_filter, countp_eq_length_filter];
   exact (s.filter _).length_eq

theorem subperm.countp_le (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} : l₁ <+~ l₂ → countp p l₁ ≤ countp p l₂
| ⟨l, p', s⟩ := p'.countp_eq p ▸ s.countp_le p

theorem perm.count_eq [decidable_eq α] {l₁ l₂ : list α}
  (p : l₁ ~ l₂) (a) : count a l₁ = count a l₂ :=
p.countp_eq _

theorem subperm.count_le [decidable_eq α] {l₁ l₂ : list α}
  (s : l₁ <+~ l₂) (a) : count a l₁ ≤ count a l₂ :=
s.countp_le _

theorem perm.foldl_eq' {f : β → α → β} {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  (∀ (x ∈ l₁) (y ∈ l₁) z, f (f z x) y = f (f z y) x) → ∀ b, foldl f b l₁ = foldl f b l₂ :=
perm_induction_on p
  (λ H b, rfl)
  (λ x t₁ t₂ p r H b, r (λ x hx y hy, H _ (or.inr hx) _ (or.inr hy)) _)
  (λ x y t₁ t₂ p r H b,
    begin
      simp only [foldl],
      rw [H x (or.inr $ or.inl rfl) y (or.inl rfl)],
      exact r (λ x hx y hy, H _ (or.inr $ or.inr hx) _ (or.inr $ or.inr hy)) _
    end)
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ H b, eq.trans (r₁ H b)
    (r₂ (λ x hx y hy, H _ (p₁.symm.subset hx) _ (p₁.symm.subset hy)) b))

theorem perm.foldl_eq {f : β → α → β} {l₁ l₂ : list α} (rcomm : right_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldl f b l₁ = foldl f b l₂ :=
p.foldl_eq' $ λ x hx y hy z, rcomm z x y

theorem perm.foldr_eq {f : α → β → β} {l₁ l₂ : list α} (lcomm : left_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldr f b l₁ = foldr f b l₂ :=
perm_induction_on p
  (λ b, rfl)
  (λ x t₁ t₂ p r b, by simp; rw [r b])
  (λ x y t₁ t₂ p r b, by simp; rw [lcomm, r b])
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ a, eq.trans (r₁ a) (r₂ a))

lemma perm.rec_heq {β : list α → Sort*} {f : Πa l, β l → β (a::l)} {b : β []} {l l' : list α}
  (hl : perm l l')
  (f_congr : ∀{a l l' b b'}, perm l l' → b == b' → f a l b == f a l' b')
  (f_swap : ∀{a a' l b}, f a (a'::l) (f a' l b) == f a' (a::l) (f a l b)) :
  @list.rec α β b f l == @list.rec α β b f l' :=
begin
  induction hl,
  case list.perm.nil { refl },
  case list.perm.cons : a l l' h ih { exact f_congr h ih },
  case list.perm.swap : a a' l { exact f_swap },
  case list.perm.trans : l₁ l₂ l₃ h₁ h₂ ih₁ ih₂ { exact heq.trans ih₁ ih₂ }
end

section
variables {op : α → α → α} [is_associative α op] [is_commutative α op]
local notation a * b := op a b
local notation l <*> a := foldl op a l

lemma perm.fold_op_eq {l₁ l₂ : list α} {a : α} (h : l₁ ~ l₂) : l₁ <*> a = l₂ <*> a :=
h.foldl_eq (right_comm _ is_commutative.comm is_associative.assoc) _
end

section comm_monoid

/-- If elements of a list commute with each other, then their product does not
depend on the order of elements-/
@[to_additive]

variable [comm_monoid α]

@[to_additive]
lemma perm.prod_eq {l₁ l₂ : list α} (h : perm l₁ l₂) : prod l₁ = prod l₂ :=
h.fold_op_eq

@[to_additive]
lemma prod_reverse (l : list α) : prod l.reverse = prod l :=
(reverse_perm l).prod_eq

end comm_monoid

theorem perm_inv_core {a : α} {l₁ l₂ r₁ r₂ : list α} : l₁++a::r₁ ~ l₂++a::r₂ → l₁++r₁ ~ l₂++r₂ :=
begin
  generalize e₁ : l₁++a::r₁ = s₁, generalize e₂ : l₂++a::r₂ = s₂,
  intro p, revert l₁ l₂ r₁ r₂ e₁ e₂,
  refine perm_induction_on p _ (λ x t₁ t₂ p IH, _) (λ x y t₁ t₂ p IH, _)
    (λ t₁ t₂ t₃ p₁ p₂ IH₁ IH₂, _); intros l₁ l₂ r₁ r₂ e₁ e₂,
  { apply (not_mem_nil a).elim, rw ← e₁, simp },
  { cases l₁ with y l₁; cases l₂ with z l₂;
      dsimp at e₁ e₂; injections; subst x,
    { substs t₁ t₂,     exact p },
    { substs z t₁ t₂,   exact p.trans perm_middle },
    { substs y t₁ t₂,   exact perm_middle.symm.trans p },
    { substs z t₁ t₂,   exact (IH rfl rfl).cons y } },
  { rcases l₁ with _|⟨y, _|⟨z, l₁⟩⟩; rcases l₂ with _|⟨u, _|⟨v, l₂⟩⟩;
      dsimp at e₁ e₂; injections; substs x y,
    { substs r₁ r₂,     exact p.cons a },
    { substs r₁ r₂,     exact p.cons u },
    { substs r₁ v t₂,   exact (p.trans perm_middle).cons u },
    { substs r₁ r₂,     exact p.cons y },
    { substs r₁ r₂ y u, exact p.cons a },
    { substs r₁ u v t₂, exact ((p.trans perm_middle).cons y).trans (swap _ _ _) },
    { substs r₂ z t₁,   exact (perm_middle.symm.trans p).cons y },
    { substs r₂ y z t₁, exact (swap _ _ _).trans ((perm_middle.symm.trans p).cons u) },
    { substs u v t₁ t₂, exact (IH rfl rfl).swap' _ _ } },
  { substs t₁ t₃,
    have : a ∈ t₂ := p₁.subset (by simp),
    rcases mem_split this with ⟨l₂, r₂, e₂⟩,
    subst t₂, exact (IH₁ rfl rfl).trans (IH₂ rfl rfl) }
end

theorem perm.cons_inv {a : α} {l₁ l₂ : list α} : a::l₁ ~ a::l₂ → l₁ ~ l₂ :=
@perm_inv_core _ _ [] [] _ _

@[simp] theorem perm_cons (a : α) {l₁ l₂ : list α} : a::l₁ ~ a::l₂ ↔ l₁ ~ l₂ :=
⟨perm.cons_inv, perm.cons a⟩

theorem perm_append_left_iff {l₁ l₂ : list α} : ∀ l, l++l₁ ~ l++l₂ ↔ l₁ ~ l₂
| []     := iff.rfl
| (a::l) := (perm_cons a).trans (perm_append_left_iff l)

theorem perm_append_right_iff {l₁ l₂ : list α} (l) : l₁++l ~ l₂++l ↔ l₁ ~ l₂ :=
⟨λ p, (perm_append_left_iff _).1 $ perm_append_comm.trans $ p.trans perm_append_comm,
 perm.append_right _⟩

theorem perm_option_to_list {o₁ o₂ : option α} : o₁.to_list ~ o₂.to_list ↔ o₁ = o₂ :=
begin
  refine ⟨λ p, _, λ e, e ▸ perm.refl _⟩,
  cases o₁ with a; cases o₂ with b, {refl},
  { cases p.length_eq },
  { cases p.length_eq },
  { exact option.mem_to_list.1 (p.symm.subset $ by simp) }
end

theorem subperm_cons (a : α) {l₁ l₂ : list α} : a::l₁ <+~ a::l₂ ↔ l₁ <+~ l₂ :=
⟨λ ⟨l, p, s⟩, begin
  cases s with _ _ _ s' u _ _ s',
  { exact (p.subperm_left.2 $ (sublist_cons _ _).subperm).trans s'.subperm },
  { exact ⟨u, p.cons_inv, s'⟩ }
end, λ ⟨l, p, s⟩, ⟨a::l, p.cons a, s.cons2 _ _ _⟩⟩

theorem cons_subperm_of_mem {a : α} {l₁ l₂ : list α} (d₁ : nodup l₁) (h₁ : a ∉ l₁) (h₂ : a ∈ l₂)
 (s : l₁ <+~ l₂) : a :: l₁ <+~ l₂ :=
begin
  rcases s with ⟨l, p, s⟩,
  induction s generalizing l₁,
  case list.sublist.slnil { cases h₂ },
  case list.sublist.cons : r₁ r₂ b s' ih
  { simp at h₂,
    cases h₂ with e m,
    { subst b, exact ⟨a::r₁, p.cons a, s'.cons2 _ _ _⟩ },
    { rcases ih m d₁ h₁ p with ⟨t, p', s'⟩, exact ⟨t, p', s'.cons _ _ _⟩ } },
  case list.sublist.cons2 : r₁ r₂ b s' ih
  { have bm : b ∈ l₁ := (p.subset $ mem_cons_self _ _),
    have am : a ∈ r₂ := h₂.resolve_left (λ e, h₁ $ e.symm ▸ bm),
    rcases mem_split bm with ⟨t₁, t₂, rfl⟩,
    have st : t₁ ++ t₂ <+ t₁ ++ b :: t₂ := by simp,
    rcases ih am (nodup_of_sublist st d₁)
      (mt (λ x, st.subset x) h₁)
      (perm.cons_inv $ p.trans perm_middle) with ⟨t, p', s'⟩,
    exact ⟨b::t, (p'.cons b).trans $ (swap _ _ _).trans (perm_middle.symm.cons a), s'.cons2 _ _ _⟩ }
end

theorem subperm_append_left {l₁ l₂ : list α} : ∀ l, l++l₁ <+~ l++l₂ ↔ l₁ <+~ l₂
| []     := iff.rfl
| (a::l) := (subperm_cons a).trans (subperm_append_left l)

theorem subperm_append_right {l₁ l₂ : list α} (l) : l₁++l <+~ l₂++l ↔ l₁ <+~ l₂ :=
(perm_append_comm.subperm_left.trans perm_append_comm.subperm_right).trans (subperm_append_left l)

theorem subperm.exists_of_length_lt {l₁ l₂ : list α} :
  l₁ <+~ l₂ → length l₁ < length l₂ → ∃ a, a :: l₁ <+~ l₂
| ⟨l, p, s⟩ h :=
  suffices length l < length l₂ → ∃ (a : α), a :: l <+~ l₂, from
  (this $ p.symm.length_eq ▸ h).imp (λ a, (p.cons a).subperm_right.1),
  begin
    clear subperm.exists_of_length_lt p h l₁, rename l₂ u,
    induction s with l₁ l₂ a s IH _ _ b s IH; intro h,
    { cases h },
    { cases lt_or_eq_of_le (nat.le_of_lt_succ h : length l₁ ≤ length l₂) with h h,
      { exact (IH h).imp (λ a s, s.trans (sublist_cons _ _).subperm) },
      { exact ⟨a, eq_of_sublist_of_length_eq s h ▸ subperm.refl _⟩ } },
    { exact (IH $ nat.lt_of_succ_lt_succ h).imp
        (λ a s, (swap _ _ _).subperm_right.1 $ (subperm_cons _).2 s) }
  end

theorem subperm_of_subset_nodup
  {l₁ l₂ : list α} (d : nodup l₁) (H : l₁ ⊆ l₂) : l₁ <+~ l₂ :=
begin
  induction d with a l₁' h d IH,
  { exact ⟨nil, perm.nil, nil_sublist _⟩ },
  { cases forall_mem_cons.1 H with H₁ H₂,
    simp at h,
    exact cons_subperm_of_mem d h H₁ (IH H₂) }
end

theorem perm_ext {l₁ l₂ : list α} (d₁ : nodup l₁) (d₂ : nodup l₂) :
  l₁ ~ l₂ ↔ ∀a, a ∈ l₁ ↔ a ∈ l₂ :=
⟨λ p a, p.mem_iff, λ H, subperm.antisymm
  (subperm_of_subset_nodup d₁ (λ a, (H a).1))
  (subperm_of_subset_nodup d₂ (λ a, (H a).2))⟩

theorem nodup.sublist_ext {l₁ l₂ l : list α} (d : nodup l)
  (s₁ : l₁ <+ l) (s₂ : l₂ <+ l) : l₁ ~ l₂ ↔ l₁ = l₂ :=
⟨λ h, begin
  induction s₂ with l₂ l a s₂ IH l₂ l a s₂ IH generalizing l₁,
  { exact h.eq_nil },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { exact IH d.2 s₁ h },
    { apply d.1.elim,
      exact subperm.subset ⟨_, h.symm, s₂⟩ (mem_cons_self _ _) } },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { apply d.1.elim,
      exact subperm.subset ⟨_, h, s₁⟩ (mem_cons_self _ _) },
    { rw IH d.2 s₁ h.cons_inv } }
end, λ h, by rw h⟩

section
variable [decidable_eq α]

-- attribute [congr]
theorem perm.erase (a : α) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  l₁.erase a ~ l₂.erase a :=
if h₁ : a ∈ l₁ then
have h₂ : a ∈ l₂, from p.subset h₁,
perm.cons_inv $ (perm_cons_erase h₁).symm.trans $ p.trans (perm_cons_erase h₂)
else
have h₂ : a ∉ l₂, from mt p.mem_iff.2 h₁,
by rw [erase_of_not_mem h₁, erase_of_not_mem h₂]; exact p

theorem subperm_cons_erase (a : α) (l : list α) : l <+~ a :: l.erase a :=
begin
  by_cases h : a ∈ l,
  { exact (perm_cons_erase h).subperm },
  { rw [erase_of_not_mem h],
    exact (sublist_cons _ _).subperm }
end

theorem erase_subperm (a : α) (l : list α) : l.erase a <+~ l :=
(erase_sublist _ _).subperm

theorem subperm.erase {l₁ l₂ : list α} (a : α) (h : l₁ <+~ l₂) : l₁.erase a <+~ l₂.erase a :=
let ⟨l, hp, hs⟩ := h in ⟨l.erase a, hp.erase _, hs.erase _⟩

theorem perm.diff_right {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) : l₁.diff t ~ l₂.diff t :=
by induction t generalizing l₁ l₂ h; simp [*, perm.erase]

theorem perm.diff_left (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l.diff t₁ = l.diff t₂ :=
by induction h generalizing l; simp [*, perm.erase, erase_comm]
  <|> exact (ih_1 _).trans (ih_2 _)

theorem perm.diff {l₁ l₂ t₁ t₂ : list α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
  l₁.diff t₁ ~ l₂.diff t₂ :=
ht.diff_left l₂ ▸ hl.diff_right _

theorem subperm.diff_right {l₁ l₂ : list α} (h : l₁ <+~ l₂) (t : list α) :
  l₁.diff t <+~ l₂.diff t :=
by induction t generalizing l₁ l₂ h; simp [*, subperm.erase]

theorem erase_cons_subperm_cons_erase (a b : α) (l : list α) :
  (a :: l).erase b <+~ a :: l.erase b :=
begin
  by_cases h : a = b,
  { subst b,
    rw [erase_cons_head],
    apply subperm_cons_erase },
  { rw [erase_cons_tail _ h] }
end

theorem subperm_cons_diff {a : α} : ∀ {l₁ l₂ : list α}, (a :: l₁).diff l₂ <+~ a :: l₁.diff l₂
| l₁ []      := ⟨a::l₁, by simp⟩
| l₁ (b::l₂) :=
begin
  simp only [diff_cons],
  refine ((erase_cons_subperm_cons_erase a b l₁).diff_right l₂).trans _,
  apply subperm_cons_diff
end

theorem subset_cons_diff {a : α} {l₁ l₂ : list α} : (a :: l₁).diff l₂ ⊆ a :: l₁.diff l₂ :=
subperm_cons_diff.subset

theorem perm.bag_inter_right {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) :
  l₁.bag_inter t ~ l₂.bag_inter t :=
begin
  induction h with x _ _ _ _ x y _ _ _ _ _ _ ih_1 ih_2 generalizing t, {simp},
  { by_cases x ∈ t; simp [*, perm.cons] },
  { by_cases x = y, {simp [h]},
    by_cases xt : x ∈ t; by_cases yt : y ∈ t,
    { simp [xt, yt, mem_erase_of_ne h, mem_erase_of_ne (ne.symm h), erase_comm, swap] },
    { simp [xt, yt, mt mem_of_mem_erase, perm.cons] },
    { simp [xt, yt, mt mem_of_mem_erase, perm.cons] },
    { simp [xt, yt] } },
  { exact (ih_1 _).trans (ih_2 _) }
end

theorem perm.bag_inter_left (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) :
  l.bag_inter t₁ = l.bag_inter t₂ :=
begin
  induction l with a l IH generalizing t₁ t₂ p, {simp},
  by_cases a ∈ t₁,
  { simp [h, p.subset h, IH (p.erase _)] },
  { simp [h, mt p.mem_iff.2 h, IH p] }
end

theorem perm.bag_inter {l₁ l₂ t₁ t₂ : list α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
  l₁.bag_inter t₁ ~ l₂.bag_inter t₂ :=
ht.bag_inter_left l₂ ▸ hl.bag_inter_right _

theorem cons_perm_iff_perm_erase {a : α} {l₁ l₂ : list α} : a::l₁ ~ l₂ ↔ a ∈ l₂ ∧ l₁ ~ l₂.erase a :=
⟨λ h, have a ∈ l₂, from h.subset (mem_cons_self a l₁),
      ⟨this, (h.trans $ perm_cons_erase this).cons_inv⟩,
 λ ⟨m, h⟩, (h.cons a).trans (perm_cons_erase m).symm⟩

theorem perm_iff_count {l₁ l₂ : list α} : l₁ ~ l₂ ↔ ∀ a, count a l₁ = count a l₂ :=
⟨perm.count_eq, λ H, begin
  induction l₁ with a l₁ IH generalizing l₂,
  { cases l₂ with b l₂, {refl},
    specialize H b, simp at H, contradiction },
  { have : a ∈ l₂ := count_pos.1 (by rw ← H; simp; apply nat.succ_pos),
    refine ((IH $ λ b, _).cons a).trans (perm_cons_erase this).symm,
    specialize H b,
    rw (perm_cons_erase this).count_eq at H,
    by_cases b = a; simp [h] at H ⊢; assumption }
end⟩

lemma subperm.cons_right {α : Type*} {l l' : list α} (x : α) (h : l <+~ l') : l <+~ x :: l' :=
h.trans (sublist_cons x l').subperm

/-- The list version of `add_tsub_cancel_of_le` for multisets. -/
lemma subperm_append_diff_self_of_count_le {l₁ l₂ : list α}
  (h : ∀ x ∈ l₁, count x l₁ ≤ count x l₂) : l₁ ++ l₂.diff l₁ ~ l₂ :=
begin
  induction l₁ with hd tl IH generalizing l₂,
  { simp },
  { have : hd ∈ l₂,
    { rw ←count_pos,
      exact lt_of_lt_of_le (count_pos.mpr (mem_cons_self _ _)) (h hd (mem_cons_self _ _)) },
    replace this : l₂ ~ hd :: l₂.erase hd := perm_cons_erase this,
    refine perm.trans _ this.symm,
    rw [cons_append, diff_cons, perm_cons],
    refine IH (λ x hx, _),
    specialize h x (mem_cons_of_mem _ hx),
    rw (perm_iff_count.mp this) at h,
    by_cases hx : x = hd,
    { subst hd,
      simpa [nat.succ_le_succ_iff] using h },
    { simpa [hx] using h } },
end

/-- The list version of `multiset.le_iff_count`. -/
lemma subperm_ext_iff {l₁ l₂ : list α} :
  l₁ <+~ l₂ ↔ ∀ x ∈ l₁, count x l₁ ≤ count x l₂ :=
begin
  refine ⟨λ h x hx, subperm.count_le h x, λ h, _⟩,
  suffices : l₁ <+~ (l₂.diff l₁ ++ l₁),
  { refine this.trans (perm.subperm _),
    exact perm_append_comm.trans (subperm_append_diff_self_of_count_le h) },
  convert (subperm_append_right _).mpr nil_subperm using 1
end

lemma subperm.cons_left {l₁ l₂ : list α} (h : l₁ <+~ l₂)
  (x : α) (hx : count x l₁ < count x l₂) :
  x :: l₁ <+~ l₂  :=
begin
  rw subperm_ext_iff at h ⊢,
  intros y hy,
  by_cases hy' : y = x,
  { subst x,
    simpa using nat.succ_le_of_lt hx },
  { rw count_cons_of_ne hy',
    refine h y _,
    simpa [hy'] using hy }
end

instance decidable_perm : ∀ (l₁ l₂ : list α), decidable (l₁ ~ l₂)
| []      []      := is_true $ perm.refl _
| []      (b::l₂) := is_false $ λ h, by have := h.nil_eq; contradiction
| (a::l₁) l₂      := by haveI := decidable_perm l₁ (l₂.erase a);
                        exact decidable_of_iff' _ cons_perm_iff_perm_erase

-- @[congr]
theorem perm.erase_dup {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  erase_dup l₁ ~ erase_dup l₂ :=
perm_iff_count.2 $ λ a,
if h : a ∈ l₁
then by simp [nodup_erase_dup, h, p.subset h]
else by simp [h, mt p.mem_iff.2 h]

-- attribute [congr]
theorem perm.insert (a : α)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) : insert a l₁ ~ insert a l₂ :=
if h : a ∈ l₁
then by simpa [h, p.subset h] using p
else by simpa [h, mt p.mem_iff.2 h] using p.cons a

theorem perm_insert_swap (x y : α) (l : list α) :
  insert x (insert y l) ~ insert y (insert x l) :=
begin
  by_cases xl : x ∈ l; by_cases yl : y ∈ l; simp [xl, yl],
  by_cases xy : x = y, { simp [xy] },
  simp [not_mem_cons_of_ne_of_not_mem xy xl,
        not_mem_cons_of_ne_of_not_mem (ne.symm xy) yl],
  constructor
end

theorem perm_insert_nth {α} (x : α) (l : list α) {n} (h : n ≤ l.length) :
  insert_nth n x l ~ x :: l :=
begin
  induction l generalizing n,
  { cases n, refl, cases h },
  cases n,
  { simp [insert_nth] },
  { simp only [insert_nth, modify_nth_tail],
    transitivity,
    { apply perm.cons, apply l_ih,
      apply nat.le_of_succ_le_succ h },
    { apply perm.swap } }
end

theorem perm.union_right {l₁ l₂ : list α} (t₁ : list α) (h : l₁ ~ l₂) : l₁ ∪ t₁ ~ l₂ ∪ t₁ :=
begin
  induction h with a _ _ _ ih _ _ _ _ _ _ _ _ ih_1 ih_2; try {simp},
  { exact ih.insert a },
  { apply perm_insert_swap },
  { exact ih_1.trans ih_2 }
end

theorem perm.union_left (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l ∪ t₁ ~ l ∪ t₂ :=
by induction l; simp [*, perm.insert]

-- @[congr]
theorem perm.union {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∪ t₁ ~ l₂ ∪ t₂ :=
(p₁.union_right t₁).trans (p₂.union_left l₂)

theorem perm.inter_right {l₁ l₂ : list α} (t₁ : list α) : l₁ ~ l₂ → l₁ ∩ t₁ ~ l₂ ∩ t₁ :=
perm.filter _

theorem perm.inter_left (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) : l ∩ t₁ = l ∩ t₂ :=
by { dsimp [(∩), list.inter], congr, funext a, rw [p.mem_iff] }

-- @[congr]
theorem perm.inter {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∩ t₁ ~ l₂ ∩ t₂ :=
p₂.inter_left l₂ ▸ p₁.inter_right t₁

theorem perm.inter_append {l t₁ t₂ : list α} (h : disjoint t₁ t₂) :
  l ∩ (t₁ ++ t₂) ~ l ∩ t₁ ++ l ∩ t₂ :=
begin
  induction l,
  case list.nil
  { simp },
  case list.cons : x xs l_ih
  { by_cases h₁ : x ∈ t₁,
    { have h₂ : x ∉ t₂ := h h₁,
      simp * },
    by_cases h₂ : x ∈ t₂,
    { simp only [*, inter_cons_of_not_mem, false_or, mem_append, inter_cons_of_mem, not_false_iff],
      transitivity,
      { apply perm.cons _ l_ih, },
      change [x] ++ xs ∩ t₁ ++ xs ∩ t₂ ~ xs ∩ t₁ ++ ([x] ++ xs ∩ t₂),
      rw [← list.append_assoc],
      solve_by_elim [perm.append_right, perm_append_comm] },
    { simp * } },
end

end

theorem perm.pairwise_iff {R : α → α → Prop} (S : symmetric R) :
  ∀ {l₁ l₂ : list α} (p : l₁ ~ l₂), pairwise R l₁ ↔ pairwise R l₂ :=
suffices ∀ {l₁ l₂}, l₁ ~ l₂ → pairwise R l₁ → pairwise R l₂, from λ l₁ l₂ p, ⟨this p, this p.symm⟩,
λ l₁ l₂ p d, begin
  induction d with a l₁ h d IH generalizing l₂,
  { rw ← p.nil_eq, constructor },
  { have : a ∈ l₂ := p.subset (mem_cons_self _ _),
    rcases mem_split this with ⟨s₂, t₂, rfl⟩,
    have p' := (p.trans perm_middle).cons_inv,
    refine (pairwise_middle S).2 (pairwise_cons.2 ⟨λ b m, _, IH _ p'⟩),
    exact h _ (p'.symm.subset m) }
end

theorem perm.nodup_iff {l₁ l₂ : list α} : l₁ ~ l₂ → (nodup l₁ ↔ nodup l₂) :=
perm.pairwise_iff $ @ne.symm α

theorem perm.bind_right {l₁ l₂ : list α} (f : α → list β) (p : l₁ ~ l₂) :
  l₁.bind f ~ l₂.bind f :=
begin
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { simp, exact IH.append_left _ },
  { simp, rw [← append_assoc, ← append_assoc], exact perm_append_comm.append_right _ },
  { exact IH₁.trans IH₂ }
end

theorem perm.bind_left (l : list α) {f g : α → list β} (h : ∀ a, f a ~ g a) :
  l.bind f ~ l.bind g :=
by induction l with a l IH; simp; exact (h a).append IH

theorem bind_append_perm (l : list α) (f g : α → list β) :
  l.bind f ++ l.bind g ~ l.bind (λ x, f x ++ g x) :=
begin
  induction l with a l IH; simp,
  refine (perm.trans _ (IH.append_left _)).append_left _,
  rw [← append_assoc, ← append_assoc],
  exact perm_append_comm.append_right _
end

theorem perm.product_right {l₁ l₂ : list α} (t₁ : list β) (p : l₁ ~ l₂) :
  product l₁ t₁ ~ product l₂ t₁ :=
p.bind_right _

theorem perm.product_left (l : list α) {t₁ t₂ : list β} (p : t₁ ~ t₂) :
  product l t₁ ~ product l t₂ :=
perm.bind_left _ $ λ a, p.map _

@[congr] theorem perm.product {l₁ l₂ : list α} {t₁ t₂ : list β}
  (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : product l₁ t₁ ~ product l₂ t₂ :=
(p₁.product_right t₁).trans (p₂.product_left l₂)

theorem sublists_cons_perm_append (a : α) (l : list α) :
  sublists (a :: l) ~ sublists l ++ map (cons a) (sublists l) :=
begin
  simp only [sublists, sublists_aux_cons_cons, cons_append, perm_cons],
  refine (perm.cons _ _).trans perm_middle.symm,
  induction sublists_aux l cons with b l IH; simp,
  exact (IH.cons _).trans perm_middle.symm
end

theorem sublists_perm_sublists' : ∀ l : list α, sublists l ~ sublists' l
| []     := perm.refl _
| (a::l) := let IH := sublists_perm_sublists' l in
  by rw sublists'_cons; exact
  (sublists_cons_perm_append _ _).trans (IH.append (IH.map _))

theorem revzip_sublists (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  apply list.reverse_rec_on l,
  { intros l₁ l₂ h, simp at h, simp [h] },
  { intros l a IH l₁ l₂ h,
    rw [sublists_concat, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [skip, {simp}],
    simp only [prod.mk.inj_iff, mem_map, mem_append, prod.map_mk, prod.exists] at h,
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩,
    { rw ← append_assoc,
      exact (IH _ _ h).append_right _ },
    { rw append_assoc,
      apply (perm_append_comm.append_left _).trans,
      rw ← append_assoc,
      exact (IH _ _ h).append_right _ } }
end

theorem revzip_sublists' (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists' → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  induction l with a l IH; intros l₁ l₂ h,
  { simp at h, simp [h] },
  { rw [sublists'_cons, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [simp at h, simp],
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', h, rfl⟩,
    { exact perm_middle.trans ((IH _ _ h).cons _) },
    { exact (IH _ _ h).cons _ } }
end

theorem perm_lookmap (f : α → option α) {l₁ l₂ : list α}
  (H : pairwise (λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d) l₁)
  (p : l₁ ~ l₂) : lookmap f l₁ ~ lookmap f l₂ :=
begin
  let F := λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { cases h : f a,
    { simp [h], exact IH (pairwise_cons.1 H).2 },
    { simp [lookmap_cons_some _ _ h, p] } },
  { cases h₁ : f a with c; cases h₂ : f b with d,
    { simp [h₁, h₂], apply swap },
    { simp [h₁, lookmap_cons_some _ _ h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, lookmap_cons_some _ _ h₂],
      rcases (pairwise_cons.1 H).1 _ (or.inl rfl) _ h₂ _ h₁ with ⟨rfl, rfl⟩,
      refl } },
  { refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff _).1 H)),
    exact λ a b h c h₁ d h₂, (h d h₂ c h₁).imp eq.symm eq.symm }
end

theorem perm.erasep (f : α → Prop) [decidable_pred f] {l₁ l₂ : list α}
  (H : pairwise (λ a b, f a → f b → false) l₁)
  (p : l₁ ~ l₂) : erasep f l₁ ~ erasep f l₂ :=
begin
  let F := λ a b, f a → f b → false,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { by_cases h : f a,
    { simp [h, p] },
    { simp [h], exact IH (pairwise_cons.1 H).2 } },
  { by_cases h₁ : f a; by_cases h₂ : f b; simp [h₁, h₂],
    { cases (pairwise_cons.1 H).1 _ (or.inl rfl) h₂ h₁ },
    { apply swap } },
  { refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff _).1 H)),
    exact λ a b h h₁ h₂, h h₂ h₁ }
end

lemma perm.take_inter {α} [decidable_eq α] {xs ys : list α} (n : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  xs.take n ~ ys.inter (xs.take n) :=
begin
  simp only [list.inter] at *,
  induction h generalizing n,
  case list.perm.nil : n
  { simp only [not_mem_nil, filter_false, take_nil] },
  case list.perm.cons : h_x h_l₁ h_l₂ h_a h_ih n
  { cases n; simp only [mem_cons_iff, true_or, eq_self_iff_true, filter_cons_of_pos,
                        perm_cons, take, not_mem_nil, filter_false],
    cases h' with _ _ h₁ h₂,
    convert h_ih h₂ n using 1,
    apply filter_congr,
    introv h, simp only [(h₁ x h).symm, false_or], },
  case list.perm.swap : h_x h_y h_l n
  { cases h' with _ _ h₁ h₂,
    cases h₂ with _ _ h₂ h₃,
    have := h₁ _ (or.inl rfl),
    cases n; simp only [mem_cons_iff, not_mem_nil, filter_false, take],
    cases n; simp only [mem_cons_iff, false_or, true_or, filter, *, nat.nat_zero_eq_zero, if_true,
                        not_mem_nil, eq_self_iff_true, or_false, if_false, perm_cons, take],
    { rw filter_eq_nil.2, intros, solve_by_elim [ne.symm], },
    { convert perm.swap _ _ _, rw @filter_congr _ _ (∈ take n h_l),
      { clear h₁, induction n generalizing h_l; simp only [not_mem_nil, filter_false, take],
        cases h_l; simp only [mem_cons_iff, true_or, eq_self_iff_true, filter_cons_of_pos,
                              true_and, take, not_mem_nil, filter_false, take_nil],
        cases h₃ with _ _ h₃ h₄,
        rwa [@filter_congr _ _ (∈ take n_n h_l_tl), n_ih],
        { introv h, apply h₂ _ (or.inr h), },
        { introv h, simp only [(h₃ x h).symm, false_or], }, },
      { introv h, simp only [(h₂ x h).symm, (h₁ x (or.inr h)).symm, false_or], } } },
  case list.perm.trans : h_l₁ h_l₂ h_l₃ h₀ h₁ h_ih₀ h_ih₁ n
  { transitivity,
    { apply h_ih₀, rwa h₁.nodup_iff },
    { apply perm.filter _ h₁, } },
end

lemma perm.drop_inter {α} [decidable_eq α] {xs ys : list α} (n : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  xs.drop n ~ ys.inter (xs.drop n) :=
begin
  by_cases h'' : n ≤ xs.length,
  { let n' := xs.length - n,
    have h₀ : n = xs.length - n',
    { dsimp [n'], rwa tsub_tsub_cancel_of_le, } ,
    have h₁ : n' ≤ xs.length,
    { apply tsub_le_self },
    have h₂ : xs.drop n = (xs.reverse.take n').reverse,
    { rw [reverse_take _ h₁, h₀, reverse_reverse], },
    rw [h₂],
    apply (reverse_perm _).trans,
    rw inter_reverse,
    apply perm.take_inter _ _ h',
    apply (reverse_perm _).trans; assumption, },
  { have : drop n xs = [],
    { apply eq_nil_of_length_eq_zero,
      rw [length_drop, tsub_eq_zero_iff_le],
      apply le_of_not_ge h'' },
    simp [this, list.inter], }
end

lemma perm.slice_inter {α} [decidable_eq α] {xs ys : list α} (n m : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  list.slice n m xs ~ ys ∩ (list.slice n m xs) :=
begin
  simp only [slice_eq],
  have : n ≤ n + m := nat.le_add_right _ _,
  have := h.nodup_iff.2 h',
  apply perm.trans _ (perm.inter_append _).symm;
  solve_by_elim [perm.append, perm.drop_inter, perm.take_inter, disjoint_take_drop, h, h']
      { max_depth := 7 },
end

/- enumerating permutations -/

section permutations

theorem perm_of_mem_permutations_aux :
  ∀ {ts is l : list α}, l ∈ permutations_aux ts is → l ~ ts ++ is :=
begin
  refine permutations_aux.rec (by simp) _,
  introv IH1 IH2 m,
  rw [permutations_aux_cons, permutations, mem_foldr_permutations_aux2] at m,
  rcases m with m | ⟨l₁, l₂, m, _, e⟩,
  { exact (IH1 m).trans perm_middle },
  { subst e,
    have p : l₁ ++ l₂ ~ is,
    { simp [permutations] at m,
      cases m with e m, {simp [e]},
      exact is.append_nil ▸ IH2 m },
    exact ((perm_middle.trans (p.cons _)).append_right _).trans (perm_append_comm.cons _) }
end

theorem perm_of_mem_permutations {l₁ l₂ : list α}
  (h : l₁ ∈ permutations l₂) : l₁ ~ l₂ :=
(eq_or_mem_of_mem_cons h).elim (λ e, e ▸ perm.refl _)
  (λ m, append_nil l₂ ▸ perm_of_mem_permutations_aux m)

theorem length_permutations_aux : ∀ ts is : list α,
  length (permutations_aux ts is) + is.length! = (length ts + length is)! :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2,
  have IH2 : length (permutations_aux is nil) + 1 = is.length!,
  { simpa using IH2 },
  simp [-add_comm, nat.factorial, nat.add_succ, mul_comm] at IH1,
  rw [permutations_aux_cons,
      length_foldr_permutations_aux2' _ _ _ _ _
        (λ l m, (perm_of_mem_permutations m).length_eq),
      permutations, length, length, IH2,
      nat.succ_add, nat.factorial_succ, mul_comm (nat.succ _), ← IH1,
      add_comm (_*_), add_assoc, nat.mul_succ, mul_comm]
end

theorem length_permutations (l : list α) : length (permutations l) = (length l)! :=
length_permutations_aux l []

theorem mem_permutations_of_perm_lemma {is l : list α}
  (H : l ~ [] ++ is → (∃ ts' ~ [], l = ts' ++ is) ∨ l ∈ permutations_aux is [])
  : l ~ is → l ∈ permutations is :=
by simpa [permutations, perm_nil] using H

theorem mem_permutations_aux_of_perm :
  ∀ {ts is l : list α}, l ~ is ++ ts → (∃ is' ~ is, l = is' ++ ts) ∨ l ∈ permutations_aux ts is :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2 l p,
  rw [permutations_aux_cons, mem_foldr_permutations_aux2],
  rcases IH1 (p.trans perm_middle) with ⟨is', p', e⟩ | m,
  { clear p, subst e,
    rcases mem_split (p'.symm.subset (mem_cons_self _ _)) with ⟨l₁, l₂, e⟩,
    subst is',
    have p := (perm_middle.symm.trans p').cons_inv,
    cases l₂ with a l₂',
    { exact or.inl ⟨l₁, by simpa using p⟩ },
    { exact or.inr (or.inr ⟨l₁, a::l₂',
        mem_permutations_of_perm_lemma IH2 p, by simp⟩) } },
  { exact or.inr (or.inl m) }
end

@[simp] theorem mem_permutations {s t : list α} : s ∈ permutations t ↔ s ~ t :=
⟨perm_of_mem_permutations, mem_permutations_of_perm_lemma mem_permutations_aux_of_perm⟩

theorem perm_permutations'_aux_comm (a b : α) (l : list α) :
  (permutations'_aux a l).bind (permutations'_aux b) ~
  (permutations'_aux b l).bind (permutations'_aux a) :=
begin
  induction l with c l ih, {simp [swap]},
  simp [permutations'_aux], apply perm.swap',
  have : ∀ a b,
    (map (cons c) (permutations'_aux a l)).bind (permutations'_aux b) ~
    map (cons b ∘ cons c) (permutations'_aux a l) ++
    map (cons c) ((permutations'_aux a l).bind (permutations'_aux b)),
  { intros,
    simp only [map_bind, permutations'_aux],
    refine (bind_append_perm _ (λ x, [_]) _).symm.trans _,
    rw [← map_eq_bind, ← bind_map] },
  refine (((this _ _).append_left _).trans _).trans ((this _ _).append_left _).symm,
  rw [← append_assoc, ← append_assoc],
  exact perm_append_comm.append (ih.map _),
end

theorem perm.permutations' {s t : list α} (p : s ~ t) :
  permutations' s ~ permutations' t :=
begin
  induction p with a s t p IH a b l s t u p₁ p₂ IH₁ IH₂, {simp},
  { simp only [permutations'], exact IH.bind_right _ },
  { simp only [permutations'],
    rw [bind_assoc, bind_assoc], apply perm.bind_left, apply perm_permutations'_aux_comm },
  { exact IH₁.trans IH₂ }
end

theorem permutations_perm_permutations' (ts : list α) : ts.permutations ~ ts.permutations' :=
begin
  obtain ⟨n, h⟩ : ∃ n, length ts < n := ⟨_, nat.lt_succ_self _⟩,
  induction n with n IH generalizing ts, {cases h},
  refine list.reverse_rec_on ts (λ h, _) (λ ts t _ h, _) h, {simp [permutations]},
  rw [← concat_eq_append, length_concat, nat.succ_lt_succ_iff] at h,
  have IH₂ := (IH ts.reverse (by rwa [length_reverse])).trans (reverse_perm _).permutations',
  simp only [permutations_append, foldr_permutations_aux2,
    permutations_aux_nil, permutations_aux_cons, append_nil],
  refine (perm_append_comm.trans ((IH₂.bind_right _).append ((IH _ h).map _))).trans
    (perm.trans _ perm_append_comm.permutations'),
  rw [map_eq_bind, singleton_append, permutations'],
  convert bind_append_perm _ _ _, funext ys,
  rw [permutations'_aux_eq_permutations_aux2, permutations_aux2_append]
end

@[simp] theorem mem_permutations' {s t : list α} : s ∈ permutations' t ↔ s ~ t :=
(permutations_perm_permutations' _).symm.mem_iff.trans mem_permutations

theorem perm.permutations {s t : list α} (h : s ~ t) : permutations s ~ permutations t :=
(permutations_perm_permutations' _).trans $ h.permutations'.trans
(permutations_perm_permutations' _).symm

@[simp] theorem perm_permutations_iff {s t : list α} : permutations s ~ permutations t ↔ s ~ t :=
⟨λ h, mem_permutations.1 $ h.mem_iff.1 $ mem_permutations.2 (perm.refl _), perm.permutations⟩

@[simp] theorem perm_permutations'_iff {s t : list α} : permutations' s ~ permutations' t ↔ s ~ t :=
⟨λ h, mem_permutations'.1 $ h.mem_iff.1 $ mem_permutations'.2 (perm.refl _), perm.permutations'⟩

lemma nth_le_permutations'_aux (s : list α) (x : α) (n : ℕ)
  (hn : n < length (permutations'_aux x s)) :
  (permutations'_aux x s).nth_le n hn = s.insert_nth n x :=
begin
  induction s with y s IH generalizing n,
  { simp only [length, permutations'_aux, nat.lt_one_iff] at hn,
    simp [hn] },
  { cases n,
    { simp },
    { simpa using IH _ _ } }
end

lemma count_permutations'_aux_self [decidable_eq α] (l : list α) (x : α) :
  count (x :: l) (permutations'_aux x l) = length (take_while ((=) x) l) + 1 :=
begin
  induction l with y l IH generalizing x,
  { simp [take_while], },
  { rw [permutations'_aux, count_cons_self],
    by_cases hx : x = y,
    { subst hx,
      simpa [take_while, nat.succ_inj'] using IH _ },
    { rw take_while,
      rw if_neg hx,
      cases permutations'_aux x l with a as,
      { simp },
      { rw [count_eq_zero_of_not_mem, length, zero_add],
        simp [hx, ne.symm hx] } } }
end

@[simp] lemma length_permutations'_aux (s : list α) (x : α) :
  length (permutations'_aux x s) = length s + 1 :=
begin
  induction s with y s IH,
  { simp },
  { simpa using IH }
end

@[simp] lemma permutations'_aux_nth_le_zero (s : list α) (x : α)
  (hn : 0 < length (permutations'_aux x s) := by simp) :
  (permutations'_aux x s).nth_le 0 hn = x :: s :=
nth_le_permutations'_aux _ _ _ _

lemma injective_permutations'_aux (x : α) : function.injective (permutations'_aux x) :=
begin
  intros s t h,
  apply insert_nth_injective s.length x,
  have hl : s.length = t.length := by simpa using congr_arg length h,
  rw [←nth_le_permutations'_aux s x s.length (by simp),
      ←nth_le_permutations'_aux t x s.length (by simp [hl])],
  simp [h, hl]
end

lemma nodup_permutations'_aux_of_not_mem (s : list α) (x : α) (hx : x ∉ s) :
  nodup (permutations'_aux x s) :=
begin
  induction s with y s IH,
  { simp },
  { simp only [not_or_distrib, mem_cons_iff] at hx,
    simp only [not_and, exists_eq_right_right, mem_map, permutations'_aux, nodup_cons],
    refine ⟨λ _, ne.symm hx.left, _⟩,
    rw nodup_map_iff,
    { exact IH hx.right },
    { simp } }
end

lemma nodup_permutations'_aux_iff {s : list α} {x : α} :
  nodup (permutations'_aux x s) ↔ x ∉ s :=
begin
  refine ⟨λ h, _, nodup_permutations'_aux_of_not_mem _ _⟩,
  intro H,
  obtain ⟨k, hk, hk'⟩ := nth_le_of_mem H,
  rw nodup_iff_nth_le_inj at h,
  suffices : k = k + 1,
  { simpa using this },
  refine h k (k + 1) _ _ _,
  { simpa [nat.lt_succ_iff] using hk.le },
  { simpa using hk },
  rw [nth_le_permutations'_aux, nth_le_permutations'_aux],
  have hl : length (insert_nth k x s) = length (insert_nth (k + 1) x s),
  { rw [length_insert_nth _ _ hk.le, length_insert_nth _ _ (nat.succ_le_of_lt hk)] },
  refine ext_le hl (λ n hn hn', _),
  rcases lt_trichotomy n k with H|rfl|H,
  { rw [nth_le_insert_nth_of_lt _ _ _ _ H (H.trans hk),
        nth_le_insert_nth_of_lt _ _ _ _ (H.trans (nat.lt_succ_self _))] },
  { rw [nth_le_insert_nth_self _ _ _ hk.le,
        nth_le_insert_nth_of_lt _ _ _ _ (nat.lt_succ_self _) hk, hk'] },
  { rcases (nat.succ_le_of_lt H).eq_or_lt with rfl|H',
    { rw [nth_le_insert_nth_self _ _ _ (nat.succ_le_of_lt hk)],
      convert hk' using 1,
      convert nth_le_insert_nth_add_succ _ _ _ 0 _,
      simpa using hk },
    { obtain ⟨m, rfl⟩ := nat.exists_eq_add_of_lt H',
      rw [length_insert_nth _ _ hk.le, nat.succ_lt_succ_iff, nat.succ_add] at hn,
      rw nth_le_insert_nth_add_succ,
      convert nth_le_insert_nth_add_succ s x k m.succ _ using 2,
      { simp [nat.add_succ, nat.succ_add] },
      { simp [add_left_comm, add_comm] },
      { simpa [nat.add_succ] using hn },
      { simpa [nat.succ_add] using hn } } }
end

lemma nodup_permutations (s : list α) (hs : nodup s) :
  nodup s.permutations :=
begin
  rw (permutations_perm_permutations' s).nodup_iff,
  induction hs with x l h h' IH,
  { simp },
  { rw [permutations'],
    rw nodup_bind,
    split,
    { intros ys hy,
      rw mem_permutations' at hy,
      rw [nodup_permutations'_aux_iff, hy.mem_iff],
      exact λ H, h x H rfl },
    { refine IH.pairwise_of_forall_ne (λ as ha bs hb H, _),
      rw disjoint_iff_ne,
      rintro a ha' b hb' rfl,
      obtain ⟨n, hn, hn'⟩ := nth_le_of_mem ha',
      obtain ⟨m, hm, hm'⟩ := nth_le_of_mem hb',
      rw mem_permutations' at ha hb,
      have hl : as.length = bs.length := (ha.trans hb.symm).length_eq,
      simp only [nat.lt_succ_iff, length_permutations'_aux] at hn hm,
      rw nth_le_permutations'_aux at hn' hm',
      have hx : nth_le (insert_nth n x as) m
        (by rwa [length_insert_nth _ _ hn, nat.lt_succ_iff, hl]) = x,
      { simp [hn', ←hm', hm] },
      have hx' : nth_le (insert_nth m x bs) n
        (by rwa [length_insert_nth _ _ hm, nat.lt_succ_iff, ←hl]) = x,
      { simp [hm', ←hn', hn] },
      rcases lt_trichotomy n m with ht|ht|ht,
      { suffices : x ∈ bs,
        { exact h x (hb.subset this) rfl },
        rw [←hx', nth_le_insert_nth_of_lt _ _ _ _ ht (ht.trans_le hm)],
        exact nth_le_mem _ _ _ },
      { simp only [ht] at hm' hn',
        rw ←hm' at hn',
        exact H (insert_nth_injective _ _ hn') },
      { suffices : x ∈ as,
        { exact h x (ha.subset this) rfl },
        rw [←hx, nth_le_insert_nth_of_lt _ _ _ _ ht (ht.trans_le hn)],
        exact nth_le_mem _ _ _ } } }
end

-- TODO: `nodup s.permutations ↔ nodup s`
-- TODO: `count s s.permutations = (zip_with count s s.tails).prod`

end permutations

end list


/-
Copyright (c) 2022 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Shing Tak Lam, Frédéric Dupuis
-/
import algebra.star.basic
import group_theory.submonoid.membership

/-!
# Unitary elements of a star monoid

This file defines `unitary R`, where `R` is a star monoid, as the submonoid made of the elements
that satisfy `star U * U = 1` and `U * star U = 1`, and these form a group.
This includes, for instance, unitary operators on Hilbert spaces.

See also `matrix.unitary_group` for specializations to `unitary (matrix n n R)`.

## Tags

unitary
-/

/--
In a `star_monoid R`, `unitary R` is the submonoid consisting of all the elements `U` of
`R` such that `star U * U = 1` and `U * star U = 1`.
-/
def unitary (R : Type*) [monoid R] [star_monoid R] : submonoid R :=
{ carrier := {U | star U * U = 1 ∧ U * star U = 1},
  one_mem' := by simp only [mul_one, and_self, set.mem_set_of_eq, star_one],
  mul_mem' := λ U B ⟨hA₁, hA₂⟩ ⟨hB₁, hB₂⟩,
  begin
    refine ⟨_, _⟩,
    { calc star (U * B) * (U * B) = star B * star U * U * B     : by simp only [mul_assoc, star_mul]
                            ...   = star B * (star U * U) * B   : by rw [←mul_assoc]
                            ...   = 1                           : by rw [hA₁, mul_one, hB₁] },
    { calc U * B * star (U * B) = U * B * (star B * star U)     : by rw [star_mul]
                            ... = U * (B * star B) * star U     : by simp_rw [←mul_assoc]
                            ... = 1                             : by rw [hB₂, mul_one, hA₂] }
  end }

variables {R : Type*}

namespace unitary

section monoid
variables [monoid R] [star_monoid R]

lemma mem_iff {U : R} : U ∈ unitary R ↔ star U * U = 1 ∧ U * star U = 1 := iff.rfl
@[simp] lemma star_mul_self_of_mem {U : R} (hU : U ∈ unitary R) : star U * U = 1 := hU.1
@[simp] lemma mul_star_self_of_mem {U : R} (hU : U ∈ unitary R) : U * star U = 1 := hU.2

lemma star_mem {U : R} (hU : U ∈ unitary R) : star U ∈ unitary R :=
⟨by rw [star_star, mul_star_self_of_mem hU], by rw [star_star, star_mul_self_of_mem hU]⟩

@[simp] lemma star_mem_iff {U : R} : star U ∈ unitary R ↔ U ∈ unitary R :=
⟨λ h, star_star U ▸ star_mem h, star_mem⟩

instance : has_star (unitary R) := ⟨λ U, ⟨star U, star_mem U.prop⟩⟩

@[simp, norm_cast] lemma coe_star {U : unitary R} : ↑(star U) = (star U : R) := rfl

lemma coe_star_mul_self (U : unitary R) : (star U : R) * U = 1 := star_mul_self_of_mem U.prop
lemma coe_mul_star_self (U : unitary R) :  (U : R) * star U = 1 := mul_star_self_of_mem U.prop

@[simp] lemma star_mul_self (U : unitary R) : star U * U = 1 := subtype.ext $ coe_star_mul_self U
@[simp] lemma mul_star_self (U : unitary R) : U * star U = 1 := subtype.ext $ coe_mul_star_self U

instance : group (unitary R) :=
{ inv := star,
  mul_left_inv := star_mul_self,
  ..submonoid.to_monoid _ }

instance : has_involutive_star (unitary R) :=
⟨λ _, by { ext, simp only [coe_star, star_star] }⟩

instance : star_monoid (unitary R) :=
⟨λ _ _, by { ext, simp only [coe_star, submonoid.coe_mul, star_mul] }⟩

instance : inhabited (unitary R) := ⟨1⟩

lemma star_eq_inv (U : unitary R) : star U = U⁻¹ := rfl

lemma star_eq_inv' : (star : unitary R → unitary R) = has_inv.inv := rfl

/-- The unitary elements embed into the units. -/
@[simps]
def to_units : unitary R →* Rˣ :=
{ to_fun := λ x, ⟨x, ↑(x⁻¹), coe_mul_star_self x, coe_star_mul_self x⟩,
  map_one' := units.ext rfl,
  map_mul' := λ x y, units.ext rfl }

lemma to_units_injective : function.injective (to_units : unitary R → Rˣ) :=
λ x y h, subtype.ext $ units.ext_iff.mp h

end monoid

section comm_monoid
variables [comm_monoid R] [star_monoid R]

instance : comm_group (unitary R) :=
{ ..unitary.group,
  ..submonoid.to_comm_monoid _ }

lemma mem_iff_star_mul_self {U : R} : U ∈ unitary R ↔ star U * U = 1 :=
mem_iff.trans $ and_iff_left_of_imp $ λ h, mul_comm (star U) U ▸ h

lemma mem_iff_self_mul_star {U : R} : U ∈ unitary R ↔ U * star U = 1 :=
mem_iff.trans $ and_iff_right_of_imp $ λ h, mul_comm U (star U) ▸ h

end comm_monoid

section group_with_zero
variables [group_with_zero R] [star_monoid R]

@[norm_cast] lemma coe_inv (U : unitary R) : ↑(U⁻¹) = (U⁻¹ : R) :=
eq_inv_of_mul_right_eq_one (coe_mul_star_self _)

@[norm_cast] lemma coe_div (U₁ U₂ : unitary R) : ↑(U₁ / U₂) = (U₁ / U₂ : R) :=
by simp only [div_eq_mul_inv, coe_inv, submonoid.coe_mul]

@[norm_cast] lemma coe_zpow (U : unitary R) (z : ℤ) : ↑(U ^ z) = (U ^ z : R) :=
begin
  induction z,
  { simp [submonoid.coe_pow], },
  { simp [coe_inv] },
end

end group_with_zero

end unitary


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Kenny Lau, Robert Y. Lewis
-/
import algebra.group.defs

/-!
# Eckmann-Hilton argument

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

The Eckmann-Hilton argument says that if a type carries two monoid structures that distribute
over one another, then they are equal, and in addition commutative.
The main application lies in proving that higher homotopy groups (`πₙ` for `n ≥ 2`) are commutative.

## Main declarations

* `eckmann_hilton.comm_monoid`: If a type carries a unital magma structure that distributes
  over a unital binary operation, then the magma is a commutative monoid.
* `eckmann_hilton.comm_group`: If a type carries a group structure that distributes
  over a unital binary operation, then the group is commutative.

-/

universe u

namespace eckmann_hilton
variables {X : Type u}

local notation a ` <`m`> ` b := m a b

/-- `is_unital m e` expresses that `e : X` is a left and right unit
for the binary operation `m : X → X → X`. -/
structure is_unital (m : X → X → X) (e : X) extends is_left_id _ m e, is_right_id _ m e : Prop.

@[to_additive eckmann_hilton.add_zero_class.is_unital]
lemma mul_one_class.is_unital [G : mul_one_class X] : is_unital (*) (1 : X) :=
is_unital.mk (by apply_instance) (by apply_instance)

variables {m₁ m₂ : X → X → X} {e₁ e₂ : X}
variables (h₁ : is_unital m₁ e₁) (h₂ : is_unital m₂ e₂)
variables (distrib : ∀ a b c d, ((a <m₂> b) <m₁> (c <m₂> d)) = ((a <m₁> c) <m₂> (b <m₁> d)))
include h₁ h₂ distrib

/-- If a type carries two unital binary operations that distribute over each other,
then they have the same unit elements.

In fact, the two operations are the same, and give a commutative monoid structure,
see `eckmann_hilton.comm_monoid`. -/
lemma one : e₁ = e₂ :=
by simpa only [h₁.left_id, h₁.right_id, h₂.left_id, h₂.right_id] using distrib e₂ e₁ e₁ e₂

/-- If a type carries two unital binary operations that distribute over each other,
then these operations are equal.

In fact, they give a commutative monoid structure, see `eckmann_hilton.comm_monoid`. -/
lemma mul : m₁ = m₂ :=
begin
  funext a b,
  calc m₁ a b = m₁ (m₂ a e₁) (m₂ e₁ b) :
    by simp only [one h₁ h₂ distrib, h₁.left_id, h₁.right_id, h₂.left_id, h₂.right_id]
          ... = m₂ a b :
    by simp only [distrib, h₁.left_id, h₁.right_id, h₂.left_id, h₂.right_id]
end

/-- If a type carries two unital binary operations that distribute over each other,
then these operations are commutative.

In fact, they give a commutative monoid structure, see `eckmann_hilton.comm_monoid`. -/
lemma mul_comm : is_commutative _ m₂ :=
⟨λ a b, by simpa [mul h₁ h₂ distrib, h₂.left_id, h₂.right_id] using distrib e₂ a b e₂⟩

/-- If a type carries two unital binary operations that distribute over each other,
then these operations are associative.

In fact, they give a commutative monoid structure, see `eckmann_hilton.comm_monoid`. -/
lemma mul_assoc : is_associative _ m₂ :=
⟨λ a b c, by simpa [mul h₁ h₂ distrib, h₂.left_id, h₂.right_id] using distrib a b e₂ c⟩

omit h₁ h₂ distrib

/-- If a type carries a unital magma structure that distributes over a unital binary
operations, then the magma structure is a commutative monoid. -/
@[reducible, to_additive "If a type carries a unital additive magma structure that distributes over
a unital binary operations, then the additive magma structure is a commutative additive monoid."]
def comm_monoid [h : mul_one_class X]
  (distrib : ∀ a b c d, ((a * b) <m₁> (c * d)) = ((a <m₁> c) * (b <m₁> d))) : comm_monoid X :=
{ mul := (*),
  one := 1,
  mul_comm := (mul_comm h₁ mul_one_class.is_unital distrib).comm,
  mul_assoc := (mul_assoc h₁ mul_one_class.is_unital distrib).assoc,
  ..h }

/-- If a type carries a group structure that distributes over a unital binary operation,
then the group is commutative. -/
@[reducible, to_additive "If a type carries an additive group structure that
distributes over a unital binary operation, then the additive group is commutative."]
def comm_group [G : group X]
  (distrib : ∀ a b c d, ((a * b) <m₁> (c * d)) = ((a <m₁> c) * (b <m₁> d))) : comm_group X :=
{ ..(eckmann_hilton.comm_monoid h₁ distrib),
  ..G }

end eckmann_hilton


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.list.range
import data.list.bag_inter

open nat

namespace list
/--
`Ico n m` is the list of natural numbers `n ≤ x < m`.
(Ico stands for "interval, closed-open".)

See also `data/set/intervals.lean` for `set.Ico`, modelling intervals in general preorders, and
`multiset.Ico` and `finset.Ico` for `n ≤ x < m` as a multiset or as a finset.

@TODO (anyone): Define `Ioo` and `Icc`, state basic lemmas about them.
@TODO (anyone): Also do the versions for integers?
@TODO (anyone): One could generalise even further, defining
'locally finite partial orders', for which `set.Ico a b` is `[finite]`, and
'locally finite total orders', for which there is a list model.
 -/
def Ico (n m : ℕ) : list ℕ := range' n (m - n)

namespace Ico

theorem zero_bot (n : ℕ) : Ico 0 n = range n :=
by rw [Ico, nat.sub_zero, range_eq_range']

@[simp] theorem length (n m : ℕ) : length (Ico n m) = m - n :=
by dsimp [Ico]; simp only [length_range']

theorem pairwise_lt (n m : ℕ) : pairwise (<) (Ico n m) :=
by dsimp [Ico]; simp only [pairwise_lt_range']

theorem nodup (n m : ℕ) : nodup (Ico n m) :=
by dsimp [Ico]; simp only [nodup_range']

@[simp] theorem mem {n m l : ℕ} : l ∈ Ico n m ↔ n ≤ l ∧ l < m :=
suffices n ≤ l ∧ l < n + (m - n) ↔ n ≤ l ∧ l < m, by simp [Ico, this],
begin
  cases le_total n m with hnm hmn,
  { rw [nat.add_sub_of_le hnm] },
  { rw [nat.sub_eq_zero_of_le hmn, add_zero],
    exact and_congr_right (assume hnl, iff.intro
      (assume hln, (not_le_of_gt hln hnl).elim)
      (assume hlm, lt_of_lt_of_le hlm hmn)) }
end

theorem eq_nil_of_le {n m : ℕ} (h : m ≤ n) : Ico n m = [] :=
by simp [Ico, nat.sub_eq_zero_of_le h]

theorem map_add (n m k : ℕ) : (Ico n m).map ((+) k) = Ico (n + k) (m + k) :=
by rw [Ico, Ico, map_add_range', nat.add_sub_add_right, add_comm n k]

theorem map_sub (n m k : ℕ) (h₁ : k ≤ n) : (Ico n m).map (λ x, x - k) = Ico (n - k) (m - k) :=
begin
  by_cases h₂ : n < m,
  { rw [Ico, Ico],
    rw nat.sub_sub_sub_cancel_right h₁,
    rw [map_sub_range' _ _ _ h₁] },
  { simp at h₂,
    rw [eq_nil_of_le h₂],
    rw [eq_nil_of_le (nat.sub_le_sub_right h₂ _)],
    refl }
end

@[simp] theorem self_empty {n : ℕ} : Ico n n = [] :=
eq_nil_of_le (le_refl n)

@[simp] theorem eq_empty_iff {n m : ℕ} : Ico n m = [] ↔ m ≤ n :=
iff.intro (assume h, nat.le_of_sub_eq_zero $ by rw [← length, h]; refl) eq_nil_of_le

lemma append_consecutive {n m l : ℕ} (hnm : n ≤ m) (hml : m ≤ l) :
  Ico n m ++ Ico m l = Ico n l :=
begin
  dunfold Ico,
  convert range'_append _ _ _,
  { exact (nat.add_sub_of_le hnm).symm },
  { rwa [← nat.add_sub_assoc hnm, nat.sub_add_cancel] }
end

@[simp] lemma inter_consecutive (n m l : ℕ) : Ico n m ∩ Ico m l = [] :=
begin
  apply eq_nil_iff_forall_not_mem.2,
  intro a,
  simp only [and_imp, not_and, not_lt, list.mem_inter, list.Ico.mem],
  intros h₁ h₂ h₃,
  exfalso,
  exact not_lt_of_ge h₃ h₂
end

@[simp] lemma bag_inter_consecutive (n m l : ℕ) : list.bag_inter (Ico n m) (Ico m l) = [] :=
(bag_inter_nil_iff_inter_nil _ _).2 (inter_consecutive n m l)

@[simp] theorem succ_singleton {n : ℕ} : Ico n (n+1) = [n] :=
by dsimp [Ico]; simp [nat.add_sub_cancel_left]

theorem succ_top {n m : ℕ} (h : n ≤ m) : Ico n (m + 1) = Ico n m ++ [m] :=
by rwa [← succ_singleton, append_consecutive]; exact nat.le_succ _

theorem eq_cons {n m : ℕ} (h : n < m) : Ico n m = n :: Ico (n + 1) m :=
by rw [← append_consecutive (nat.le_succ n) h, succ_singleton]; refl

@[simp] theorem pred_singleton {m : ℕ} (h : 0 < m) : Ico (m - 1) m = [m - 1] :=
by dsimp [Ico]; rw nat.sub_sub_self h; simp

theorem chain'_succ (n m : ℕ) : chain' (λa b, b = succ a) (Ico n m) :=
begin
  by_cases n < m,
  { rw [eq_cons h], exact chain_succ_range' _ _ },
  { rw [eq_nil_of_le (le_of_not_gt h)], trivial }
end

@[simp] theorem not_mem_top {n m : ℕ} : m ∉ Ico n m :=
by simp; intros; refl

lemma filter_lt_of_top_le {n m l : ℕ} (hml : m ≤ l) : (Ico n m).filter (λ x, x < l) = Ico n m :=
filter_eq_self.2 $ assume k hk, lt_of_lt_of_le (mem.1 hk).2 hml

lemma filter_lt_of_ge {n m l : ℕ} (hlm : l ≤ m) : (Ico n m).filter (λ x, x < l) = Ico n l :=
begin
  cases le_total n l with hnl hln,
  { rw [← append_consecutive hnl hlm, filter_append,
      filter_lt_of_top_le (le_refl l), filter_lt_of_le_bot (le_refl l), append_nil] },
  { rw [eq_nil_of_le hln, filter_lt_of_le_bot hln] }
end

@[simp] lemma filter_lt (n m l : ℕ) : (Ico n m).filter (λ x, x < l) = Ico n (min m l) :=
begin
  cases le_total m l with hml hlm,
  { rw [min_eq_left hml, filter_lt_of_top_le hml] },
  { rw [min_eq_right hlm, filter_lt_of_ge hlm] }
end

lemma filter_le_of_le_bot {n m l : ℕ} (hln : l ≤ n) : (Ico n m).filter (λ x, l ≤ x) = Ico n m :=
filter_eq_self.2 $ assume k hk, le_trans hln (mem.1 hk).1

lemma filter_le_of_top_le {n m l : ℕ} (hml : m ≤ l) : (Ico n m).filter (λ x, l ≤ x) = [] :=
filter_eq_nil.2 $ assume k hk, not_le_of_gt (lt_of_lt_of_le (mem.1 hk).2 hml)

lemma filter_le_of_le {n m l : ℕ} (hnl : n ≤ l) : (Ico n m).filter (λ x, l ≤ x) = Ico l m :=
begin
  cases le_total l m with hlm hml,
  { rw [← append_consecutive hnl hlm, filter_append,
      filter_le_of_top_le (le_refl l), filter_le_of_le_bot (le_refl l), nil_append] },
  { rw [eq_nil_of_le hml, filter_le_of_top_le hml] }
end

@[simp] lemma filter_le (n m l : ℕ) : (Ico n m).filter (λ x, l ≤ x) = Ico (_root_.max n l) m :=
begin
  cases le_total n l with hnl hln,
  { rw [max_eq_right hnl, filter_le_of_le hnl] },
  { rw [max_eq_left hln, filter_le_of_le_bot hln] }
end

lemma filter_lt_of_succ_bot {n m : ℕ} (hnm : n < m) : (Ico n m).filter (λ x, x < n + 1) = [n] :=
begin
  have r : min m (n + 1) = n + 1 := (@inf_eq_right _ _ m (n + 1)).mpr hnm,
  simp [filter_lt n m (n + 1), r],
end

@[simp] lemma filter_le_of_bot {n m : ℕ} (hnm : n < m) : (Ico n m).filter (λ x, x ≤ n) = [n] :=
begin
  rw ←filter_lt_of_succ_bot hnm,
  exact filter_congr (λ _ _, lt_succ_iff.symm),
end

/--
For any natural numbers n, a, and b, one of the following holds:
1. n < a
2. n ≥ b
3. n ∈ Ico a b
-/
lemma trichotomy (n a b : ℕ) : n < a ∨ b ≤ n ∨ n ∈ Ico a b :=
begin
  by_cases h₁ : n < a,
  { left, exact h₁ },
  { right,
    by_cases h₂ : n ∈ Ico a b,
    { right, exact h₂ },
    { left,  simp only [Ico.mem, not_and, not_lt] at *, exact h₂ h₁ }}
end

end Ico
end list


import data.real.basic

structure group₁ (α : Type*) :=
  (mul : α → α → α)
  (one: α)
  (inv : α → α)
  (mul_assoc : ∀ x y z : α, mul (mul x y) z = mul x (mul y z))
  (mul_one : ∀ x : α, mul x one = x)
  (one_mul : ∀ x : α, mul one x = x)
  (mul_left_inv : ∀ x : α, mul (inv x) x = one)

#print group

structure Group₁ :=
  (α : Type*)
  (str : group₁ α)

section
variables (α β γ : Type*)
variables (f : α ≃ β) (g : β ≃ γ) -- ~-

#check equiv α β
#check (f.to_fun : α → β)
#check (f.inv_fun : β → α)
#check (f.right_inv: ∀ x : β, f (f.inv_fun x) = x)
#check (f.left_inv: ∀ x : α, f.inv_fun (f x) = x)

#check (equiv.refl α : α ≃ α)
#check (f.symm : β ≃ α)
#check (f.trans g : α ≃ γ)

example (x : α) : (f.trans g).to_fun x = g.to_fun (f.to_fun x) := rfl

example (x : α) : (f.trans g) x = g (f x) := rfl

example : (f.trans g : α → γ) = g ∘ f := rfl

end

example (α : Type*) : equiv.perm α = (α ≃ α) := rfl

def perm_group {α : Type*} : group₁ (equiv.perm α) :=
{
  mul := λ f g, equiv.trans g f,
  one := equiv.refl α,
  inv := equiv.symm,
  mul_assoc := λ f g h, (equiv.trans_assoc _ _ _).symm,
  one_mul := equiv.trans_refl,
  mul_one := equiv.refl_trans,
  mul_left_inv := equiv.self_trans_symm,
}

structure add_group₁ (α : Type*) :=
  (add : α → α → α)
  (zero : α)
  (neg : α → α)
  (add_assoc : ∀ x y z : α, add (add x y) z = add x (add y z))
  (add_zero : ∀ x : α, add x zero = x)
  (zero_add : ∀ x : α, add zero x = x)
  (add_left_neg : ∀ x : α, add (neg x) x = zero)

@[ext] structure point := (x : ℝ) (y : ℝ) (z : ℝ)

namespace point

def add (a b : point) : point := ⟨a.x + b.x, a.y + b.y, a.z + b.z⟩

def neg (a : point) : point :=
  ⟨-a.x, -a.y, -a.z⟩

def zero : point :=
  ⟨0, 0, 0⟩

def add_group_point : add_group₁ point :=
{
  add := add,
  zero := zero,
  neg := neg,
  add_assoc := by { intros, ext; simp [add, add_assoc],},
  add_zero := by { intros, ext; simp [add, add_zero, zero],},
  zero_add := by { intros, ext; simp [add, zero_add, zero]},
  add_left_neg := by { intros, ext; simp [add, neg, zero]},
}

end point

section
variables {α : Type*} (f g : equiv.perm α) (n : ℕ)

#check f * g
#check mul_assoc f g g⁻¹

-- group power, defined for any group
#check g^n

example : f * g * (g⁻¹) = f :=
by { rw [mul_assoc, mul_right_inv, mul_one] }

example : f * g * (g⁻¹) = f := mul_inv_cancel_right f g

example {α : Type*} (f g : equiv.perm α) : g.symm.trans (g.trans f) = f :=
mul_inv_cancel_right f g

end

class group₂ (α : Type*) :=
(mul: α → α → α)
(one: α)
(inv: α → α)
(mul_assoc : ∀ x y z : α, mul (mul x y) z = mul x (mul y z))
(mul_one: ∀ x : α, mul x one = x)
(one_mul: ∀ x : α, mul one x = x)
(mul_left_inv : ∀ x : α, mul (inv x) x = one)

instance {α : Type*} : group₂ (equiv.perm α) :=
{ mul          := λ f g, equiv.trans g f,
  one          := equiv.refl α,
  inv          := equiv.symm,
  mul_assoc    := λ f g h, (equiv.trans_assoc _ _ _).symm,
  one_mul      := equiv.trans_refl,
  mul_one      := equiv.refl_trans,
  mul_left_inv := equiv.self_trans_symm }

#check @group₂.mul

def my_square {α : Type*} [group₂ α] (x : α) := group₂.mul x x

#check @my_square

section
variables {β : Type*} (f g : equiv.perm β)

example : group₂.mul f g = g.trans f := rfl

example : my_square f = f.trans f := rfl

end

instance : inhabited point := { default := ⟨0, 0, 0⟩ }

#check (default : point)

example : ([] : list point).head = default := rfl

instance : has_add point := { add := point.add }

section
variables x y : point

#check x + y

example : x + y = point.add x y := rfl

end

instance has_mul_group₂ {α : Type*} [group₂ α] : has_mul α := ⟨group₂.mul⟩

instance has_one_group₂ {α : Type*} [group₂ α] : has_one α := ⟨group₂.one⟩

instance has_inv_group₂ {α : Type*} [group₂ α] : has_inv α := ⟨group₂.inv⟩

section
variables {α : Type*} (f g : equiv.perm α)

#check f * 1 * g⁻¹

example : f * 1 * g⁻¹ = g.symm.trans ((equiv.refl α).trans f) := rfl

end


-- Pertenencia_a_bloques_de_una_particion_con_elementos_comunes.lean
-- Pertenencia a bloques de una partición con elementos comunes
-- José A. Alonso Jiménez
-- Sevilla, 1 de octubre de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Este ejercicio es el 2º de una serie, que comenzó con el [ejercicio
-- del 30 de septiembre](https://bit.ly/2YfsvBZ), cuyo objetivo es
-- demostrar que el tipo de las particiones de un conjunto `X` es
-- isomorfo al tipo de las relaciones de equivalencia sobre `X`.
--
-- El ejercicio consiste en demostrar que si dos bloques de una
-- partición tienen elementos comunes, entonces los elementos de uno
-- también pertenecen al otro.
-- ---------------------------------------------------------------------

import tactic

@[ext] structure particion (A : Type) :=
(Bloques    : set (set A))
(Hno_vacios : ∀ X ∈ Bloques, (X : set A).nonempty)
(Hrecubren  : ∀ a, ∃ X ∈ Bloques, a ∈ X)
(Hdisjuntos : ∀ X Y ∈ Bloques, (X ∩ Y : set A).nonempty → X = Y)

namespace particion

variable  {A : Type}
variable  {P : particion A}
variables {X Y : set A}

lemma iguales_si_comun
  (hX : X ∈ Bloques P)
  (hY : Y ∈ Bloques P)
  {a : A}
  (haX : a ∈ X)
  (haY : a ∈ Y)
  : X = Y :=
Hdisjuntos P X hX Y  hY ⟨a, haX, haY⟩

-- 1ª demostración
example
  (hX : X ∈ Bloques P)
  (hY : Y ∈ Bloques P)
  {a b : A}
  (haX : a ∈ X)
  (haY : a ∈ Y)
  (hbX : b ∈ X)
  : b ∈ Y :=
begin
  convert hbX,
  apply iguales_si_comun hY hX haY,
  exact haX,
end

-- 2ª demostración
example
  (hX : X ∈ Bloques P)
  (hY : Y ∈ Bloques P)
  {a b : A}
  (haX : a ∈ X)
  (haY : a ∈ Y)
  (hbX : b ∈ X)
  : b ∈ Y :=
begin
  have hXY : X = Y := iguales_si_comun hX hY haX haY,
  rw ← hXY,
  exact hbX,
end

-- 3ª demostración
lemma pertenece_si_pertenece
  (hX : X ∈ Bloques P)
  (hY : Y ∈ Bloques P)
  {a b : A}
  (haX : a ∈ X)
  (haY : a ∈ Y)
  (hbX : b ∈ X)
  : b ∈ Y :=
begin
  convert hbX,
  exact iguales_si_comun hY hX haY haX,
end

end particion


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Benjamin Davidson
-/
import analysis.special_functions.complex.arg
import analysis.special_functions.log.basic

/-!
# The complex `log` function

Basic properties, relationship with `exp`.
-/

noncomputable theory

namespace complex

open set filter

open_locale real topology complex_conjugate

/-- Inverse of the `exp` function. Returns values such that `(log x).im > - π` and `(log x).im ≤ π`.
  `log 0 = 0`-/
@[pp_nodot] noncomputable def log (x : ℂ) : ℂ := x.abs.log + arg x * I

lemma log_re (x : ℂ) : x.log.re = x.abs.log := by simp [log]

lemma log_im (x : ℂ) : x.log.im = x.arg := by simp [log]

lemma neg_pi_lt_log_im (x : ℂ) : -π < (log x).im := by simp only [log_im, neg_pi_lt_arg]
lemma log_im_le_pi (x : ℂ) : (log x).im ≤ π := by simp only [log_im, arg_le_pi]

lemma exp_log {x : ℂ} (hx : x ≠ 0) : exp (log x) = x :=
by rw [log, exp_add_mul_I, ← of_real_sin, sin_arg, ← of_real_cos, cos_arg hx,
  ← of_real_exp, real.exp_log (abs.pos hx), mul_add, of_real_div, of_real_div,
  mul_div_cancel' _ (of_real_ne_zero.2 $ abs.ne_zero hx), ← mul_assoc,
  mul_div_cancel' _ (of_real_ne_zero.2 $ abs.ne_zero hx), re_add_im]

@[simp] lemma range_exp : range exp = {0}ᶜ :=
set.ext $ λ x, ⟨by { rintro ⟨x, rfl⟩, exact exp_ne_zero x }, λ hx, ⟨log x, exp_log hx⟩⟩

lemma log_exp {x : ℂ} (hx₁ : -π < x.im) (hx₂: x.im ≤ π) : log (exp x) = x :=
by rw [log, abs_exp, real.log_exp, exp_eq_exp_re_mul_sin_add_cos, ← of_real_exp,
  arg_mul_cos_add_sin_mul_I (real.exp_pos _) ⟨hx₁, hx₂⟩, re_add_im]

lemma of_real_log {x : ℝ} (hx : 0 ≤ x) : (x.log : ℂ) = log x :=
complex.ext
  (by rw [log_re, of_real_re, abs_of_nonneg hx])
  (by rw [of_real_im, log_im, arg_of_real_of_nonneg hx])

lemma log_of_real_re (x : ℝ) : (log (x : ℂ)).re = real.log x := by simp [log_re]

lemma log_of_real_mul {r : ℝ} (hr : 0 < r) {x : ℂ} (hx : x ≠ 0) :
  log (r * x) = real.log r + log x :=
begin
  replace hx := complex.abs.ne_zero_iff.mpr hx,
  simp_rw [log, map_mul, abs_of_real, arg_real_mul _ hr, abs_of_pos hr, real.log_mul hr.ne' hx,
    of_real_add, add_assoc],
end

lemma log_mul_of_real (r : ℝ) (hr : 0 < r) (x : ℂ) (hx : x ≠ 0) :
  log (x * r) = real.log r + log x :=
by rw [mul_comm, log_of_real_mul hr hx, add_comm]

@[simp] lemma log_zero : log 0 = 0 := by simp [log]

@[simp] lemma log_one : log 1 = 0 := by simp [log]

lemma log_neg_one : log (-1) = π * I := by simp [log]

lemma log_I : log I = π / 2 * I := by simp [log]

lemma log_neg_I : log (-I) = -(π / 2) * I := by simp [log]

lemma log_conj_eq_ite (x : ℂ) :
  log (conj x) = if x.arg = π then log x else conj (log x) :=
begin
  simp_rw [log, abs_conj, arg_conj, map_add, map_mul, conj_of_real],
  split_ifs with hx,
  { rw hx },
  simp_rw [of_real_neg, conj_I, mul_neg, neg_mul]
end

lemma log_conj (x : ℂ) (h : x.arg ≠ π) : log (conj x) = conj (log x) :=
by rw [log_conj_eq_ite, if_neg h]

lemma log_inv_eq_ite (x : ℂ) : log (x⁻¹) = if x.arg = π then -conj (log x) else -log x :=
begin
  by_cases hx : x = 0,
  { simp [hx] },
  rw [inv_def, log_mul_of_real, real.log_inv, of_real_neg, ←sub_eq_neg_add, log_conj_eq_ite],
  { simp_rw [log, map_add, map_mul, conj_of_real, conj_I, norm_sq_eq_abs, real.log_pow,
      nat.cast_two, of_real_mul, of_real_bit0, of_real_one, neg_add, mul_neg, two_mul, neg_neg],
    split_ifs,
    { rw [add_sub_right_comm, sub_add_cancel'] },
    { rw [add_sub_right_comm, sub_add_cancel'] } },
  { rwa [inv_pos, complex.norm_sq_pos] },
  { rwa map_ne_zero },
end

lemma log_inv (x : ℂ) (hx : x.arg ≠ π) : log (x⁻¹) = -log x :=
by rw [log_inv_eq_ite, if_neg hx]

lemma two_pi_I_ne_zero : (2 * π * I : ℂ) ≠ 0 :=
by norm_num [real.pi_ne_zero, I_ne_zero]

lemma exp_eq_one_iff {x : ℂ} : exp x = 1 ↔ ∃ n : ℤ, x = n * ((2 * π) * I) :=
begin
  split,
  { intro h,
    rcases exists_unique_add_zsmul_mem_Ioc real.two_pi_pos x.im (-π) with ⟨n, hn, -⟩,
    use -n,
    rw [int.cast_neg, neg_mul, eq_neg_iff_add_eq_zero],
    have : (x + n * (2 * π * I)).im ∈ Ioc (-π) π, by simpa [two_mul, mul_add] using hn,
    rw [← log_exp this.1 this.2, exp_periodic.int_mul n, h, log_one] },
  { rintro ⟨n, rfl⟩, exact (exp_periodic.int_mul n).eq.trans exp_zero }
end

lemma exp_eq_exp_iff_exp_sub_eq_one {x y : ℂ} : exp x = exp y ↔ exp (x - y) = 1 :=
by rw [exp_sub, div_eq_one_iff_eq (exp_ne_zero _)]

lemma exp_eq_exp_iff_exists_int {x y : ℂ} : exp x = exp y ↔ ∃ n : ℤ, x = y + n * ((2 * π) * I) :=
by simp only [exp_eq_exp_iff_exp_sub_eq_one, exp_eq_one_iff, sub_eq_iff_eq_add']

@[simp] lemma countable_preimage_exp {s : set ℂ} : (exp ⁻¹' s).countable ↔ s.countable :=
begin
  refine ⟨λ hs, _, λ hs, _⟩,
  { refine ((hs.image exp).insert 0).mono _,
    rw [image_preimage_eq_inter_range, range_exp, ← diff_eq, ← union_singleton, diff_union_self],
    exact subset_union_left _ _ },
  { rw ← bUnion_preimage_singleton,
    refine hs.bUnion (λ z hz, _),
    rcases em (∃ w, exp w = z) with ⟨w, rfl⟩|hne,
    { simp only [preimage, mem_singleton_iff, exp_eq_exp_iff_exists_int, set_of_exists],
      exact countable_Union (λ m, countable_singleton _) },
    { push_neg at hne, simp [preimage, hne] } }
end

alias countable_preimage_exp ↔ _ _root_.set.countable.preimage_cexp

lemma tendsto_log_nhds_within_im_neg_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  tendsto log (𝓝[{z : ℂ | z.im < 0}] z) (𝓝 $ real.log (abs z) - π * I) :=
begin
  have := (continuous_of_real.continuous_at.comp_continuous_within_at
    (continuous_abs.continuous_within_at.log _)).tendsto.add
    (((continuous_of_real.tendsto _).comp $
    tendsto_arg_nhds_within_im_neg_of_re_neg_of_im_zero hre him).mul tendsto_const_nhds),
  convert this,
  { simp [sub_eq_add_neg] },
  { lift z to ℝ using him, simpa using hre.ne }
end

lemma continuous_within_at_log_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  continuous_within_at log {z : ℂ | 0 ≤ z.im} z :=
begin
  have := (continuous_of_real.continuous_at.comp_continuous_within_at
    (continuous_abs.continuous_within_at.log _)).tendsto.add
    ((continuous_of_real.continuous_at.comp_continuous_within_at $
    continuous_within_at_arg_of_re_neg_of_im_zero hre him).mul tendsto_const_nhds),
  convert this,
  { lift z to ℝ using him, simpa using hre.ne }
end

lemma tendsto_log_nhds_within_im_nonneg_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  tendsto log (𝓝[{z : ℂ | 0 ≤ z.im}] z) (𝓝 $ real.log (abs z) + π * I) :=
by simpa only [log, arg_eq_pi_iff.2 ⟨hre, him⟩]
  using (continuous_within_at_log_of_re_neg_of_im_zero hre him).tendsto

@[simp] lemma map_exp_comap_re_at_bot : map exp (comap re at_bot) = 𝓝[≠] 0 :=
by rw [← comap_exp_nhds_zero, map_comap, range_exp, nhds_within]

@[simp] lemma map_exp_comap_re_at_top : map exp (comap re at_top) = comap abs at_top :=
begin
  rw [← comap_exp_comap_abs_at_top, map_comap, range_exp, inf_eq_left, le_principal_iff],
  exact eventually_ne_of_tendsto_norm_at_top tendsto_comap 0
end

end complex

section log_deriv

open complex filter
open_locale topology

variables {α : Type*}

lemma continuous_at_clog {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) :
  continuous_at log x :=
begin
  refine continuous_at.add _ _,
  { refine continuous_of_real.continuous_at.comp _,
    refine (real.continuous_at_log _).comp complex.continuous_abs.continuous_at,
    rw complex.abs.ne_zero_iff,
    rintro rfl,
    simpa using h },
  { have h_cont_mul : continuous (λ x : ℂ, x * I), from continuous_id'.mul continuous_const,
    refine h_cont_mul.continuous_at.comp (continuous_of_real.continuous_at.comp _),
    exact continuous_at_arg h, },
end

lemma filter.tendsto.clog {l : filter α} {f : α → ℂ} {x : ℂ} (h : tendsto f l (𝓝 x))
  (hx : 0 < x.re ∨ x.im ≠ 0) :
  tendsto (λ t, log (f t)) l (𝓝 $ log x) :=
(continuous_at_clog hx).tendsto.comp h

variables [topological_space α]

lemma continuous_at.clog {f : α → ℂ} {x : α} (h₁ : continuous_at f x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_at (λ t, log (f t)) x :=
h₁.clog h₂

lemma continuous_within_at.clog {f : α → ℂ} {s : set α} {x : α} (h₁ : continuous_within_at f s x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_within_at (λ t, log (f t)) s x :=
h₁.clog h₂

lemma continuous_on.clog {f : α → ℂ} {s : set α} (h₁ : continuous_on f s)
  (h₂ : ∀ x ∈ s, 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_on (λ t, log (f t)) s :=
λ x hx, (h₁ x hx).clog (h₂ x hx)

lemma continuous.clog {f : α → ℂ} (h₁ : continuous f) (h₂ : ∀ x, 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous (λ t, log (f t)) :=
continuous_iff_continuous_at.2 $ λ x, h₁.continuous_at.clog (h₂ x)

end log_deriv


-- * Level 1
import mynat.le

lemma one_add_le_self (x : mynat) : x ≤ 1 + x :=

begin

use 1,
rw add_comm,

end

-- * Level 2
lemma le_refl (x : mynat) : x ≤ x :=

begin

use 0,
refl

end
-- * Level 3

theorem le_succ (a b : mynat) : a ≤ b → a ≤ (succ b) :=

begin

intro h,
rw le_iff_exists_add at h ⊢,
cases h with c hc,
use c+1,
rw succ_eq_add_one,
rw hc,
refl,

end

-- * Level 4

lemma zero_le (a : mynat) : 0 ≤ a :=

begin

rw le_iff_exists_add,
use a,
rw zero_add,
refl,

end

-- * Level 5
theorem le_trans (a b c : mynat) (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c :=
begin

rw le_iff_exists_add at hab hbc,
cases hbc,
cases hab,
rw hab_h at hbc_h,
use hab_w + hbc_w,
rw add_assoc at hbc_h,
apply hbc_h,
end

-- * Level 6
theorem le_antisymm (a b : mynat) (hab : a ≤ b) (hba : b ≤ a) : a = b :=

begin

cases hab,
cases hba,
rw hab_h at hba_h,
rw add_assoc at hba_h,
symmetry at hba_h,
have h := eq_zero_of_add_right_eq_self hba_h,
have g := add_right_eq_zero(h),
rw g at hab_h,
rw add_zero at hab_h,
symmetry at hab_h,
exact hab_h,

end

-- * Level 7
lemma le_zero (a : mynat) (h : a ≤ 0) : a = 0 :=

begin

cases h,
symmetry at h_h,
exact add_right_eq_zero(h_h),

end
-- * Level 8
lemma succ_le_succ (a b : mynat) (h : a ≤ b) : succ a ≤ succ b :=
begin
rw le_iff_exists_add at h,
cases h,
repeat {rw succ_eq_add_one},
rw h_h,
rw add_right_comm,
rw le_iff_exists_add,
use h_w,
refl,
end
-- * Level 9
-- couldnt do it
theorem le_total (a b : mynat) : a ≤ b ∨ b ≤ a :=
begin
sorry
end

-- * Level 10
lemma le_succ_self (a : mynat) : a ≤ succ a :=

begin
apply le_succ,
exact le_refl a,
end

-- * Level 11

theorem add_le_add_right {a b : mynat} : a ≤ b → ∀ t, (a + t) ≤ (b + t) :=

begin
intro h,
intro t,
rw le_iff_exists_add ,
rw le_iff_exists_add at h,
cases h,
use h_w,
rw h_h,
rw add_right_comm,
refl,
end

-- * Level 12
theorem le_of_succ_le_succ (a b : mynat) : succ a ≤ succ b → a ≤ b :=
begin
intro h,
rw le_iff_exists_add at h,
cases h,
rw le_iff_exists_add,
use h_w,
rw succ_add at h_h,
have foo:= succ_inj(h_h),
exact foo,
end

-- * Level 13
theorem not_succ_le_self (a : mynat) : ¬ (succ a ≤ a) :=

begin

intro h,
rw le_iff_exists_add at h,
cases h,
induction a,
rw succ_add at h_h,
rw zero_add at h_h,
symmetry at h_h,
have foo :=  succ_ne_zero h_w,
exact foo h_h,
rw succ_add at h_h,
have foo2 := succ_inj(h_h),
exact a_ih(foo2),

end

-- * Level 14

theorem add_le_add_left {a b : mynat} (h : a ≤ b) (t : mynat) :
  t + a ≤ t + b :=

begin

cases h,
use h_w,
rw h_h,
rw add_assoc,
refl,

end

-- * Level 15
lemma lt_aux_one (a b : mynat) : a ≤ b ∧ ¬ (b ≤ a) → succ a ≤ b :=

begin

intro h,
cases h with r l,
cases r with f1 f2,
cases f1,
rw add_zero at f2,
exfalso,
apply l,
rw f2,

apply le_refl a,
rw le_iff_exists_add,
rw add_succ at  f2,
use f1,
rw succ_add,
apply f2,

end

-- * Level 16
lemma lt_aux_two (a b : mynat) : succ a ≤ b → a ≤ b ∧ ¬ (b ≤ a) :=

begin

intro h,
split,
rw le_iff_exists_add at h,
rw le_iff_exists_add,
cases h,
rw ← add_one_eq_succ at h_h,
rw add_assoc at h_h,
use (1 + h_w),
exact h_h,
by_contra h2,
have foo3 := le_trans (succ a) b a h h2,
have foo4 := not_succ_le_self a,
exact foo4(foo3),

end
-- * Level 17

lemma lt_iff_succ_le (a b : mynat) : a < b ↔ succ a ≤ b :=
begin

split,
exact lt_aux_one a b,
exact lt_aux_two a b,

end


import data.rat

def is_regular_sequence(seq: ℕ → ℚ) :=
  ∀ {m n: ℕ}, (0 < m) → (0 < n) → |seq m - seq n| ≤ (m : ℚ)⁻¹ + (n : ℚ)⁻¹

def regular_sequence := {f: ℕ → ℚ // is_regular_sequence f}

namespace regular_sequence

instance : has_coe_to_fun regular_sequence (λ _, ℕ → ℚ) :=
  ⟨subtype.val⟩

@[simp] theorem mk_to_fun (f) (hf : is_regular_sequence f) :
  @coe_fn regular_sequence _ _ ⟨f, λ x y, hf⟩ = f := rfl

@[simp] lemma fn_apply (a: regular_sequence) (n) : a n = a.val n := rfl

theorem ext {f g : regular_sequence} (h : ∀ i, f i = g i) : f = g :=
  subtype.eq (funext h)

theorem is_reg_seq (f : regular_sequence) : is_regular_sequence f.val := f.property

/-The constant regular sequence-/
def const(x: ℚ): regular_sequence :=
  { val := λ n, x,
    property := λ m n m_pos n_pos, let h1 := (@inv_pos _ _ (m : ℚ)).2 (nat.cast_pos.2 m_pos),
        h2 := (@inv_pos _ _ (n : ℚ)).2 (nat.cast_pos.2 n_pos),
        h := le_of_lt (add_pos h1 h2) in by rwa [sub_self, abs_zero] }

instance : has_zero regular_sequence :=
  ⟨const 0⟩

instance : has_one regular_sequence :=
  ⟨const 1⟩

instance : inhabited regular_sequence :=
  ⟨0⟩

def equivalent(a b: regular_sequence) :=
  ∀ {n : ℕ}, 0 < n → |a n - b n| ≤ 2 * (n : ℚ)⁻¹

lemma equivalent_refl: reflexive equivalent :=
  λ n h_n, by {simp,}

/-- `lim_zero f` holds when `f` approaches 0. -/
def lim_zero (f : regular_sequence) := (∀ (j: ℕ), 0 < j → ∃ N, ∀ n ≥ N, | f n | ≤ (j: ℚ)⁻¹)

lemma equivalent_symm : symmetric regular_sequence.equivalent :=
  λ _ _ h_eq _ h_n, let h := h_eq h_n in by rwa [←abs_neg, neg_sub]

lemma equivalent_iff' {a b: regular_sequence}:
    (equivalent a b) ↔ (∀ j: ℕ, 0 < j → ∃ Nj, ∀ n ≥ Nj, |a n - b n| ≤ (j : ℚ)⁻¹) :=
  begin
    split,
    { intros h_eq j j_pos,
      use 2 * j,
      intros n n_ge_two_j,
      have j_le_2j: j ≤ 2 * j := (le_mul_iff_one_le_left j_pos).2 one_le_two,
      have n_pos := gt_of_ge_of_gt n_ge_two_j (gt_of_ge_of_gt j_le_2j j_pos),
      have hn2n : n ≤ 2 * n,
      {
        obtain h := mul_le_mul one_le_two rfl.ge (zero_le n) (zero_le 2),
        rwa one_mul at h,
      },
      have n2_pos := gt_of_ge_of_gt hn2n n_pos,
      specialize h_eq n_pos,
      have n_inv_pos: 0 < (n : ℚ)⁻¹, by rwa [inv_pos, nat.cast_pos],
      haveI := rat.nontrivial,
      have ninv_lt_2jinv : (n : ℚ)⁻¹ ≤ (2*j)⁻¹,
      {
        rw inv_le_inv,
        norm_cast,
        exact n_ge_two_j,
        exact nat.cast_pos.2 n_pos,
        exact (@zero_lt_mul_left _ _  (j : ℚ) 2 zero_lt_two).2 (nat.cast_pos.2 j_pos),
      },
      calc |a n - b n | ≤ 2*(↑n)⁻¹ : h_eq
                   ... ≤ 2*(2*j)⁻¹ : by rwa @mul_le_mul_left _ _ (n : ℚ)⁻¹ (2*j)⁻¹ 2 zero_lt_two
                   ... = (↑j)⁻¹ :  by { rw [mul_inv₀], ring}
    },
    {
      intros h_eq n n_pos,
      have key: ∀ j: ℕ, 0 < j → |a n - b n| ≤ 2*(n: ℚ)⁻¹ + 3 * (j: ℚ)⁻¹,
      {
        intros j j_pos,
        obtain ⟨Nj, h_Nj⟩  := h_eq j j_pos,
        set m := max j Nj with hm,
        have m_pos := gt_of_ge_of_gt (le_max_left j Nj) j_pos,
        have inv_m_leq_inv_j : 2*(m : ℚ)⁻¹ ≤ 2*(j : ℚ)⁻¹,
        {
          simp only [mul_le_mul_left, nat.cast_max, zero_lt_bit0, zero_lt_one],
          obtain m_rat_pos := @lt_max_of_lt_left _ _ 0 (j : ℚ) (Nj : ℚ) (nat.cast_pos.mpr j_pos),
          rw inv_le_inv m_rat_pos (nat.cast_pos.mpr j_pos),
          norm_cast,
          exact le_max_left j Nj,
        },
        calc |a n - b n| = |(a n - a m) + ((a m - b m) + (b m - b n))| : by ring_nf
                     ... ≤ |a n - a m| + |(a m - b m) + (b m - b n)| : abs_add _ _
                     ... ≤ |a n - a m| + (|a m - b m| + |b m - b n|) : add_le_add_left (abs_add _ _) _
                     ... ≤ ((n: ℚ)⁻¹ + (m: ℚ)⁻¹) + ((j: ℚ)⁻¹ + ((m: ℚ)⁻¹ + (n: ℚ)⁻¹) ): by exact add_le_add (a.property n_pos m_pos)
                                                                  (add_le_add (h_Nj m (le_max_right j Nj)) (b.property m_pos n_pos))
                     ... = 2*(↑n)⁻¹ + 2 * (↑m)⁻¹ + (↑j)⁻¹ : by ring_nf
                     ... ≤ 2*(↑n)⁻¹ + 2 * (↑j)⁻¹ + (↑j)⁻¹ : by exact add_le_add_right (add_le_add_left inv_m_leq_inv_j (2 * (↑n)⁻¹)) (↑j)⁻¹
                     ... = 2*(↑n)⁻¹ + 3*(↑j)⁻¹: by ring_nf
      },
      apply le_of_forall_pos_le_add,
      intros ε ε_pos,
      have h1: ↑(int.floor ((3:ℚ)/ε))+1 > 3/ε,
      {
        obtain h := rat.num_lt_succ_floor_mul_denom ((3:ℚ)/ε),
        apply rat.lt_def.2,
        norm_cast,
        simp[h],
      },
      have hh1 := nat.lt_succ_floor (3 / ε),
      have h2 : (↑(int.to_nat (int.floor ((3:ℚ)/ε)))+1)⁻¹ < (3/ε)⁻¹,
      {
        exact (@inv_lt_inv ℚ _ _ _ (⌊3 / ε⌋.to_nat.cast_add_one_pos)
            (div_pos zero_lt_three ε_pos)).2 hh1,
      },
      apply le_of_lt,
      have : ∃ j: ℕ, 0 < j ∧ 3*(j: ℚ)⁻¹ < ε,
      {
        use  int.to_nat (int.floor ((3/ε)))+1,
        split,
        {
          exact fin.last_pos,
        },
        {
          calc 3 * (↑(int.to_nat (rat.floor ((3:ℚ)/ε)))+1)⁻¹ < 3* (3/ε)⁻¹ : mul_lt_mul_of_pos_left h2 zero_lt_three
              ... = 3 * (ε/3) : by rw inv_div
              ... = ε : by ring_nf
        }
      },
      obtain ⟨j, j_pos, j_lt_ε⟩ := this,
      specialize key j j_pos,
      calc |a n - b n| ≤ 2 * (↑n)⁻¹ + 3 * (↑j)⁻¹ : key
                   ... < 2 * (↑n)⁻¹ + ε : add_lt_add_left j_lt_ε _
    },
  end

lemma lim_zero_of_equiv{a b : regular_sequence}(hab: equivalent a b)(a_lim_zero: lim_zero a): lim_zero b :=
begin
  rw equivalent_iff' at *,
  unfold lim_zero at *,
  intros j hj,
  obtain h2j_pos := nat.succ_mul_pos 1 hj,
  obtain ⟨N₁, hN₁⟩ := a_lim_zero (2*j) h2j_pos,
  obtain ⟨N₂, hN₂⟩ := hab (2*j) h2j_pos,
  use max N₁ N₂,
  intros n hn,
  specialize hN₁ n (le_of_max_le_left hn),
  specialize hN₂ n (le_of_max_le_right hn),
  have h2jNQ : (↑(2 * j))⁻¹ = (((2 : ℚ) * ↑j))⁻¹ := by rw [nat.cast_mul, nat.cast_two],
  calc |b n| = |b n - a n + a n| : by ring_nf
  ... ≤ |b n - a n| + |a n| : abs_add _ _
  ... = |a n - b n| + |a n| : by  rw [←abs_neg, neg_sub]
  ... ≤ (2 * j)⁻¹ + (2 * j)⁻¹: add_le_add (by rwa ← h2jNQ) (by rwa ← h2jNQ)
  ... = (↑j)⁻¹ : by {ring_nf, rw mul_inv₀, simp,},
end

lemma equivalent_trans: transitive regular_sequence.equivalent :=
  begin
    intros a b c h_eq_ab h_eq_bc,
    rw regular_sequence.equivalent_iff' at *,
    intros j j_pos,
    have two_j_pos: 2 * j > 0,
      { exact nat.succ_mul_pos 1 j_pos },
    specialize h_eq_ab (2*j) two_j_pos,
    specialize h_eq_bc (2*j) two_j_pos,
    obtain ⟨N, h_N⟩ := h_eq_ab,
    obtain ⟨M, h_M⟩ := h_eq_bc,
    use max N M,
    intros n n_ge_max,
    have n_ge_N: n ≥ N,
      { exact le_of_max_le_left n_ge_max },
    have n_ge_M: n ≥ M,
      { exact le_of_max_le_right n_ge_max },

    specialize h_N n n_ge_N,
    specialize h_M n n_ge_M,

    calc |a n - c n| ≤ |(a n - b n) + (b n - c n)| : by simp
                 ... ≤ |a n - b n| + |b n - c n| : abs_add _ _
                 ... ≤ (↑(2*j))⁻¹ + (↑(2*j))⁻¹ : add_le_add h_N h_M
                 ... = (j: ℚ)⁻¹ : by { push_cast, rw mul_inv₀, ring}
  end

instance equiv: setoid regular_sequence :=
  setoid.mk equivalent ⟨equivalent_refl, equivalent_symm, equivalent_trans⟩

lemma equivalent_iff {a b: regular_sequence}:
    (a ≈ b) ↔ (∀ j: ℕ, 0 < j → ∃ Nj, ∀ n ≥ Nj, |a n - b n| ≤ (j : ℚ)⁻¹) :=
  equivalent_iff'

end regular_sequence


import combinatorics.quiver.basic
import combinatorics.quiver.path
import order.category.FinPartialOrder
import order.cover

import finite

namespace hasse

universe u

-- 1.1.2 (Hasse diagram)
instance hasse (P : FinPartialOrder) : quiver P := { hom := λ y x, x ⋖ y }

open quiver

variable {P : FinPartialOrder}

lemma eq_of_between_cov_right {x y z : P} (hcov : x ⋖ y) (hlt : x < z) (hle : z ≤ y) : z = y :=
begin
  cases covby.eq_or_eq hcov (le_of_lt hlt) (hle),
  { rw h at hlt,
    exfalso,
    apply lt_irrefl x hlt },
  { exact h }
end

lemma eq_of_between_cov_left {x y z : P} (hcov : x ⋖ y) (hlt : z < y) (hle : x ≤ z) : x = z :=
begin
  by_contra' h,
  apply hcov.right (lt_of_le_of_ne hle h) hlt
end

lemma covby_of_eq {x y : P} (hlt : x < y) (h : ∀ z, x < z → z ≤ y → z = y) : x ⋖ y :=
begin
  apply covby_of_eq_or_eq hlt,
  intros z hx hy,
  rw le_iff_lt_or_eq at hx,
  cases hx,
  { right,
    apply h z hx hy },
  { left, exact hx.symm }
end

instance subsingleton_hom_set (x y : P) : subsingleton (x ⟶ y) :=
begin
  apply subsingleton.intro, intros e e',
  refl
end

def hom_of_cov {x y : P} (hcov : y ⋖ x) : x ⟶ y := hcov
def path_of_cov {x y : P} (hcov : y ⋖ x) : path x y := hom.to_path (hom_of_cov hcov)
def cov_of_hom {x y : P} (f : x ⟶ y) : y ⋖ x := f

lemma le_of_path {x y : P} (p : path y x) : x ≤ y :=
begin
  induction p with w z p h h1,
  { refl },
  { apply le_of_lt,
    apply has_lt.lt.trans_le (covby.lt (cov_of_hom h)) h1  }
end

lemma lt_of_path {x y : P} (hneq : x ≠ y) (p : path y x) : x < y :=
begin
  rw lt_iff_le_and_ne,
  exact and.intro (le_of_path p) hneq
end

lemma covby_of_length_one  {x y : P} (p : path y x) (hl : p.length = 1) : x ⋖ y :=
begin
  cases p with w _ p q,
  { rw path.length_nil at hl, linarith },
  { rw [path.length_cons, add_left_eq_self] at hl,
    rw path.eq_of_length_zero p hl,
    exact cov_of_hom q }
end

-- Two lemmas, if we have two elements one smaller than the other,
-- we can consider an element in between that either cover the smaller
-- or is covered by the larger
lemma exists_right_cov_of_lt {x x' : P} (hle : x < x') : ∃ y, x ⋖ y ∧ y ≤ x' :=
begin
  rw ←finite.greater_iff_in_greater at hle,
  exact finite.exists_cov_of_greater hle
end

lemma exists_left_cov_of_lt {x x' : P} (hle : x < x') : ∃ y, x ≤ y ∧ y ⋖ x' :=
begin
  rw ←finite.smaller_iff_in_smaller at hle,
  exact finite.exists_cov_of_smaller hle
end

lemma nil_of_path_to_self {x : P} (p : quiver.path x x) : p = path.nil :=
begin
  cases p with y hp q e,
  { refl },
  { have lt := covby.lt e,
    rw lt_iff_le_not_le at lt,
    exfalso, exact lt.right (le_of_path q) }
end

-- Auxiliary results to prove that if x < y, then we have a path from y to x
namespace path_of_lt
variables {x y : P}

noncomputable
def next (xn : P) (hpath : ∀ z : P, path z x → ¬z = y) (hlt : xn < y) (p : path xn x) :
  { x // xn ⋖ x ∧ x < y } :=
begin
  let k := classical.indefinite_description _ (exists_right_cov_of_lt hlt),
  use k.val,
  apply and.intro k.prop.left,
  by_cases heq : k.val = y,
  { exfalso,
    have hcov : xn ⋖ y :=
    begin
      rw ←heq, exact k.prop.left
    end,
    apply hpath _ (path.comp (path_of_cov hcov) p),
    refl },
    { rw lt_iff_le_and_ne,
      exact and.intro k.prop.right heq }
end

-- A cool use of Σ-types
noncomputable
def path_seq (hpath : ∀ z : P, path z x → ¬z = y) (hlt : x < y) :
  ℕ → Σ (w : P), { p : path w x // w < y }
| 0       := ⟨x, ⟨path.nil, hlt⟩⟩
| (n + 1) := let v := (next (path_seq n).1 hpath (path_seq n).2.prop (path_seq n).2.val) in
             ⟨v.val, ⟨path.comp (path_of_cov v.prop.left) (path_seq n).2.val, v.prop.right⟩⟩

-- Now we forget some of the structure of the previous sequence
noncomputable
def path_seq_forget (hpath : ∀ z : P, path z x → ¬z = y) (hlt : x < y) :
  ℕ → P := λ n, (path_seq hpath hlt n).1

-- Tis sequence is increasing
lemma path_seq_forget_cov_increasing (hpath : ∀ z : P, path z x → ¬z = y) (hlt : x < y) :
  ∀ n, path_seq_forget hpath hlt n ⋖ path_seq_forget hpath hlt (n + 1) :=
begin
  intro n,
  unfold path_seq_forget path_seq, simp,
  exact (next _ hpath (path_seq hpath hlt n).2.prop (path_seq hpath hlt n).2.val).prop.left
end

lemma path_seq_forget_increasing (hpath : ∀ z : P, path z x → ¬z = y) (hlt : x < y) :
  ∀ n, path_seq_forget hpath hlt n < path_seq_forget hpath hlt (n + 1) :=
begin
  intro n,
  apply covby.lt,
  apply path_seq_forget_cov_increasing
end

def path_of_lt {x y : P} (hlt : x < y) : ∃ (z : P) (p : path z x), z = y :=
begin
  by_contra' h,
  apply finite.no_infinite_increasing_seq (path_of_lt.path_seq_forget h hlt),
  apply path_of_lt.path_seq_forget_increasing
end

end path_of_lt

-- This is the result,
-- Highly nonconstructible
noncomputable
def path_of_lt {x y : P} (hlt : x < y) : path y x :=
begin
  have p := classical.indefinite_description _ (path_of_lt.path_of_lt hlt),
  simp at p,
  have q := classical.indefinite_description _ p.prop,
  rw ←q.prop,
  exact q.val
end

lemma eq_of_double_covby {x y z : P} (h1 : x ⋖ y) (h2 : x ⋖ z) (hle : y ≤ z) : y = z :=
eq_of_le_of_not_lt hle (h2.right h1.left)

lemma eq_of_length_zero_int {x y : P} (p : path x y) (hzero : int.of_nat p.length = 0) : x = y :=
begin
  apply path.eq_of_length_zero p,
  rw int.coe_nat_inj hzero,
end

end hasse


-- import .options

set_option trace.simplify.rewrite true

inductive palindrome {α : Type} : list α → Prop
| nil : palindrome []
| single (x : α) : palindrome [x]
| sandwich (x : α) (xs : list α) (hxs : palindrome xs) :
  palindrome ([x] ++ xs ++ [x])

open list
variable α : Type

lemma rev_core_nil {ys : list α} : reverse_core ys nil = reverse ys := by rw reverse

set_option pp.generalized_field_notation false

namespace example_for_rev_append_cons
def ys := [1,2,3,4]
constant y : ℕ
example : reverse (y :: ys) = reverse ys ++ [y] := rfl
-- GOAL: ⊢ reverse (x :: xs ++ ys) = reverse ys ++ reverse (x :: xs)
end example_for_rev_append_cons
-- we have positive example means this lemma is potentially provable, and we can safely use sorry keyword

lemma rev_append_cons (y : α) (ys : list α) :
  reverse (y :: ys) = reverse ys ++ [y] :=
begin
  induction ys,
  case nil {
    simp only [reverse, reverse_core, nil_append],
    split; refl,
  },
  case cons : x ys ih {
    sorry,
  },
end

lemma reverse_append {xs ys : list α} :
  reverse (xs ++ ys) = reverse ys ++ reverse xs :=
begin
  induction xs,
  case nil {
    rw [nil_append, reverse]; simp,
    rw [reverse_core, append_nil],
  },
  case cons : x xs ih {
    rw cons_append,
    iterate 2 { rw rev_append_cons },
    rw [←append_assoc, ih],
  },
end

lemma reverse_palindrome (xs : list α)
    (hxs : palindrome xs) :
  palindrome (reverse xs) :=
begin
  induction hxs,
  case palindrome.nil { exact palindrome.nil },
  case palindrome.single { exact palindrome.single hxs },
  case palindrome.sandwich : x xs hxs ih {
    simp only [reverse, reverse_append],
    -- type_check palindrome.sandwich _ (reverse xs) ih, -- palindrome ([?m_1] ++ reverse xs ++ [?m_1])
    exact palindrome.sandwich x (reverse xs) ih,
  },
end