/- Blah copyright
-/
import .easy_lemmas
import order.minimal
import order.hom.complete_lattice

/-!
This file defines a `base_family`, which is simply a nonempty antichain in a complete lattice,
and a host of matroidal terminology such as independent/dependent elements, spanning elements,
circuits, hyperplanes, bases and canopies for elements, etc. None of the material here uses
any nontrivial 'augmentation'-type axioms. First PR?
-/

universes u v

variables {α : Type u}

open set order_dual

section base_family

/-- A `base_family` is a nonempty antichain in a complete lattice -/
class base_family (α : Type u) extends complete_lattice α :=
(carrier : set α)
(nonempty : carrier.nonempty)
(is_antichain : is_antichain (≤) carrier)

/-- A `base_family` is also a base family in the dual order -/
instance {α : Type u} [base_family α]: base_family αᵒᵈ := {
carrier := of_dual ⁻¹' base_family.carrier,
nonempty := base_family.nonempty,
is_antichain := base_family.is_antichain.to_dual }

variables [base_family α] {x y z x' y' z'  i j a b b' c s t f d : α}

/-! #### Definitions / Existence -/

def base (x : α) : Prop := x ∈ (base_family.carrier : set α)

lemma exists_base (α : Type u) [base_family α] : ∃ (b : α), base b := base_family.nonempty

lemma base_antichain : is_antichain (≤) (base : set α) := base_family.is_antichain

/-- An element below a base is independent-/
def indep (x : α) := ∃ b, base b ∧ x ≤ b

/-- An element above a base is spanning-/
def spanning (x : α) :=  ∃ b, base b ∧ b ≤ x

/-- An element that is not independent is depedent-/
@[reducible] def dep (x : α) := ¬ indep x

-- `x` is loopy if it is 'disjoint' from every base
--def loopy (x : α) := ∀ b, base b → x ⊓ b = ⊥

lemma mem_lower_set_base_iff_indep : indep i ↔ i ∈ lower_closure (base : set α) :=
⟨λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩, λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩⟩

lemma indep.not_dep (hi : indep i) : ¬ dep i := by rwa [not_not]

lemma dep.not_indep (hx : dep x) : ¬ indep x := hx

lemma not_dep_iff_indep : ¬ dep i ↔ indep i  := by rw [not_not]

lemma indep_or_dep (i : α) : indep i ∨ dep i := em _

lemma not_indep_iff_dep : ¬ indep i ↔ dep i := iff.rfl

lemma exists_indep : ∃ (i : α), indep i := (exists_base α).imp (λ b hb, ⟨b,hb,rfl.le⟩)

lemma base.indep (h : base b) : indep b := ⟨b, h, rfl.le⟩

@[simp] lemma mem_upper_set_base_iff_spanning : s ∈ upper_closure (base : set α) ↔ spanning s :=
⟨λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩, λ ⟨b,hb,hbx⟩, ⟨b,hb,hbx⟩⟩

lemma spanning.spanning_of_le (hs : spanning s) (hst : s ≤ t) : spanning t :=
exists.elim hs (λ b hb, ⟨b, hb.1, hb.2.trans hst⟩)

lemma spanning.sup_right_spanning (hs : spanning s) (x : α) : spanning (s ⊔ x) :=
hs.spanning_of_le le_sup_left

lemma spanning.sup_left_spanning (hs : spanning s) (x : α) : spanning (x ⊔ s) :=
hs.spanning_of_le le_sup_right

lemma spanning_iff_basis_le : spanning s ↔ ∃ b, base b ∧ b ≤ s := iff.rfl

lemma base.spanning (h : base b) : spanning b := ⟨b, h, rfl.le⟩

lemma base.spanning_of_le (h : base b) (hbs : b ≤ s) : spanning s :=
h.spanning.spanning_of_le hbs

-- NB : avoid this one - prefer `x ⊔ b` over `b ⊔ x`
lemma base.sup_right_spanning (hb : base b) (x : α) : spanning (b ⊔ x) :=
hb.spanning.sup_right_spanning _

lemma base.sup_left_spanning (hb : base b) (x : α) : spanning (x ⊔ b) :=
hb.spanning.sup_left_spanning _

lemma indep_iff_le_base : indep i ↔ ∃ b, base b ∧ i ≤ b := iff.rfl

lemma indep.indep_of_le (hi : indep i) (hji : j ≤ i) : indep j :=
exists.elim hi (λ b hb, ⟨b, ⟨hb.1, hji.trans hb.2⟩⟩)

lemma indep.inf_left_indep (hi : indep i) (x : α) : indep (x ⊓ i) :=
hi.indep_of_le inf_le_right

-- NB : avoid this one - prefer `x ⊓ i` over `i ⊓ x`
lemma indep.inf_right_indep (hi : indep i) (x : α) : indep (i ⊓ x) :=
hi.indep_of_le inf_le_left

lemma bot_indep (α : Type u) [base_family α] : indep (⊥ : α) :=
exists.elim (exists_base α) (λ b h, ⟨b, h, bot_le⟩)

lemma dep.dep_of_lt (hx : dep x) (hxy : x ≤ y) : dep y :=
not_indep_iff_dep.mp (λ h, (hx.not_indep (h.indep_of_le hxy)).elim)

lemma base.indep_of_le (hb : base b) (hi : i ≤ b) : indep i := ⟨b,hb,hi⟩

lemma base.inf_left_indep (hb : base b) (x : α) : indep (x ⊓ b) :=
hb.indep.indep_of_le inf_le_right

-- NB : avoid this one - prefer `x ⊓ b` over `b ⊓ x`
lemma base.inf_right_indep (hb : base b) (x : α) : indep (b ⊓ x) :=
hb.indep.indep_of_le inf_le_left

lemma top_spanning (α : Type u) [base_family α] : spanning (⊤ : α) :=
exists.elim (exists_base α) (λ b hb, ⟨b,hb,le_top⟩)

lemma indep.base (hi : indep i) (hmax : ∀ j, indep j → i ≤ j → i = j) : base i :=
exists.elim hi (λ b ⟨hb, hbi⟩, (hmax b hb.indep hbi).substr hb)

lemma base.eq_of_le_base (hb : base b) (hx : base x) (hxb : b ≤ x) : b = x :=
by_contra (λ hne, base_antichain hb hx hne hxb)

lemma base.eq_of_le_indep (hb : base b) (hi : indep i) (hbi : b ≤ i) : b = i :=
hbi.antisymm (exists.elim hi (λ b' ⟨hb',hib'⟩,(hb.eq_of_le_base hb' (hbi.trans hib')).substr hib'))

lemma base.eq_of_spanning_le (hb : base b) (hs : spanning s) (hsb : s ≤ b) : s = b :=
hsb.antisymm (exists.elim hs (λ b' ⟨hb',hb's⟩, (hb'.eq_of_le_base hb (hb's.trans hsb)).subst hb's))

lemma base.lt_not_indep (hb : base b) (hbx : b < x) : ¬ indep x :=
λ hx, hbx.ne (hb.eq_of_le_indep hx hbx.le)

lemma base.lt_not_base (hb : base b) (hbx : b < x) : ¬ base x :=
λ h, hb.lt_not_indep hbx h.indep

lemma base.not_base_of_lt (hb : base b) (hxb : x < b) : ¬ base x :=
λ hx, (hx.lt_not_base hxb) hb

lemma indep.not_base_of_lt (hi : indep i) (hxi : x < i) : ¬ base x :=
λ hb, hb.lt_not_indep hxi hi

lemma spanning.eq_of_le_base (hs : spanning s) (hb : base b) (hsb : s ≤ b) : s = b :=
hb.eq_of_spanning_le hs hsb

lemma base_iff_maximal_indep : base b ↔ (maximals (≤) indep) b :=
⟨λ hb, ⟨hb.indep,λ i hi hbi, hb.eq_of_le_indep hi hbi⟩,
  λ ⟨⟨b',hb',hbb'⟩, hb''⟩, (hb'' hb'.indep hbb').substr hb'⟩

lemma base_iff_minimal_spanning : base b ↔ b ∈ (minimals (≤) (spanning : set α)) :=
⟨λ hb, ⟨hb.spanning,λ s hs hbs, (hb.eq_of_spanning_le hs hbs).symm⟩,
  λ ⟨⟨b',hb',hbb'⟩, hb''⟩, (hb'' hb'.spanning hbb').substr hb'⟩

section basis

/-- A basis for `x` is a maximal element that is independent and below `x` -/
def basis_for (i x : α) := indep i ∧ i ≤ x ∧ ∀ j, indep j → j ≤ x → i ≤ j → i = j

infix ` basis_for `:50 := basis_for

/-- `x` has rank zero if `⊥` is a basis for `x` -/
def rank_zero (x : α) := ⊥ basis_for x

lemma basis_for.indep (h : b basis_for x) : indep b := h.1

lemma basis_for.le (h : b basis_for x) : b ≤ x := h.2.1

lemma basis_iff : i basis_for x ↔ indep i ∧ i ≤ x ∧ ∀ j, indep j → j ≤ x → i ≤ j → i = j := iff.rfl

lemma indep.basis_for (hi : indep i) (hix : i ≤ x) (h : ∀ j, indep j → j ≤ x → i ≤ j → i = j) :
  i basis_for x :=
⟨hi,  hix, h⟩

lemma indep.basis_self (hi : indep i) : i basis_for i :=
hi.basis_for rfl.le (λ h hj, flip le_antisymm)

lemma basis_self_iff_indep : i basis_for i ↔ indep i :=
⟨λ h, h.indep, indep.basis_self⟩

lemma base.basis_sup_left (hb : base b) (x : α) : b basis_for (b ⊔ x) :=
hb.indep.basis_for le_sup_left (λ j hj hjx hbj, hb.eq_of_le_indep hj hbj)

lemma base.basis_sup_right (hb : base b) (x : α) : b basis_for (x ⊔ b) :=
by {rw sup_comm, exact hb.basis_sup_left x}

lemma basis_for.eq_of_le_indep (h : b basis_for x) (hy : indep y) (hby : b ≤ y) (hyx : y ≤ x) :
  b = y := (h.2.2 _ hy hyx hby)

lemma basis_antichain (x : α) : is_antichain (≤) {i | i basis_for x} :=
λ i hi j hj hne hle, hne (hi.eq_of_le_indep hj.indep hle hj.le)

lemma basis_for.not_indep_of_lt (hb : b basis_for x) (hby : b < y) (hyx : y ≤ x) : ¬ indep y :=
λ h, hby.ne (hb.eq_of_le_indep h hby.le hyx)

lemma basis_for.basis_of_le (hi : i basis_for x) (hiy : i ≤ y) (hyx : y ≤ x) : i basis_for y :=
hi.indep.basis_for hiy (λ j hj hjy hij, hi.eq_of_le_indep hj hij (hjy.trans hyx))

lemma basis_for.basis_sup_of_le (hi : i basis_for x) (hyx : y ≤ x) : i basis_for (i ⊔ y) :=
hi.basis_of_le le_sup_left (sup_le hi.le hyx)

lemma basis_of_basis_sup_of_le (hi : i basis_for x ⊔ i) (hix : i ≤ x) : i basis_for x :=
hi.indep.basis_for hix (λ j hj hjx hij, hi.eq_of_le_indep hj hij (le_sup_of_le_left hjx))

lemma indep.not_basis_of_lt (hi : indep i) (hji : j < i) : ¬ j basis_for i :=
λ h, h.not_indep_of_lt hji rfl.le hi

lemma basis_for.not_basis_of_lt (hi : i basis_for x) (hji : j < i) : ¬ j basis_for x :=
λ h, h.not_indep_of_lt hji hi.le hi.indep

lemma basis_for.indep_of_le (hb : b basis_for x) (hib : i ≤ b)  : indep i :=
(hb.indep).indep_of_le hib

lemma base.basis_top (hb : base b) : b basis_for ⊤ :=
hb.indep.basis_for le_top (λ j hj hbj h, hb.eq_of_le_indep hj h)

lemma basis_top_iff : b basis_for ⊤ ↔ base b :=
⟨λ h, h.indep.base (λ j hj hbj, h.eq_of_le_indep hj hbj le_top), base.basis_top⟩

lemma basis_bot_iff : x basis_for ⊥ ↔ x = ⊥ :=
⟨λ h, le_bot_iff.mp h.le, by {rintro rfl, exact (bot_indep α).basis_self}⟩

lemma basis_for.basis_sup_self (hi : i basis_for x) : i basis_for (x ⊔ i) :=
hi.indep.basis_for le_sup_right
  (λ j hj hjix hij, (hi.eq_of_le_indep hj hij (by {rwa [sup_eq_left.mpr hi.le] at hjix})))

lemma indep.eq_of_basis (hi : indep i) (hj : j basis_for i) : i = j :=
(hj.eq_of_le_indep hi hj.le rfl.le).symm

end basis

section canopy

/-- A canopy for `x` is a minimal element that is spanning and above `x` -/
def canopy_for (s x : α) := spanning s ∧ x ≤ s ∧ ∀ t, spanning t → x ≤ t → t ≤ s → s = t

infix ` canopy_for `:50 := canopy_for

lemma spanning.canopy_for (hs : spanning s) (hxs : x ≤ s)
  (h : ∀ t, spanning t → x ≤ t → t ≤ s → s = t) : s canopy_for x :=
⟨hs, hxs, h⟩

lemma canopy_for_iff :
  s canopy_for x ↔ spanning s ∧ x ≤ s ∧ ∀ s', spanning s' → x ≤ s' → s' ≤ s → s = s' := iff.rfl

lemma canopy_for.spanning (h : s canopy_for x) : spanning s := h.1

lemma canopy_for.le (h : s canopy_for x) : x ≤ s := h.2.1

lemma canopy_for.eq_of_spanning_le (hs : s canopy_for x) (ht : spanning t) (hxt : x ≤ t)
(hts : t ≤ s) :
  t = s := (hs.2.2 _ ht hxt hts).symm

lemma canopy_antichain (x : α) : is_antichain (≤) {s | s canopy_for x} :=
λ s hs t ht hne hle, hne (ht.eq_of_spanning_le hs.spanning hs.le hle)

lemma canopy_for.not_spanning_of_lt (hs : s canopy_for x) (hts : t < s) (hxt : x ≤ t):
  ¬ spanning t :=
λ h, hts.ne (hs.eq_of_spanning_le h hxt hts.le)

lemma canopy_for.canopy_for_of_le (hs : s canopy_for x) (hys : y ≤ s) (hxy : x ≤ y) :
  s canopy_for y :=
@basis_for.basis_of_le αᵒᵈ _ _ _ _ hs hys hxy

lemma canopy_for_top_iff : x canopy_for ⊤ ↔ x = ⊤ :=
@basis_bot_iff αᵒᵈ _ _

lemma canopy_for_bot_iff : b canopy_for ⊥ ↔ base b :=
@basis_top_iff αᵒᵈ _ _

end canopy

section dual

lemma indep.spanning_dual (hi : indep i) : spanning (to_dual i) := hi

@[simp] lemma spanning_dual_iff_indep : spanning (to_dual i) ↔ indep i := iff.rfl

lemma spanning.indep_dual (hs : spanning s) : indep (to_dual s) := hs

@[simp] lemma indep_dual_iff_spanning : indep (to_dual s) ↔ spanning s := iff.rfl

lemma base.to_dual (hb : base b) : base (to_dual b) := hb

end dual

section span_closure

/-- `x` spans `y` if every basis for `x` is a basis for `y ⊔ x` -/
def spans (x y : α) := ∀ i, i basis_for x → i basis_for (y ⊔ x)

infix ` spans `:50 := spans

def closure (x : α) : α := Sup {y | ∀ i, i basis_for x → i basis_for (y ⊔ x)}

lemma spans.basis_for (hxy : x spans y) (hix : i basis_for x) : i basis_for (y ⊔ x) := hxy _ hix

lemma spans_iff_forall : (x spans y) ↔ ∀ i, i basis_for x → i basis_for (y ⊔ x) := iff.rfl

lemma le_closure_self (x : α) : x ≤ closure x := le_Sup (by simp)

@[simp] lemma closure_top_eq (α : Type u) [base_family α ]: closure (⊤ : α) = ⊤ :=
  eq_top_iff.mpr (le_closure_self _)

lemma spans_self (x : α) : x spans x := λ i hi, by rwa sup_idem

/-- `x` controls `y` if every canopy for `x` is a canopy for `y ⊓ x`-/
def controls (x y : α) := ∀ s, s canopy_for x → s canopy_for y ⊓ x

end span_closure

section circuit_hyperplane

/-- A circuit is a minimal dependent element-/
def circuit (x : α) := x ∈ minimals (≤) (indep : set α)ᶜ

/-- A hyperplane is a maximally nonspanning element-/
def hyperplane (x : α) := x ∈ maximals (≤) (spanning : set α)ᶜ

lemma circuit.not_indep (hc : circuit c) : ¬ indep c := hc.1

lemma circuit.dep (hc : circuit c) : dep c := hc.1

lemma circuit.eq_of_dep_le (hc : circuit c) (hd : dep d) (hdc : d ≤ c) : d = c := (hc.2 hd hdc).symm

lemma circuit.indep_of_lt (hc : circuit c) (hic : i < c) : indep i :=
by_contra (λ h, hic.ne (hc.eq_of_dep_le h hic.le))

lemma circuit_antichain : is_antichain (≤) (circuit : set α) :=
λ _ h _ h' hne hle, hne (h'.eq_of_dep_le h.dep hle)

lemma hyperplane.not_spanning (hf : hyperplane f) : ¬ spanning f := hf.1

lemma hyperplane.eq_of_le_nonspanning (hf : hyperplane f) (hx : ¬spanning x) (hfx : f ≤ x) :
  f = x := hf.2 hx hfx

lemma hyperplane.spanning_of_lt (hf : hyperplane f) (hlt : f < s) : spanning s :=
by_contra (λ h, hlt.ne (hf.eq_of_le_nonspanning h hlt.le))

lemma hyperplane_antichain : is_antichain (≤) (hyperplane : set α) :=
λ f h f' h' hne hle, hne (h.eq_of_le_nonspanning h'.not_spanning hle)

end circuit_hyperplane

end base_family


import tactic
import data.rel
import data.vector
import data.nat.basic
import ruby.defs

open rel vector nat

variables {α β γ δ ε φ : Type}

/- Delay-/

def D_fun (f : $α) : $α
  := λ n, f (n+1)

def D_fun' (f : $α) : $α
  := λ n, f (n-1)

lemma D_fun_inv_right (f : $α) : D_fun (D_fun' f) = f :=
begin
  unfold D_fun D_fun',
  simp,
end

lemma D_fun_inv_left (f : $α) : D_fun' (D_fun f) = f :=
begin
  unfold D_fun D_fun',
  simp,
end

def D : rel ($α) ($α)
  := to_rel D_fun

lemma D_inj : function.injective (@D_fun α) :=
begin
  intros f g h,
  ext x,
  have h' := congr_fun h (x-1),
  unfold D_fun at h',
  simpa using h',
end

lemma D_surj : function.surjective (@D_fun α) :=
begin
  intro f,
  use (λ n, f (n - 1)),
  unfold D_fun,
  simp,
end

lemma D_inv_left : (@D α)† ;; D = idd
  := @conv_inv_left ($α) ($α) D D_fun rfl D_surj

lemma D_inv_right : @D α ;; D† = idd
  := @conv_inv_right ($α) ($α) D D_fun rfl D_inj

/- Basics -/

def fork : rel α (α × α)
  := λ x ⟨y,z⟩, x=y ∧ x=z

def full : rel α β
  := λ x y, true

@[simp]
lemma full_def {a : α} {b : β} : full a b
  := by unfold full

def empt : rel α β
  := λ x y, false

def nill : rel (vector α 0) (vector β 0)
  := full

@[simp]
lemma nill_def {a : vector α 0} {b : vector β 0} : nill a b
  := by unfold nill

def π₁ : rel (α × β) α
  := to_rel prod.fst

@[simp]
lemma π₁_def {a c : α} {b : β} : π₁ (a, b) c ↔ a = c
  := by unfold π₁ to_rel prod.fst

def π₂ : rel (α × β) β
  := to_rel prod.snd

@[simp]
lemma π₂_def {a : α} {b c : β} : π₂ (a, b) c ↔ b = c
  := by unfold π₂ to_rel prod.snd

/- Left shift and right shift -/

def rsh_fun : α × (β × γ) → (α × β) × γ
  := λ ⟨x,⟨y,z⟩⟩, ⟨⟨x,y⟩,z⟩

def rsh : rel (α × (β × γ)) ((α × β) × γ)
  := to_rel rsh_fun

@[simp]
def rsh_def {a a' : α} {b b' : β} {c c' : γ} : rsh (a,(b,c)) ((a',b'),c') ↔ a=a' ∧ b=b' ∧ c=c' :=
begin
  unfold rsh to_rel rsh_fun,
  split, intro h,
  have ha : a = a' := congr_arg (prod.fst ∘ prod.fst) h,
  have hb : b = b' := congr_arg (prod.snd ∘ prod.fst) h,
  have hc : c = c' := congr_arg prod.snd h,
  exact ⟨ha,hb,hc⟩,
  rintro ⟨ha,hb,hc⟩,
  rwa [ha, hb, hc],
end

lemma rsh_inj : function.injective (@rsh_fun α β γ) :=
begin
  rintro ⟨a,⟨b,c⟩⟩ ⟨x,⟨y,z⟩⟩ h,
  unfold rsh_fun at h,
  simp at *,
  tauto,
end

lemma rsh_surj : function.surjective (@rsh_fun α β γ) :=
begin
  rintro ⟨⟨a,b⟩,c⟩,
  use ⟨a,⟨b,c⟩⟩,
  refl,
end

lemma rsh_inv_left : (@rsh α β γ)† ;; rsh = idd
  := @conv_inv_left (α × (β × γ)) ((α × β) × γ) rsh rsh_fun rfl rsh_surj

lemma rsh_inv_right : @rsh α β γ ;; rsh† = idd
  := @conv_inv_right (α × (β × γ)) ((α × β) × γ) rsh rsh_fun rfl rsh_inj

def lsh : rel ((α × β) × γ) (α × (β × γ)) := rsh†

/- Swap -/

def swap : rel (α × β) (β × α)
  := to_rel prod.swap

@[simp]
lemma swap_def {a d : α} {b c : β} : swap (a,b) (c,d) ↔ a=d ∧ b=c :=
begin
  unfold swap to_rel prod.swap,
  simp only [prod.mk.inj_iff, and.comm],
end

lemma swap_inv_left : (@swap α β)† ;; swap = idd
  := @conv_inv_left (α × β) (β × α) swap prod.swap rfl prod.swap_surjective

lemma swap_inv_right : @swap α β ;; swap† = idd
  := @conv_inv_right (α × β) (β × α) swap prod.swap rfl prod.swap_injective

/- Fork2 -/

def fork2 : rel (α × α) ((α × β) × β)
  := π₁† ;; [ fork† , fork ] ;; rsh

/- Append right and append left -/

def apr_fun (n : ℕ) : vector α n × α → vector α (n+1)
  := λ ⟨xs,x⟩, xs.append (x ::ᵥ nil)

def apr (n : ℕ) : rel (vector α n × α) (vector α (n+1))
  := to_rel (apr_fun n)

@[simp]
def apr_def {n : ℕ} {xs : vector α n} {x : α} {ys : vector α (n+1)} : apr n (xs,x) ys ↔ append xs (x ::ᵥ nil) = ys
  := by unfold apr to_rel apr_fun

lemma apr_inj (n : ℕ) : function.injective (@apr_fun α n) :=
begin
  rintro ⟨xs,x⟩ ⟨ys,y⟩ h,
  unfold apr_fun at h,
  sorry
end

lemma apr_inv_right (n : ℕ) : (@apr α n ;; (apr n)†) = idd
  := @conv_inv_right (vector α n × α) (vector α (n+1)) (apr n) (apr_fun n) rfl (apr_inj n)

def apl_fun (n : ℕ) : α × vector α n → vector α (n+1)
  := λ ⟨x,xs⟩, x ::ᵥ xs

def apl (n : ℕ) : rel (α × vector α n) (vector α (n+1))
  := to_rel (apl_fun n)

@[simp]
def apl_def {n : ℕ} {x : α} {xs : vector α n} {ys : vector α (n+1)} : apl n (x,xs) ys ↔ (x ::ᵥ xs) = ys
  := by unfold apl to_rel apl_fun

lemma apl_inv_right (n : ℕ) : (@apl α n ;; (apl n)†) = idd
  := sorry--@conv_inv_right (vector α n × α) (vector α (n+1)) (apr n) (apr_fun n) rfl (apr_inj n)


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
-/
import algebra.big_operators.basic
import algebra.field.basic
import algebra.hom.equiv
import algebra.ring.opposite

/-!
# (Semi)ring equivs

In this file we define extension of `equiv` called `ring_equiv`, which is a datatype representing an
isomorphism of `semiring`s, `ring`s, `division_ring`s, or `field`s. We also introduce the
corresponding group of automorphisms `ring_aut`.

## Notations

* ``infix ` ≃+* `:25 := ring_equiv``

The extended equiv have coercions to functions, and the coercion is the canonical notation when
treating the isomorphism as maps.

## Implementation notes

The fields for `ring_equiv` now avoid the unbundled `is_mul_hom` and `is_add_hom`, as these are
deprecated.

Definition of multiplication in the groups of automorphisms agrees with function composition,
multiplication in `equiv.perm`, and multiplication in `category_theory.End`, not with
`category_theory.comp`.

## Tags

equiv, mul_equiv, add_equiv, ring_equiv, mul_aut, add_aut, ring_aut
-/

open_locale big_operators

variables {F α β R S S' : Type*}

set_option old_structure_cmd true

/-- An equivalence between two (non-unital non-associative semi)rings that preserves the
algebraic structure. -/
structure ring_equiv (R S : Type*) [has_mul R] [has_add R] [has_mul S] [has_add S]
  extends R ≃ S, R ≃* S, R ≃+ S

infix ` ≃+* `:25 := ring_equiv

/-- The "plain" equivalence of types underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_equiv

/-- The equivalence of additive monoids underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_add_equiv

/-- The equivalence of multiplicative monoids underlying an equivalence of (semi)rings. -/
add_decl_doc ring_equiv.to_mul_equiv

/-- `ring_equiv_class F R S` states that `F` is a type of ring structure preserving equivalences.
You should extend this class when you extend `ring_equiv`. -/
class ring_equiv_class (F : Type*) (R S : out_param Type*)
  [has_mul R] [has_add R] [has_mul S] [has_add S]
  extends mul_equiv_class F R S :=
(map_add : ∀ (f : F) a b, f (a + b) = f a + f b)

namespace ring_equiv_class

@[priority 100] -- See note [lower instance priority]
instance to_add_equiv_class (F R S : Type*)
  [has_mul R] [has_add R] [has_mul S] [has_add S] [h : ring_equiv_class F R S] :
  add_equiv_class F R S :=
{ coe := coe_fn,
  .. h }

@[priority 100] -- See note [lower instance priority]
instance to_ring_hom_class (F R S : Type*)
  [non_assoc_semiring R] [non_assoc_semiring S] [h : ring_equiv_class F R S] :
  ring_hom_class F R S :=
{ coe := coe_fn,
  coe_injective' := fun_like.coe_injective,
  map_zero := map_zero,
  map_one := map_one,
  .. h }

@[priority 100] -- See note [lower instance priority]
instance to_non_unital_ring_hom_class (F R S : Type*)
  [non_unital_non_assoc_semiring R] [non_unital_non_assoc_semiring S] [h : ring_equiv_class F R S] :
  non_unital_ring_hom_class F R S :=
{ coe := coe_fn,
  coe_injective' := fun_like.coe_injective,
  map_zero := map_zero,
  .. h }

end ring_equiv_class

instance [has_mul α] [has_add α] [has_mul β] [has_add β] [ring_equiv_class F α β] :
  has_coe_t F (α ≃+* β) :=
⟨λ f, { to_fun := f, inv_fun := equiv_like.inv f, left_inv := equiv_like.left_inv f,
  right_inv := equiv_like.right_inv f, map_mul' := map_mul f, map_add' := map_add f }⟩

namespace ring_equiv

section basic

variables [has_mul R] [has_add R] [has_mul S] [has_add S] [has_mul S'] [has_add S']

instance : ring_equiv_class (R ≃+* S) R S :=
{ coe := to_fun,
  inv := inv_fun,
  coe_injective' := λ e f h₁ h₂, by { cases e, cases f, congr' },
  map_add := map_add',
  map_mul := map_mul',
  left_inv := ring_equiv.left_inv,
  right_inv := ring_equiv.right_inv }

instance : has_coe_to_fun (R ≃+* S) (λ _, R → S) := ⟨ring_equiv.to_fun⟩

@[simp] lemma to_equiv_eq_coe (f : R ≃+* S) : f.to_equiv = f := rfl

@[simp] lemma to_fun_eq_coe (f : R ≃+* S) : f.to_fun = f := rfl

@[simp] lemma coe_to_equiv (f : R ≃+* S) : ⇑(f : R ≃ S) = f := rfl

/-- A ring isomorphism preserves multiplication. -/
protected lemma map_mul (e : R ≃+* S) (x y : R) : e (x * y) = e x * e y := map_mul e x y

/-- A ring isomorphism preserves addition. -/
protected lemma map_add (e : R ≃+* S) (x y : R) : e (x + y) = e x + e y := map_add e x y

/-- Two ring isomorphisms agree if they are defined by the
    same underlying function. -/
@[ext] lemma ext {f g : R ≃+* S} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

@[simp] theorem coe_mk (e e' h₁ h₂ h₃ h₄) :
  ⇑(⟨e, e', h₁, h₂, h₃, h₄⟩ : R ≃+* S) = e := rfl

@[simp] theorem mk_coe (e : R ≃+* S) (e' h₁ h₂ h₃ h₄) :
  (⟨e, e', h₁, h₂, h₃, h₄⟩ : R ≃+* S) = e := ext $ λ _, rfl

protected lemma congr_arg {f : R ≃+* S} {x x' : R} : x = x' → f x = f x' := fun_like.congr_arg f

protected lemma congr_fun {f g : R ≃+* S} (h : f = g) (x : R) : f x = g x := fun_like.congr_fun h x

protected lemma ext_iff {f g : R ≃+* S} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

@[simp] lemma to_add_equiv_eq_coe (f : R ≃+* S) : f.to_add_equiv = ↑f := rfl

@[simp] lemma to_mul_equiv_eq_coe (f : R ≃+* S) : f.to_mul_equiv = ↑f := rfl

@[simp, norm_cast] lemma coe_to_mul_equiv (f : R ≃+* S) : ⇑(f : R ≃* S) = f := rfl

@[simp, norm_cast] lemma coe_to_add_equiv (f : R ≃+* S) : ⇑(f : R ≃+ S) = f := rfl

/-- The `ring_equiv` between two semirings with a unique element. -/
def ring_equiv_of_unique {M N}
  [unique M] [unique N] [has_add M] [has_mul M] [has_add N] [has_mul N] : M ≃+* N :=
{ ..add_equiv.add_equiv_of_unique,
  ..mul_equiv.mul_equiv_of_unique}

instance {M N} [unique M] [unique N] [has_add M] [has_mul M] [has_add N] [has_mul N] :
  unique (M ≃+* N) :=
{ default := ring_equiv_of_unique,
  uniq := λ _, ext $ λ x, subsingleton.elim _ _ }

variable (R)

/-- The identity map is a ring isomorphism. -/
@[refl] protected def refl : R ≃+* R := { .. mul_equiv.refl R, .. add_equiv.refl R }

@[simp] lemma refl_apply (x : R) : ring_equiv.refl R x = x := rfl

@[simp] lemma coe_add_equiv_refl : (ring_equiv.refl R : R ≃+ R) = add_equiv.refl R := rfl

@[simp] lemma coe_mul_equiv_refl : (ring_equiv.refl R : R ≃* R) = mul_equiv.refl R := rfl

instance : inhabited (R ≃+* R) := ⟨ring_equiv.refl R⟩

variables {R}

/-- The inverse of a ring isomorphism is a ring isomorphism. -/
@[symm] protected def symm (e : R ≃+* S) : S ≃+* R :=
{ .. e.to_mul_equiv.symm, .. e.to_add_equiv.symm }

/-- See Note [custom simps projection] -/
def simps.symm_apply (e : R ≃+* S) : S → R := e.symm

initialize_simps_projections ring_equiv (to_fun → apply, inv_fun → symm_apply)

@[simp] lemma inv_fun_eq_symm (f : R ≃+* S) : f.inv_fun = f.symm := rfl

@[simp] lemma symm_symm (e : R ≃+* S) : e.symm.symm = e := ext $ λ x, rfl

lemma symm_bijective : function.bijective (ring_equiv.symm : (R ≃+* S) → (S ≃+* R)) :=
equiv.bijective ⟨ring_equiv.symm, ring_equiv.symm, symm_symm, symm_symm⟩

@[simp] lemma mk_coe' (e : R ≃+* S) (f h₁ h₂ h₃ h₄) :
  (ring_equiv.mk f ⇑e h₁ h₂ h₃ h₄ : S ≃+* R) = e.symm :=
symm_bijective.injective $ ext $ λ x, rfl

@[simp] lemma symm_mk (f : R → S) (g h₁ h₂ h₃ h₄) :
  (mk f g h₁ h₂ h₃ h₄).symm =
  { to_fun := g, inv_fun := f, ..(mk f g h₁ h₂ h₃ h₄).symm} := rfl

/-- Transitivity of `ring_equiv`. -/
@[trans] protected def trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') : R ≃+* S' :=
{ .. (e₁.to_mul_equiv.trans e₂.to_mul_equiv), .. (e₁.to_add_equiv.trans e₂.to_add_equiv) }

@[simp] lemma trans_apply (e₁ : R ≃+* S) (e₂ : S ≃+* S') (a : R) :
  e₁.trans e₂ a = e₂ (e₁ a) := rfl

protected lemma bijective (e : R ≃+* S) : function.bijective e := equiv_like.bijective e
protected lemma injective (e : R ≃+* S) : function.injective e := equiv_like.injective e
protected lemma surjective (e : R ≃+* S) : function.surjective e := equiv_like.surjective e

@[simp] lemma apply_symm_apply (e : R ≃+* S) : ∀ x, e (e.symm x) = x := e.to_equiv.apply_symm_apply
@[simp] lemma symm_apply_apply (e : R ≃+* S) : ∀ x, e.symm (e x) = x := e.to_equiv.symm_apply_apply

lemma image_eq_preimage (e : R ≃+* S) (s : set R) : e '' s = e.symm ⁻¹' s :=
e.to_equiv.image_eq_preimage s

end basic

section opposite
open mul_opposite

/-- A ring iso `α ≃+* β` can equivalently be viewed as a ring iso `αᵐᵒᵖ ≃+* βᵐᵒᵖ`. -/
@[simps]
protected def op {α β} [has_add α] [has_mul α] [has_add β] [has_mul β] :
  (α ≃+* β) ≃ (αᵐᵒᵖ ≃+* βᵐᵒᵖ) :=
{ to_fun    := λ f, { ..f.to_add_equiv.mul_op, ..f.to_mul_equiv.op},
  inv_fun   := λ f, { ..add_equiv.mul_op.symm f.to_add_equiv, ..mul_equiv.op.symm f.to_mul_equiv },
  left_inv  := λ f, by { ext, refl },
  right_inv := λ f, by { ext, refl } }

/-- The 'unopposite' of a ring iso `αᵐᵒᵖ ≃+* βᵐᵒᵖ`. Inverse to `ring_equiv.op`. -/
@[simp] protected def unop {α β} [has_add α] [has_mul α] [has_add β] [has_mul β] :
  (αᵐᵒᵖ ≃+* βᵐᵒᵖ) ≃ (α ≃+* β) := ring_equiv.op.symm

section non_unital_comm_semiring

variables (R) [non_unital_comm_semiring R]

/-- A non-unital commutative ring is isomorphic to its opposite. -/
def to_opposite : R ≃+* Rᵐᵒᵖ :=
{ map_add' := λ x y, rfl,
  map_mul' := λ x y, mul_comm (op y) (op x),
  .. mul_opposite.op_equiv }

@[simp]
lemma to_opposite_apply (r : R) : to_opposite R r = op r := rfl

@[simp]
lemma to_opposite_symm_apply (r : Rᵐᵒᵖ) : (to_opposite R).symm r = unop r := rfl

end non_unital_comm_semiring

end opposite

section non_unital_semiring

variables [non_unital_non_assoc_semiring R] [non_unital_non_assoc_semiring S]
  (f : R ≃+* S) (x y : R)

/-- A ring isomorphism sends zero to zero. -/
protected lemma map_zero : f 0 = 0 := map_zero f

variable {x}

protected lemma map_eq_zero_iff : f x = 0 ↔ x = 0 := add_equiv_class.map_eq_zero_iff f

lemma map_ne_zero_iff : f x ≠ 0 ↔ x ≠ 0 := add_equiv_class.map_ne_zero_iff f

/-- Produce a ring isomorphism from a bijective ring homomorphism. -/
noncomputable def of_bijective [non_unital_ring_hom_class F R S] (f : F)
  (hf : function.bijective f) : R ≃+* S :=
{ map_mul' := map_mul f,
  map_add' := map_add f,
  .. equiv.of_bijective f hf,}

@[simp] lemma coe_of_bijective [non_unital_ring_hom_class F R S] (f : F)
  (hf : function.bijective f) : (of_bijective f hf : R → S) = f := rfl

lemma of_bijective_apply [non_unital_ring_hom_class F R S] (f : F)
  (hf : function.bijective f) (x : R) : of_bijective f hf x = f x := rfl

/-- A family of ring isomorphisms `Π j, (R j ≃+* S j)` generates a
ring isomorphisms between `Π j, R j` and `Π j, S j`.

This is the `ring_equiv` version of `equiv.Pi_congr_right`, and the dependent version of
`ring_equiv.arrow_congr`.
-/
@[simps apply]
def Pi_congr_right {ι : Type*} {R S : ι → Type*}
  [Π i, non_unital_non_assoc_semiring (R i)] [Π i, non_unital_non_assoc_semiring (S i)]
  (e : Π i, R i ≃+* S i) : (Π i, R i) ≃+* Π i, S i :=
{ to_fun := λ x j, e j (x j),
  inv_fun := λ x j, (e j).symm (x j),
  .. @mul_equiv.Pi_congr_right ι R S _ _ (λ i, (e i).to_mul_equiv),
  .. @add_equiv.Pi_congr_right ι R S _ _ (λ i, (e i).to_add_equiv) }

@[simp]
lemma Pi_congr_right_refl {ι : Type*} {R : ι → Type*} [Π i, non_unital_non_assoc_semiring (R i)] :
  Pi_congr_right (λ i, ring_equiv.refl (R i)) = ring_equiv.refl _ := rfl

@[simp]
lemma Pi_congr_right_symm {ι : Type*} {R S : ι → Type*}
  [Π i, non_unital_non_assoc_semiring (R i)] [Π i, non_unital_non_assoc_semiring (S i)]
  (e : Π i, R i ≃+* S i) : (Pi_congr_right e).symm = (Pi_congr_right $ λ i, (e i).symm) := rfl

@[simp]
lemma Pi_congr_right_trans {ι : Type*} {R S T : ι → Type*}
  [Π i, non_unital_non_assoc_semiring (R i)] [Π i, non_unital_non_assoc_semiring (S i)]
  [Π i, non_unital_non_assoc_semiring (T i)]
  (e : Π i, R i ≃+* S i) (f : Π i, S i ≃+* T i) :
  (Pi_congr_right e).trans (Pi_congr_right f) = (Pi_congr_right $ λ i, (e i).trans (f i)) := rfl

end non_unital_semiring

section semiring

variables [non_assoc_semiring R] [non_assoc_semiring S] (f : R ≃+* S) (x y : R)

/-- A ring isomorphism sends one to one. -/
protected lemma map_one : f 1 = 1 := map_one f

variable {x}

protected lemma map_eq_one_iff : f x = 1 ↔ x = 1 := mul_equiv_class.map_eq_one_iff f

lemma map_ne_one_iff : f x ≠ 1 ↔ x ≠ 1 := mul_equiv_class.map_ne_one_iff f

end semiring

section non_unital_ring

variables [non_unital_non_assoc_ring R] [non_unital_non_assoc_ring S] (f : R ≃+* S) (x y : R)

protected lemma map_neg : f (-x) = -f x := map_neg f x

protected lemma map_sub : f (x - y) = f x - f y := map_sub f x y

end non_unital_ring

section ring

variables [non_assoc_ring R] [non_assoc_ring S] (f : R ≃+* S) (x y : R)

@[simp] lemma map_neg_one : f (-1) = -1 := f.map_one ▸ f.map_neg 1

end ring

section non_unital_semiring_hom

variables [non_unital_non_assoc_semiring R] [non_unital_non_assoc_semiring S]
  [non_unital_non_assoc_semiring S']

/-- Reinterpret a ring equivalence as a non-unital ring homomorphism. -/
def to_non_unital_ring_hom (e : R ≃+* S) : R →ₙ+* S :=
{ .. e.to_mul_equiv.to_mul_hom, .. e.to_add_equiv.to_add_monoid_hom }

lemma to_non_unital_ring_hom_injective :
  function.injective (to_non_unital_ring_hom : (R ≃+* S) → R →ₙ+* S) :=
λ f g h, ring_equiv.ext (non_unital_ring_hom.ext_iff.1 h)

/- The instance priority is lowered here so that in the case when `R` and `S` are both unital, Lean
will first find and use `ring_equiv.has_coe_to_ring_hom`. -/
@[priority 900]
instance has_coe_to_non_unital_ring_hom : has_coe (R ≃+* S) (R →ₙ+* S) :=
⟨ring_equiv.to_non_unital_ring_hom⟩

lemma to_non_unital_ring_hom_eq_coe (f : R ≃+* S) : f.to_non_unital_ring_hom = ↑f := rfl

@[simp, norm_cast] lemma coe_to_non_unital_ring_hom (f : R ≃+* S) : ⇑(f : R →ₙ+* S) = f := rfl

lemma coe_non_unital_ring_hom_inj_iff {R S : Type*}
  [non_unital_non_assoc_semiring R] [non_unital_non_assoc_semiring S]
  (f g : R ≃+* S) :
  f = g ↔ (f : R →ₙ+* S) = g :=
⟨congr_arg _, λ h, ext $ non_unital_ring_hom.ext_iff.mp h⟩

@[simp]
lemma to_non_unital_ring_hom_refl :
  (ring_equiv.refl R).to_non_unital_ring_hom = non_unital_ring_hom.id R := rfl

@[simp]
lemma to_non_unital_ring_hom_apply_symm_to_non_unital_ring_hom_apply (e : R ≃+* S) :
  ∀ (y : S), e.to_non_unital_ring_hom (e.symm.to_non_unital_ring_hom y) = y :=
e.to_equiv.apply_symm_apply

@[simp]
lemma symm_to_non_unital_ring_hom_apply_to_non_unital_ring_hom_apply (e : R ≃+* S) :
  ∀ (x : R), e.symm.to_non_unital_ring_hom (e.to_non_unital_ring_hom x) = x :=
equiv.symm_apply_apply (e.to_equiv)

@[simp]
lemma to_non_unital_ring_hom_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
  (e₁.trans e₂).to_non_unital_ring_hom = e₂.to_non_unital_ring_hom.comp e₁.to_non_unital_ring_hom :=
rfl

@[simp]

@[simp]
lemma symm_to_non_unital_ring_hom_comp_to_non_unital_ring_hom (e : R ≃+* S) :
  e.symm.to_non_unital_ring_hom.comp e.to_non_unital_ring_hom = non_unital_ring_hom.id _ :=
by { ext, simp }
end non_unital_semiring_hom

section semiring_hom

variables [non_assoc_semiring R] [non_assoc_semiring S] [non_assoc_semiring S']

/-- Reinterpret a ring equivalence as a ring homomorphism. -/
def to_ring_hom (e : R ≃+* S) : R →+* S :=
{ .. e.to_mul_equiv.to_monoid_hom, .. e.to_add_equiv.to_add_monoid_hom }

lemma to_ring_hom_injective : function.injective (to_ring_hom : (R ≃+* S) → R →+* S) :=
λ f g h, ring_equiv.ext (ring_hom.ext_iff.1 h)

instance has_coe_to_ring_hom : has_coe (R ≃+* S) (R →+* S) := ⟨ring_equiv.to_ring_hom⟩

lemma to_ring_hom_eq_coe (f : R ≃+* S) : f.to_ring_hom = ↑f := rfl

@[simp, norm_cast] lemma coe_to_ring_hom (f : R ≃+* S) : ⇑(f : R →+* S) = f := rfl

lemma coe_ring_hom_inj_iff {R S : Type*} [non_assoc_semiring R] [non_assoc_semiring S]
  (f g : R ≃+* S) :
  f = g ↔ (f : R →+* S) = g :=
⟨congr_arg _, λ h, ext $ ring_hom.ext_iff.mp h⟩

/-- The two paths coercion can take to a `non_unital_ring_hom` are equivalent -/
@[simp, norm_cast] lemma to_non_unital_ring_hom_commutes (f : R ≃+* S) :
  ((f : R →+* S) : R →ₙ+* S) = (f : R →ₙ+* S) :=
rfl

/-- Reinterpret a ring equivalence as a monoid homomorphism. -/
abbreviation to_monoid_hom (e : R ≃+* S) : R →* S := e.to_ring_hom.to_monoid_hom

/-- Reinterpret a ring equivalence as an `add_monoid` homomorphism. -/
abbreviation to_add_monoid_hom (e : R ≃+* S) : R →+ S := e.to_ring_hom.to_add_monoid_hom

/-- The two paths coercion can take to an `add_monoid_hom` are equivalent -/
lemma to_add_monoid_hom_commutes (f : R ≃+* S) :
  (f : R →+* S).to_add_monoid_hom = (f : R ≃+ S).to_add_monoid_hom :=
rfl

/-- The two paths coercion can take to an `monoid_hom` are equivalent -/
lemma to_monoid_hom_commutes (f : R ≃+* S) :
  (f : R →+* S).to_monoid_hom = (f : R ≃* S).to_monoid_hom :=
rfl

/-- The two paths coercion can take to an `equiv` are equivalent -/
lemma to_equiv_commutes (f : R ≃+* S) :
  (f : R ≃+ S).to_equiv = (f : R ≃* S).to_equiv :=
rfl

@[simp]
lemma to_ring_hom_refl : (ring_equiv.refl R).to_ring_hom = ring_hom.id R := rfl

@[simp]
lemma to_monoid_hom_refl : (ring_equiv.refl R).to_monoid_hom = monoid_hom.id R := rfl

@[simp]
lemma to_add_monoid_hom_refl : (ring_equiv.refl R).to_add_monoid_hom = add_monoid_hom.id R := rfl

@[simp]
lemma to_ring_hom_apply_symm_to_ring_hom_apply (e : R ≃+* S) :
  ∀ (y : S), e.to_ring_hom (e.symm.to_ring_hom y) = y :=
e.to_equiv.apply_symm_apply

@[simp]
lemma symm_to_ring_hom_apply_to_ring_hom_apply (e : R ≃+* S) :
  ∀ (x : R), e.symm.to_ring_hom (e.to_ring_hom x) = x :=
equiv.symm_apply_apply (e.to_equiv)

@[simp]
lemma to_ring_hom_trans (e₁ : R ≃+* S) (e₂ : S ≃+* S') :
  (e₁.trans e₂).to_ring_hom = e₂.to_ring_hom.comp e₁.to_ring_hom := rfl

@[simp]
lemma to_ring_hom_comp_symm_to_ring_hom (e : R ≃+* S) :
  e.to_ring_hom.comp e.symm.to_ring_hom = ring_hom.id _ :=
by { ext, simp }

@[simp]
lemma symm_to_ring_hom_comp_to_ring_hom (e : R ≃+* S) :
  e.symm.to_ring_hom.comp e.to_ring_hom = ring_hom.id _ :=
by { ext, simp }

/--
Construct an equivalence of rings from homomorphisms in both directions, which are inverses.
-/
@[simps]
def of_hom_inv' {R S F G : Type*} [non_unital_non_assoc_semiring R]
  [non_unital_non_assoc_semiring S] [non_unital_ring_hom_class F R S]
  [non_unital_ring_hom_class G S R] (hom : F) (inv : G)
  (hom_inv_id : (inv : S →ₙ+* R).comp (hom : R →ₙ+* S) = non_unital_ring_hom.id R)
  (inv_hom_id : (hom : R →ₙ+* S).comp (inv : S →ₙ+* R) = non_unital_ring_hom.id S) :
  R ≃+* S :=
{ to_fun := hom,
  inv_fun := inv,
  left_inv := fun_like.congr_fun hom_inv_id,
  right_inv := fun_like.congr_fun inv_hom_id,
  map_mul' := map_mul hom,
  map_add' := map_add hom, }

/--
Construct an equivalence of rings from unital homomorphisms in both directions, which are inverses.
-/
@[simps]
def of_hom_inv {R S F G : Type*} [non_assoc_semiring R] [non_assoc_semiring S]
  [ring_hom_class F R S] [ring_hom_class G S R] (hom : F) (inv : G)
  (hom_inv_id : (inv : S →+* R).comp (hom : R →+* S) = ring_hom.id R)
  (inv_hom_id : (hom : R →+* S).comp (inv : S →+* R) = ring_hom.id S) :
  R ≃+* S :=
{ to_fun := hom,
  inv_fun := inv,
  left_inv := fun_like.congr_fun hom_inv_id,
  right_inv := fun_like.congr_fun inv_hom_id,
  map_mul' := map_mul hom,
  map_add' := map_add hom, }

end semiring_hom

section big_operators

protected lemma map_list_prod [semiring R] [semiring S] (f : R ≃+* S) (l : list R) :
  f l.prod = (l.map f).prod := map_list_prod f l

protected lemma map_list_sum [non_assoc_semiring R] [non_assoc_semiring S] (f : R ≃+* S)
  (l : list R) : f l.sum = (l.map f).sum := map_list_sum f l

/-- An isomorphism into the opposite ring acts on the product by acting on the reversed elements -/
protected lemma unop_map_list_prod [semiring R] [semiring S] (f : R ≃+* Sᵐᵒᵖ) (l : list R) :
  mul_opposite.unop (f l.prod) = (l.map (mul_opposite.unop ∘ f)).reverse.prod :=
unop_map_list_prod f l

protected lemma map_multiset_prod [comm_semiring R] [comm_semiring S] (f : R ≃+* S)
  (s : multiset R) : f s.prod = (s.map f).prod := map_multiset_prod f s

protected lemma map_multiset_sum [non_assoc_semiring R] [non_assoc_semiring S]
  (f : R ≃+* S) (s : multiset R) : f s.sum = (s.map f).sum := map_multiset_sum f s

protected lemma map_prod {α : Type*} [comm_semiring R] [comm_semiring S] (g : R ≃+* S) (f : α → R)
  (s : finset α) : g (∏ x in s, f x) = ∏ x in s, g (f x) :=
map_prod g f s

protected lemma map_sum {α : Type*} [non_assoc_semiring R] [non_assoc_semiring S]
  (g : R ≃+* S) (f : α → R) (s : finset α) : g (∑ x in s, f x) = ∑ x in s, g (f x) :=
map_sum g f s

end big_operators

section division_ring

variables {K K' : Type*} [division_ring K] [division_ring K']
  (g : K ≃+* K') (x y : K)

lemma map_inv : g x⁻¹ = (g x)⁻¹ := g.to_ring_hom.map_inv x

lemma map_div : g (x / y) = g x / g y := g.to_ring_hom.map_div x y

end division_ring

section group_power

variables [semiring R] [semiring S]

protected lemma map_pow (f : R ≃+* S) (a) : ∀ n : ℕ, f (a ^ n) = (f a) ^ n := map_pow f a

end group_power

end ring_equiv

namespace mul_equiv

/-- Gives a `ring_equiv` from an element of a `mul_equiv_class` preserving addition.-/
def to_ring_equiv {R S F : Type*} [has_add R] [has_add S] [has_mul R] [has_mul S]
  [mul_equiv_class F R S] (f : F) (H : ∀ x y : R, f (x + y) = f x + f y) : R ≃+* S :=
{ ..(f : R ≃* S).to_equiv, ..(f : R ≃* S), ..add_equiv.mk' (f : R ≃* S).to_equiv H }

end mul_equiv

namespace add_equiv

/-- Gives a `ring_equiv` from an element of an `add_equiv_class` preserving addition.-/
def to_ring_equiv {R S F : Type*} [has_add R] [has_add S] [has_mul R] [has_mul S]
  [add_equiv_class F R S] (f : F) (H : ∀ x y : R, f (x * y) = f x * f y) : R ≃+* S :=
{ ..(f : R ≃+ S).to_equiv, ..(f : R ≃+ S), ..mul_equiv.mk' (f : R ≃+ S).to_equiv H }

end add_equiv

namespace ring_equiv

variables [has_add R] [has_add S] [has_mul R] [has_mul S]

@[simp] theorem self_trans_symm (e : R ≃+* S) : e.trans e.symm = ring_equiv.refl R := ext e.3
@[simp] theorem symm_trans_self (e : R ≃+* S) : e.symm.trans e = ring_equiv.refl S := ext e.4

/-- If two rings are isomorphic, and the second is a domain, then so is the first. -/
protected lemma is_domain
  {A : Type*} (B : Type*) [ring A] [ring B] [is_domain B]
  (e : A ≃+* B) : is_domain A :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ x y hxy,
    have e x * e y = 0, by rw [← e.map_mul, hxy, e.map_zero],
    by simpa using eq_zero_or_eq_zero_of_mul_eq_zero this,
  exists_pair_ne := ⟨e.symm 0, e.symm 1, e.symm.injective.ne zero_ne_one⟩ }

end ring_equiv


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.count
import data.list.lex
import data.list.sublists
import data.set.pairwise

/-!
# Pairwise relations on a list

This file provides basic results about `list.pairwise` and `list.pw_filter` (definitions are in
`data.list.defs`).
`pairwise r [a 0, ..., a (n - 1)]` means `∀ i j, i < j → r (a i) (a j)`. For example,
`pairwise (≠) l` means that all elements of `l` are distinct, and `pairwise (<) l` means that `l`
is strictly increasing.
`pw_filter r l` is the list obtained by iteratively adding each element of `l` that doesn't break
the pairwiseness of the list we have so far. It thus yields `l'` a maximal sublist of `l` such that
`pairwise r l'`.

## Tags

sorted, nodup
-/

open nat function

namespace list
variables {α β : Type*} {R : α → α → Prop}

mk_iff_of_inductive_prop list.pairwise list.pairwise_iff

/-! ### Pairwise -/

theorem rel_of_pairwise_cons {a : α} {l : list α}
  (p : pairwise R (a :: l)) : ∀ {a'}, a' ∈ l → R a a' :=
(pairwise_cons.1 p).1

theorem pairwise_of_pairwise_cons {a : α} {l : list α}
  (p : pairwise R (a :: l)) : pairwise R l :=
(pairwise_cons.1 p).2

theorem pairwise.tail : ∀ {l : list α} (p : pairwise R l), pairwise R l.tail
| [] h := h
| (a :: l) h := pairwise_of_pairwise_cons h

theorem pairwise.drop : ∀ {l : list α} {n : ℕ}, list.pairwise R l → list.pairwise R (l.drop n)
| _ 0 h := h
| [] (n + 1) h := list.pairwise.nil
| (a :: l) (n + 1) h := pairwise.drop (pairwise_cons.mp h).right

theorem pairwise.imp_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → R a b → S a b) (p : pairwise R l) : pairwise S l :=
begin
  induction p with a l r p IH generalizing H; constructor,
  { exact ball.imp_right
      (λ x h, H (mem_cons_self _ _) (mem_cons_of_mem _ h)) r },
  { exact IH (λ a b m m', H
      (mem_cons_of_mem _ m) (mem_cons_of_mem _ m')) }
end

theorem pairwise.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {l : list α} : pairwise R l → pairwise S l :=
pairwise.imp_of_mem (λ a b _ _, H a b)

theorem pairwise.and {S : α → α → Prop} {l : list α} :
  pairwise (λ a b, R a b ∧ S a b) l ↔ pairwise R l ∧ pairwise S l :=
⟨λ h, ⟨h.imp (λ a b h, h.1), h.imp (λ a b h, h.2)⟩,
 λ ⟨hR, hS⟩, begin
  clear_, induction hR with a l R1 R2 IH;
  simp only [pairwise.nil, pairwise_cons] at *,
  exact ⟨λ b bl, ⟨R1 b bl, hS.1 b bl⟩, IH hS.2⟩
 end⟩

theorem pairwise.imp₂ {S : α → α → Prop} {T : α → α → Prop}
  (H : ∀ a b, R a b → S a b → T a b) {l : list α}
  (hR : pairwise R l) (hS : pairwise S l) : pairwise T l :=
(pairwise.and.2 ⟨hR, hS⟩).imp $ λ a b, and.rec (H a b)

theorem pairwise.iff_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → (R a b ↔ S a b)) : pairwise R l ↔ pairwise S l :=
⟨pairwise.imp_of_mem (λ a b m m', (H m m').1),
 pairwise.imp_of_mem (λ a b m m', (H m m').2)⟩

theorem pairwise.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {l : list α} : pairwise R l ↔ pairwise S l :=
pairwise.iff_of_mem (λ a b _ _, H a b)

theorem pairwise_of_forall {l : list α} (H : ∀ x y, R x y) : pairwise R l :=
by induction l; [exact pairwise.nil,
simp only [*, pairwise_cons, forall_2_true_iff, and_true]]

theorem pairwise.and_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l ∧ y ∈ l ∧ R x y) l :=
pairwise.iff_of_mem (by simp only [true_and, iff_self, forall_2_true_iff] {contextual := tt})

theorem pairwise.imp_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l → y ∈ l → R x y) l :=
pairwise.iff_of_mem
  (by simp only [forall_prop_of_true, iff_self, forall_2_true_iff] {contextual := tt})

theorem pairwise_of_sublist : Π {l₁ l₂ : list α}, l₁ <+ l₂ → pairwise R l₂ → pairwise R l₁
| ._ ._ sublist.slnil h := h
| ._ ._ (sublist.cons l₁ l₂ a s) (pairwise.cons i n) := pairwise_of_sublist s n
| ._ ._ (sublist.cons2 l₁ l₂ a s) (pairwise.cons i n) :=
  (pairwise_of_sublist s n).cons (ball.imp_left s.subset i)

theorem forall_of_forall_of_pairwise (H : symmetric R)
  {l : list α} (H₁ : ∀ x ∈ l, R x x) (H₂ : pairwise R l) :
  ∀ (x ∈ l) (y ∈ l), R x y :=
begin
  induction l with a l IH, { exact forall_mem_nil _ },
  cases forall_mem_cons.1 H₁ with H₁₁ H₁₂,
  cases pairwise_cons.1 H₂ with H₂₁ H₂₂,
  rintro x (rfl | hx) y (rfl | hy),
  exacts [H₁₁, H₂₁ _ hy, H (H₂₁ _ hx), IH H₁₂ H₂₂ _ hx _ hy]
end

lemma forall_of_pairwise (H : symmetric R) {l : list α}
   (hl : pairwise R l) : (∀a∈l, ∀b∈l, a ≠ b → R a b) :=
forall_of_forall_of_pairwise
  (λ a b h hne, H (h hne.symm))
  (λ _ _ h, (h rfl).elim)
  (pairwise.imp (λ _ _ h _, h) hl)

theorem pairwise_singleton (R) (a : α) : pairwise R [a] :=
by simp only [pairwise_cons, mem_singleton, forall_prop_of_false (not_mem_nil _), forall_true_iff,
  pairwise.nil, and_true]

theorem pairwise_pair {a b : α} : pairwise R [a, b] ↔ R a b :=
by simp only [pairwise_cons, mem_singleton, forall_eq, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, pairwise.nil, and_true]

theorem pairwise_append {l₁ l₂ : list α} : pairwise R (l₁++l₂) ↔
  pairwise R l₁ ∧ pairwise R l₂ ∧ ∀ x ∈ l₁, ∀ y ∈ l₂, R x y :=
by induction l₁ with x l₁ IH; [simp only [list.pairwise.nil, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, and_true, true_and, nil_append],
simp only [cons_append, pairwise_cons, forall_mem_append, IH, forall_mem_cons, forall_and_distrib,
  and_assoc, and.left_comm]]

theorem pairwise_append_comm (s : symmetric R) {l₁ l₂ : list α} :
  pairwise R (l₁++l₂) ↔ pairwise R (l₂++l₁) :=
have ∀ l₁ l₂ : list α,
  (∀ (x : α), x ∈ l₁ → ∀ (y : α), y ∈ l₂ → R x y) →
  (∀ (x : α), x ∈ l₂ → ∀ (y : α), y ∈ l₁ → R x y),
from λ l₁ l₂ a x xm y ym, s (a y ym x xm),
by simp only [pairwise_append, and.left_comm]; rw iff.intro (this l₁ l₂) (this l₂ l₁)

theorem pairwise_middle (s : symmetric R) {a : α} {l₁ l₂ : list α} :
  pairwise R (l₁ ++ a :: l₂) ↔ pairwise R (a :: (l₁++l₂)) :=
show pairwise R (l₁ ++ ([a] ++ l₂)) ↔ pairwise R ([a] ++ l₁ ++ l₂),
by rw [← append_assoc, pairwise_append, @pairwise_append _ _ ([a] ++ l₁), pairwise_append_comm s];
   simp only [mem_append, or_comm]

theorem pairwise_map (f : β → α) :
  ∀ {l : list β}, pairwise R (map f l) ↔ pairwise (λ a b : β, R (f a) (f b)) l
| []     := by simp only [map, pairwise.nil]
| (b :: l) :=
  have (∀ a b', b' ∈ l → f b' = a → R (f b) a) ↔ ∀ (b' : β), b' ∈ l → R (f b) (f b'), from
  forall_swap.trans $ forall_congr $ λ a, forall_swap.trans $ by simp only [forall_eq'],
  by simp only [map, pairwise_cons, mem_map, exists_imp_distrib, and_imp, this, pairwise_map]

theorem pairwise_of_pairwise_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {l : list α}
  (p : pairwise S (map f l)) : pairwise R l :=
((pairwise_map f).1 p).imp H

theorem pairwise_map_of_pairwise {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {l : list α}
  (p : pairwise R l) : pairwise S (map f l) :=
(pairwise_map f).2 $ p.imp H

theorem pairwise_filter_map (f : β → option α) {l : list β} :
  pairwise R (filter_map f l) ↔ pairwise (λ a a' : β, ∀ (b ∈ f a) (b' ∈ f a'), R b b') l :=
let S (a a' : β) := ∀ (b ∈ f a) (b' ∈ f a'), R b b' in
begin
  simp only [option.mem_def], induction l with a l IH,
  { simp only [filter_map, pairwise.nil] },
  cases e : f a with b,
  { rw [filter_map_cons_none _ _ e, IH, pairwise_cons],
    simp only [e, forall_prop_of_false not_false, forall_3_true_iff, true_and] },
  rw [filter_map_cons_some _ _ _ e],
  simp only [pairwise_cons, mem_filter_map, exists_imp_distrib, and_imp, IH, e, forall_eq'],
  show (∀ (a' : α) (x : β), x ∈ l → f x = some a' → R b a') ∧ pairwise S l ↔
        (∀ (a' : β), a' ∈ l → ∀ (b' : α), f a' = some b' → R b b') ∧ pairwise S l,
  from and_congr ⟨λ h b mb a ma, h a b mb ma, λ h a b mb ma, h b mb a ma⟩ iff.rfl
end

theorem pairwise_filter_map_of_pairwise {S : β → β → Prop} (f : α → option β)
  (H : ∀ (a a' : α), R a a' → ∀ (b ∈ f a) (b' ∈ f a'), S b b') {l : list α}
  (p : pairwise R l) : pairwise S (filter_map f l) :=
(pairwise_filter_map _).2 $ p.imp H

theorem pairwise_filter (p : α → Prop) [decidable_pred p] {l : list α} :
  pairwise R (filter p l) ↔ pairwise (λ x y, p x → p y → R x y) l :=
begin
  rw [← filter_map_eq_filter, pairwise_filter_map],
  apply pairwise.iff, intros, simp only [option.mem_def, option.guard_eq_some, and_imp, forall_eq'],
end

theorem pairwise_filter_of_pairwise (p : α → Prop) [decidable_pred p] {l : list α}
  : pairwise R l → pairwise R (filter p l) :=
pairwise_of_sublist (filter_sublist _)

theorem pairwise_pmap {p : β → Prop} {f : Π b, p b → α} {l : list β} (h : ∀ x ∈ l, p x) :
  pairwise R (l.pmap f h) ↔
    pairwise (λ b₁ b₂, ∀ (h₁ : p b₁) (h₂ : p b₂), R (f b₁ h₁) (f b₂ h₂)) l :=
begin
  induction l with a l ihl, { simp },
  obtain ⟨ha, hl⟩ : p a ∧ ∀ b, b ∈ l → p b, by simpa using h,
  simp only [ihl hl, pairwise_cons, bex_imp_distrib, pmap, and.congr_left_iff, mem_pmap],
  refine λ _, ⟨λ H b hb hpa hpb, H _ _ hb rfl, _⟩,
  rintro H _ b hb rfl,
  exact H b hb _ _
end

theorem pairwise_join {L : list (list α)} : pairwise R (join L) ↔
  (∀ l ∈ L, pairwise R l) ∧ pairwise (λ l₁ l₂, ∀ (x ∈ l₁) (y ∈ l₂), R x y) L :=
begin
  induction L with l L IH,
  {simp only [join, pairwise.nil, forall_prop_of_false (not_mem_nil _), forall_const, and_self]},
  have : (∀ (x : α), x ∈ l → ∀ (y : α) (x_1 : list α), x_1 ∈ L → y ∈ x_1 → R x y) ↔
          ∀ (a' : list α), a' ∈ L → ∀ (x : α), x ∈ l → ∀ (y : α), y ∈ a' → R x y :=
    ⟨λ h a b c d e, h c d e a b, λ h c d e a b, h a b c d e⟩,
  simp only [join, pairwise_append, IH, mem_join, exists_imp_distrib, and_imp, this,
    forall_mem_cons, pairwise_cons],
  simp only [and_assoc, and_comm, and.left_comm],
end

@[simp] theorem pairwise_reverse : ∀ {R} {l : list α},
  pairwise R (reverse l) ↔ pairwise (λ x y, R y x) l :=
suffices ∀ {R l}, @pairwise α R l → pairwise (λ x y, R y x) (reverse l),
from λ R l, ⟨λ p, reverse_reverse l ▸ this p, this⟩,
λ R l p, by induction p with a l h p IH;
  [apply pairwise.nil, simpa only [reverse_cons, pairwise_append, IH,
    pairwise_cons, forall_prop_of_false (not_mem_nil _), forall_true_iff,
    pairwise.nil, mem_reverse, mem_singleton, forall_eq, true_and] using h]

lemma pairwise.set_pairwise {l : list α} (h : pairwise R l) (hr : symmetric R) :
  set.pairwise {x | x ∈ l} R :=
begin
  induction h with hd tl imp h IH,
  { simp },
  { intros x hx y hy hxy,
    simp only [mem_cons_iff, set.mem_set_of_eq] at hx hy,
    rcases hx with rfl|hx;
    rcases hy with rfl|hy,
    { contradiction },
    { exact imp y hy },
    { exact hr (imp x hx) },
    { exact IH x hx y hy hxy } }
end

lemma pairwise_of_reflexive_on_dupl_of_forall_ne [decidable_eq α] {l : list α} {r : α → α → Prop}
  (hr : ∀ a, 1 < count a l → r a a)
  (h : ∀ (a ∈ l) (b ∈ l), a ≠ b → r a b) : l.pairwise r :=
begin
  induction l with hd tl IH,
  { simp },
  { rw list.pairwise_cons,
    split,
    { intros x hx,
      by_cases H : hd = x,
      { rw H,
        refine hr _ _,
        simpa [count_cons, H, nat.succ_lt_succ_iff, count_pos] using hx },
      { exact h hd (mem_cons_self _ _) x (mem_cons_of_mem _ hx) H } },
    { refine IH _ _,
      { intros x hx,
        refine hr _ _,
        rw count_cons,
        split_ifs,
        { exact hx.trans (nat.lt_succ_self _) },
        { exact hx } },
      { intros x hx y hy,
        exact h x (mem_cons_of_mem _ hx) y (mem_cons_of_mem _ hy) } } }
end

lemma pairwise_of_reflexive_of_forall_ne {l : list α} {r : α → α → Prop}
  (hr : reflexive r) (h : ∀ (a ∈ l) (b ∈ l), a ≠ b → r a b) : l.pairwise r :=
begin
  classical,
  refine pairwise_of_reflexive_on_dupl_of_forall_ne _ h,
  exact λ _ _, hr _
end

theorem pairwise_iff_nth_le {R} : ∀ {l : list α},
  pairwise R l ↔ ∀ i j (h₁ : j < length l) (h₂ : i < j),
    R (nth_le l i (lt_trans h₂ h₁)) (nth_le l j h₁)
| [] := by simp only [pairwise.nil, true_iff]; exact λ i j h, (nat.not_lt_zero j).elim h
| (a :: l) := begin
  rw [pairwise_cons, pairwise_iff_nth_le],
  refine ⟨λ H i j h₁ h₂, _, λ H, ⟨λ a' m, _,
    λ i j h₁ h₂, H _ _ (succ_lt_succ h₁) (succ_lt_succ h₂)⟩⟩,
  { cases j with j, {exact (nat.not_lt_zero _).elim h₂},
    cases i with i,
    { exact H.1 _ (nth_le_mem l _ _) },
    { exact H.2 _ _ (lt_of_succ_lt_succ h₁) (lt_of_succ_lt_succ h₂) } },
  { rcases nth_le_of_mem m with ⟨n, h, rfl⟩,
    exact H _ _ (succ_lt_succ h) (succ_pos _) }
end

theorem pairwise_sublists' {R} : ∀ {l : list α}, pairwise R l →
  pairwise (lex (swap R)) (sublists' l)
| _ pairwise.nil := pairwise_singleton _ _
| _ (@pairwise.cons _ _ a l H₁ H₂) :=
  begin
    simp only [sublists'_cons, pairwise_append, pairwise_map, mem_sublists', mem_map,
      exists_imp_distrib, and_imp],
    have IH := pairwise_sublists' H₂,
    refine ⟨IH, IH.imp (λ l₁ l₂, lex.cons), _⟩,
    intros l₁ sl₁ x l₂ sl₂ e, subst e,
    cases l₁ with b l₁, {constructor},
    exact lex.rel (H₁ _ $ sl₁.subset $ mem_cons_self _ _)
  end

theorem pairwise_sublists {R} {l : list α} (H : pairwise R l) :
  pairwise (λ l₁ l₂, lex R (reverse l₁) (reverse l₂)) (sublists l) :=
by have := pairwise_sublists' (pairwise_reverse.2 H);
   rwa [sublists'_reverse, pairwise_map] at this

/-! ### Pairwise filtering -/

variable [decidable_rel R]

@[simp] theorem pw_filter_nil : pw_filter R [] = [] := rfl

@[simp] theorem pw_filter_cons_of_pos {a : α} {l : list α} (h : ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a :: l) = a :: pw_filter R l := if_pos h

@[simp] theorem pw_filter_cons_of_neg {a : α} {l : list α} (h : ¬ ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a :: l) = pw_filter R l := if_neg h

theorem pw_filter_map (f : β → α) :
  Π (l : list β), pw_filter R (map f l) = map f (pw_filter (λ x y, R (f x) (f y)) l)
| [] := rfl
| (x :: xs) :=
  if h : ∀ b ∈ pw_filter R (map f xs), R (f x) b
    then have h' : ∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ b hb, h _ (by rw [pw_filter_map]; apply mem_map_of_mem _ hb),
         by rw [map,pw_filter_cons_of_pos h,pw_filter_cons_of_pos h',pw_filter_map,map]
    else have h' : ¬∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ hh, h $ λ a ha,
           by { rw [pw_filter_map,mem_map] at ha, rcases ha with ⟨b,hb₀,hb₁⟩,
                subst a, exact hh _ hb₀, },
         by rw [map,pw_filter_cons_of_neg h,pw_filter_cons_of_neg h',pw_filter_map]

theorem pw_filter_sublist : ∀ (l : list α), pw_filter R l <+ l
| []     := nil_sublist _
| (x :: l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact (pw_filter_sublist l).cons_cons _ },
  { rw [pw_filter_cons_of_neg h],
    exact sublist_cons_of_sublist _ (pw_filter_sublist l) },
end

theorem pw_filter_subset (l : list α) : pw_filter R l ⊆ l :=
(pw_filter_sublist _).subset

theorem pairwise_pw_filter : ∀ (l : list α), pairwise R (pw_filter R l)
| []     := pairwise.nil
| (x :: l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact pairwise_cons.2 ⟨h, pairwise_pw_filter l⟩ },
  { rw [pw_filter_cons_of_neg h],
    exact pairwise_pw_filter l },
end

theorem pw_filter_eq_self {l : list α} : pw_filter R l = l ↔ pairwise R l :=
⟨λ e, e ▸ pairwise_pw_filter l, λ p, begin
  induction l with x l IH, {refl},
  cases pairwise_cons.1 p with al p,
  rw [pw_filter_cons_of_pos (ball.imp_left (pw_filter_subset l) al), IH p],
end⟩

@[simp] theorem pw_filter_idempotent {l : list α} :
  pw_filter R (pw_filter R l) = pw_filter R l :=
pw_filter_eq_self.mpr (pairwise_pw_filter l)

theorem forall_mem_pw_filter (neg_trans : ∀ {x y z}, R x z → R x y ∨ R y z)
  (a : α) (l : list α) : (∀ b ∈ pw_filter R l, R a b) ↔ (∀ b ∈ l, R a b) :=
⟨begin
  induction l with x l IH, { exact λ _ _, false.elim },
  simp only [forall_mem_cons],
  by_cases (∀ y ∈ pw_filter R l, R x y); dsimp at h,
  { simp only [pw_filter_cons_of_pos h, forall_mem_cons, and_imp],
    exact λ r H, ⟨r, IH H⟩ },
  { rw [pw_filter_cons_of_neg h],
    refine λ H, ⟨_, IH H⟩,
    cases e : find (λ y, ¬ R x y) (pw_filter R l) with k,
    { refine h.elim (ball.imp_right _ (find_eq_none.1 e)),
      exact λ y _, not_not.1 },
    { have := find_some e,
      exact (neg_trans (H k (find_mem e))).resolve_right this } }
end, ball.imp_left (pw_filter_subset l)⟩

end list


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad

Finite sets.
-/
import data.fintype.basic data.nat data.list.perm algebra.binary
open nat quot list subtype binary function eq.ops
open [decl] perm

definition nodup_list (A : Type) := {l : list A | nodup l}

variable {A : Type}

definition to_nodup_list_of_nodup {l : list A} (n : nodup l) : nodup_list A :=
tag l n

definition to_nodup_list [decidable_eq A] (l : list A) : nodup_list A :=
@to_nodup_list_of_nodup A (erase_dup l) (nodup_erase_dup l)

private definition eqv (l₁ l₂ : nodup_list A) :=
perm (elt_of l₁) (elt_of l₂)

local infix ~ := eqv

private definition eqv.refl (l : nodup_list A) : l ~ l :=
!perm.refl

private definition eqv.symm {l₁ l₂ : nodup_list A} : l₁ ~ l₂ → l₂ ~ l₁ :=
perm.symm

private definition eqv.trans {l₁ l₂ l₃ : nodup_list A} : l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃ :=
perm.trans

definition finset.nodup_list_setoid [instance] (A : Type) : setoid (nodup_list A) :=
setoid.mk (@eqv A) (mk_equivalence (@eqv A) (@eqv.refl A) (@eqv.symm A) (@eqv.trans A))

definition finset (A : Type) : Type :=
quot (finset.nodup_list_setoid A)

namespace finset

-- give finset notation higher priority than set notation, so that it is tried first
protected definition prio : num := num.succ std.priority.default

definition to_finset_of_nodup (l : list A) (n : nodup l) : finset A :=
⟦to_nodup_list_of_nodup n⟧

definition to_finset [decidable_eq A] (l : list A) : finset A :=
⟦to_nodup_list l⟧

lemma to_finset_eq_of_nodup [decidable_eq A] {l : list A} (n : nodup l) :
  to_finset_of_nodup l n = to_finset l :=
have P : to_nodup_list_of_nodup n = to_nodup_list l, from
  begin
    rewrite [↑to_nodup_list, ↑to_nodup_list_of_nodup],
    congruence,
    rewrite [erase_dup_eq_of_nodup n]
  end,
quot.sound (eq.subst P !setoid.refl)

definition has_decidable_eq [instance] [decidable_eq A] : decidable_eq (finset A) :=
λ s₁ s₂, quot.rec_on_subsingleton₂ s₁ s₂
  (λ l₁ l₂,
     match decidable_perm (elt_of l₁) (elt_of l₂) with
     | decidable.inl e := decidable.inl (quot.sound e)
     | decidable.inr n := decidable.inr (λ e : ⟦l₁⟧ = ⟦l₂⟧, absurd (quot.exact e) n)
     end)

definition mem (a : A) (s : finset A) : Prop :=
quot.lift_on s (λ l, a ∈ elt_of l)
 (λ l₁ l₂ (e : l₁ ~ l₂), propext (iff.intro
   (λ ainl₁, mem_perm e ainl₁)
   (λ ainl₂, mem_perm (perm.symm e) ainl₂)))

infix [priority finset.prio] ∈ := mem
notation [priority finset.prio] a ∉ b := ¬ mem a b

theorem mem_of_mem_list {a : A} {l : nodup_list A} : a ∈ elt_of l → a ∈ ⟦l⟧ :=
λ ainl, ainl

theorem mem_list_of_mem {a : A} {l : nodup_list A} : a ∈ ⟦l⟧ → a ∈ elt_of l :=
λ ainl, ainl

definition decidable_mem [instance] [h : decidable_eq A] : ∀ (a : A) (s : finset A), decidable (a ∈ s) :=
λ a s, quot.rec_on_subsingleton s
  (λ l, match list.decidable_mem a (elt_of l) with
        | decidable.inl p := decidable.inl (mem_of_mem_list p)
        | decidable.inr n := decidable.inr (λ p, absurd (mem_list_of_mem p) n)
        end)

theorem mem_to_finset [decidable_eq A] {a : A} {l : list A} : a ∈ l → a ∈ to_finset l :=
λ ainl, mem_erase_dup ainl

theorem mem_to_finset_of_nodup {a : A} {l : list A} (n : nodup l) : a ∈ l → a ∈ to_finset_of_nodup l n :=
λ ainl, ainl

/- extensionality -/
theorem ext {s₁ s₂ : finset A} : (∀ a, a ∈ s₁ ↔ a ∈ s₂) → s₁ = s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ e, quot.sound (perm_ext (has_property l₁) (has_property l₂) e))

/- empty -/
definition empty : finset A :=
to_finset_of_nodup [] nodup_nil

notation [priority finset.prio] `∅` := !empty

theorem not_mem_empty [simp] (a : A) : a ∉ ∅ :=
λ aine : a ∈ ∅, aine

theorem mem_empty_iff [simp] (x : A) : x ∈ ∅ ↔ false :=
iff_false_intro !not_mem_empty

theorem mem_empty_eq (x : A) : x ∈ ∅ = false :=
propext !mem_empty_iff

theorem eq_empty_of_forall_not_mem {s : finset A} (H : ∀x, ¬ x ∈ s) : s = ∅ :=
ext (take x, iff_false_intro (H x))

/- universe -/
definition univ [h : fintype A] : finset A :=
to_finset_of_nodup (@fintype.elems A h) (@fintype.unique A h)

theorem mem_univ [fintype A] (x : A) : x ∈ univ :=
fintype.complete x

theorem mem_univ_eq [fintype A] (x : A) : x ∈ univ = true := propext (iff_true_intro !mem_univ)

/- card -/
definition card (s : finset A) : nat :=
quot.lift_on s
  (λ l, length (elt_of l))
  (λ l₁ l₂ p, length_eq_length_of_perm p)

theorem card_empty : card (@empty A) = 0 :=
rfl

lemma ne_empty_of_card_eq_succ {s : finset A} {n : nat} : card s = succ n → s ≠ ∅ :=
by intros; substvars; contradiction

/- insert -/
section insert
variable [h : decidable_eq A]
include h

definition insert (a : A) (s : finset A) : finset A :=
quot.lift_on s
  (λ l, to_finset_of_nodup (insert a (elt_of l)) (nodup_insert a (has_property l)))
  (λ (l₁ l₂ : nodup_list A) (p : l₁ ~ l₂), quot.sound (perm_insert a p))

-- set builder notation
notation [priority finset.prio] `'{`:max a:(foldr `, ` (x b, insert x b) ∅) `}`:0 := a

theorem mem_insert (a : A) (s : finset A) : a ∈ insert a s :=
quot.induction_on s
 (λ l : nodup_list A, mem_to_finset_of_nodup _ !list.mem_insert)

theorem mem_insert_of_mem {a : A} {s : finset A} (b : A) : a ∈ s → a ∈ insert b s :=
quot.induction_on s
 (λ (l : nodup_list A) (ainl : a ∈ ⟦l⟧), mem_to_finset_of_nodup _ (list.mem_insert_of_mem _ ainl))

theorem eq_or_mem_of_mem_insert {x a : A} {s : finset A} : x ∈ insert a s → x = a ∨ x ∈ s :=
quot.induction_on s (λ l : nodup_list A, λ H, list.eq_or_mem_of_mem_insert H)

theorem mem_of_mem_insert_of_ne {x a : A} {s : finset A} (xin : x ∈ insert a s) : x ≠ a → x ∈ s :=
or_resolve_right (eq_or_mem_of_mem_insert xin)

theorem mem_insert_iff (x a : A) (s : finset A) : x ∈ insert a s ↔ (x = a ∨ x ∈ s) :=
iff.intro !eq_or_mem_of_mem_insert
  (or.rec (λH', (eq.substr H' !mem_insert)) !mem_insert_of_mem)

theorem mem_insert_eq (x a : A) (s : finset A) : x ∈ insert a s = (x = a ∨ x ∈ s) :=
propext !mem_insert_iff

theorem mem_singleton_iff (x a : A) : x ∈ '{a} ↔ (x = a) :=
by rewrite [mem_insert_eq, mem_empty_eq, or_false]

theorem mem_singleton (a : A) : a ∈ '{a} := mem_insert a ∅

theorem mem_singleton_of_eq {x a : A} (H : x = a) : x ∈ '{a} :=
by rewrite H; apply mem_insert

theorem eq_of_mem_singleton {x a : A} (H : x ∈ '{a}) : x = a := iff.mp !mem_singleton_iff H

theorem eq_of_singleton_eq {a b : A} (H : '{a} = '{b}) : a = b :=
have a ∈ '{b}, by rewrite -H; apply mem_singleton,
eq_of_mem_singleton this

theorem insert_eq_of_mem {a : A} {s : finset A} (H : a ∈ s) : insert a s = s :=
ext (λ x, eq.substr (mem_insert_eq x a s)
   (or_iff_right_of_imp (λH1, eq.substr H1 H)))

theorem singleton_ne_empty (a : A) : '{a} ≠ ∅ :=
begin
  intro H,
  apply not_mem_empty a,
  rewrite -H,
  apply mem_insert
end

theorem pair_eq_singleton (a : A) : '{a, a} = '{a} :=
by rewrite [insert_eq_of_mem !mem_singleton]

-- useful in proofs by induction
theorem forall_of_forall_insert {P : A → Prop} {a : A} {s : finset A}
    (H : ∀ x, x ∈ insert a s → P x) :
  ∀ x, x ∈ s → P x :=
λ x xs, H x (!mem_insert_of_mem xs)

theorem insert.comm (x y : A) (s : finset A) : insert x (insert y s) = insert y (insert x s) :=
ext (take a, by rewrite [*mem_insert_eq, propext !or.left_comm])

theorem card_insert_of_mem {a : A} {s : finset A} : a ∈ s → card (insert a s) = card s :=
quot.induction_on s
  (λ (l : nodup_list A) (ainl : a ∈ ⟦l⟧), list.length_insert_of_mem ainl)

theorem card_insert_of_not_mem {a : A} {s : finset A} : a ∉ s → card (insert a s) = card s + 1 :=
quot.induction_on s
  (λ (l : nodup_list A) (nainl : a ∉ ⟦l⟧), list.length_insert_of_not_mem nainl)

theorem card_insert_le (a : A) (s : finset A) :
  card (insert a s) ≤ card s + 1 :=
if H : a ∈ s then by rewrite [card_insert_of_mem H]; apply le_succ
else by rewrite [card_insert_of_not_mem H]

protected theorem induction [recursor 6] {P : finset A → Prop}
    (H1 : P empty)
    (H2 : ∀ ⦃a : A⦄, ∀{s : finset A}, a ∉ s → P s → P (insert a s)) :
  ∀s, P s :=
take s,
quot.induction_on s
 (take u,
  subtype.destruct u
   (take l,
    list.induction_on l
      (assume nodup_l, H1)
      (take a l',
        assume IH nodup_al',
        have aux₁: a ∉ l', from not_mem_of_nodup_cons nodup_al',
        have e : list.insert a l' = a :: l', from insert_eq_of_not_mem aux₁,
        have nodup l', from nodup_of_nodup_cons nodup_al',
        have P (quot.mk (subtype.tag l' this)), from IH this,
        have P (insert a (quot.mk (subtype.tag l' _))), from H2 aux₁ this,
        begin
          revert nodup_al',
          rewrite [-e],
          intros,
          apply this
        end)))

protected theorem induction_on {P : finset A → Prop} (s : finset A)
    (H1 : P empty)
    (H2 : ∀ ⦃a : A⦄, ∀ {s : finset A}, a ∉ s → P s → P (insert a s)) :
  P s :=
finset.induction H1 H2 s

theorem exists_mem_of_ne_empty {s : finset A} : s ≠ ∅ → ∃ a : A, a ∈ s :=
begin
  induction s with a s nin ih,
    {intro h, exact absurd rfl h},
    {intro h, existsi a, apply mem_insert}
end

theorem eq_empty_of_card_eq_zero {s : finset A} (H : card s = 0) : s = ∅ :=
begin
  induction s with a s' H1 IH,
  { reflexivity },
  { rewrite (card_insert_of_not_mem H1) at H, apply nat.no_confusion H}
end

end insert

/- erase -/
section erase
variable [h : decidable_eq A]
include h

definition erase (a : A) (s : finset A) : finset A :=
quot.lift_on s
  (λ l, to_finset_of_nodup (erase a (elt_of l)) (nodup_erase_of_nodup a (has_property l)))
  (λ (l₁ l₂ : nodup_list A) (p : l₁ ~ l₂), quot.sound (erase_perm_erase_of_perm a p))

theorem not_mem_erase (a : A) (s : finset A) : a ∉ erase a s :=
quot.induction_on s
  (λ l, list.mem_erase_of_nodup _ (has_property l))

theorem card_erase_of_mem {a : A} {s : finset A} : a ∈ s → card (erase a s) = pred (card s) :=
quot.induction_on s (λ l ainl, list.length_erase_of_mem ainl)

theorem card_erase_of_not_mem {a : A} {s : finset A} : a ∉ s → card (erase a s) = card s :=
quot.induction_on s (λ l nainl, list.length_erase_of_not_mem nainl)

theorem erase_empty (a : A) : erase a ∅ = ∅ :=
rfl

theorem ne_of_mem_erase {a b : A} {s : finset A} : b ∈ erase a s → b ≠ a :=
by intro h beqa; subst b; exact absurd h !not_mem_erase

theorem mem_of_mem_erase {a b : A} {s : finset A} : b ∈ erase a s → b ∈ s :=
quot.induction_on s (λ l bin, mem_of_mem_erase bin)

theorem mem_erase_of_ne_of_mem {a b : A} {s : finset A} : a ≠ b → a ∈ s → a ∈ erase b s :=
quot.induction_on s (λ l n ain, list.mem_erase_of_ne_of_mem n ain)

theorem mem_erase_iff (a b : A) (s : finset A) : a ∈ erase b s ↔ a ∈ s ∧ a ≠ b :=
iff.intro
  (assume H, and.intro (mem_of_mem_erase H) (ne_of_mem_erase H))
  (assume H, mem_erase_of_ne_of_mem (and.right H) (and.left H))

theorem mem_erase_eq (a b : A) (s : finset A) : a ∈ erase b s = (a ∈ s ∧ a ≠ b) :=
propext !mem_erase_iff

open decidable
theorem erase_insert {a : A} {s : finset A} : a ∉ s → erase a (insert a s) = s :=
λ anins, finset.ext (λ b, by_cases
  (λ beqa : b = a, iff.intro
    (λ bin, by subst b; exact absurd bin !not_mem_erase)
    (λ bin, by subst b; contradiction))
  (λ bnea : b ≠ a, iff.intro
    (λ bin,
       have b ∈ insert a s, from mem_of_mem_erase bin,
       mem_of_mem_insert_of_ne this bnea)
    (λ bin,
      have b ∈ insert a s, from mem_insert_of_mem _ bin,
      mem_erase_of_ne_of_mem bnea this)))

theorem insert_erase {a : A} {s : finset A} : a ∈ s → insert a (erase a s) = s :=
λ ains, finset.ext (λ b, by_cases
  (suppose b = a, iff.intro
    (λ bin, by subst b; assumption)
    (λ bin, by subst b; apply mem_insert))
  (suppose b ≠ a, iff.intro
    (λ bin, mem_of_mem_erase (mem_of_mem_insert_of_ne bin `b ≠ a`))
    (λ bin, mem_insert_of_mem _ (mem_erase_of_ne_of_mem `b ≠ a` bin))))
end erase

/- union -/
section union
variable [h : decidable_eq A]
include h

definition union (s₁ s₂ : finset A) : finset A :=
quot.lift_on₂ s₁ s₂
  (λ l₁ l₂,
    to_finset_of_nodup (list.union (elt_of l₁) (elt_of l₂))
                       (nodup_union_of_nodup_of_nodup (has_property l₁) (has_property l₂)))
  (λ v₁ v₂ w₁ w₂ p₁ p₂, quot.sound (perm_union p₁ p₂))

infix [priority finset.prio] ∪ := union

theorem mem_union_left {a : A} {s₁ : finset A} (s₂ : finset A) : a ∈ s₁ → a ∈ s₁ ∪ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁, list.mem_union_left _ ainl₁)

theorem mem_union_l {a : A} {s₁ : finset A} {s₂ : finset A} : a ∈ s₁ → a ∈ s₁ ∪ s₂ :=
mem_union_left s₂

theorem mem_union_right {a : A} {s₂ : finset A} (s₁ : finset A) : a ∈ s₂ → a ∈ s₁ ∪ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₂, list.mem_union_right _ ainl₂)

theorem mem_union_r {a : A} {s₂ : finset A} {s₁ : finset A} : a ∈ s₂ → a ∈ s₁ ∪ s₂ :=
mem_union_right s₁

theorem mem_or_mem_of_mem_union {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∪ s₂ → a ∈ s₁ ∨ a ∈ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_or_mem_of_mem_union ainl₁l₂)

theorem mem_union_iff (a : A) (s₁ s₂ : finset A) : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
iff.intro
 (λ h, mem_or_mem_of_mem_union h)
 (λ d, or.elim d
   (λ i, mem_union_left _ i)
   (λ i, mem_union_right _ i))

theorem mem_union_eq (a : A) (s₁ s₂ : finset A) : (a ∈ s₁ ∪ s₂) = (a ∈ s₁ ∨ a ∈ s₂) :=
propext !mem_union_iff

theorem union_comm (s₁ s₂ : finset A) : s₁ ∪ s₂ = s₂ ∪ s₁ :=
ext (λ a, by rewrite [*mem_union_eq]; exact or.comm)

theorem union_assoc (s₁ s₂ s₃ : finset A) : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
ext (λ a, by rewrite [*mem_union_eq]; exact or.assoc)

theorem union_left_comm (s₁ s₂ s₃ : finset A) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) :=
!left_comm union_comm union_assoc s₁ s₂ s₃

theorem union_right_comm (s₁ s₂ s₃ : finset A) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ :=
!right_comm union_comm union_assoc s₁ s₂ s₃

theorem union_self (s : finset A) : s ∪ s = s :=
ext (λ a, iff.intro
  (λ ain, or.elim (mem_or_mem_of_mem_union ain) (λ i, i) (λ i, i))
  (λ i, mem_union_left _ i))

theorem union_empty (s : finset A) : s ∪ ∅ = s :=
ext (λ a, iff.intro
  (suppose a ∈ s ∪ ∅, or.elim (mem_or_mem_of_mem_union this) (λ i, i) (λ i, absurd i !not_mem_empty))
  (suppose a ∈ s, mem_union_left _ this))

theorem empty_union (s : finset A) : ∅ ∪ s = s :=
calc ∅ ∪ s = s ∪ ∅ : union_comm
       ... = s     : union_empty

theorem insert_eq (a : A) (s : finset A) : insert a s = '{a} ∪ s :=
ext (take x, by rewrite [mem_insert_iff, mem_union_iff, mem_singleton_iff])

theorem insert_union (a : A) (s t : finset A) : insert a (s ∪ t) = insert a s ∪ t :=
by rewrite [insert_eq, insert_eq a s, union_assoc]
end union

/- inter -/
section inter
variable [h : decidable_eq A]
include h

definition inter (s₁ s₂ : finset A) : finset A :=
quot.lift_on₂ s₁ s₂
  (λ l₁ l₂,
    to_finset_of_nodup (list.inter (elt_of l₁) (elt_of l₂))
                       (nodup_inter_of_nodup _ (has_property l₁)))
  (λ v₁ v₂ w₁ w₂ p₁ p₂, quot.sound (perm_inter p₁ p₂))

infix [priority finset.prio] ∩ := inter

theorem mem_of_mem_inter_left {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∩ s₂ → a ∈ s₁ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_of_mem_inter_left ainl₁l₂)

theorem mem_of_mem_inter_right {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∩ s₂ → a ∈ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_of_mem_inter_right ainl₁l₂)

theorem mem_inter {a : A} {s₁ s₂ : finset A} : a ∈ s₁ → a ∈ s₂ → a ∈ s₁ ∩ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁ ainl₂, list.mem_inter_of_mem_of_mem ainl₁ ainl₂)

theorem mem_inter_iff (a : A) (s₁ s₂ : finset A) : a ∈ s₁ ∩ s₂ ↔ a ∈ s₁ ∧ a ∈ s₂ :=
iff.intro
 (λ h, and.intro (mem_of_mem_inter_left h) (mem_of_mem_inter_right h))
 (λ h, mem_inter (and.elim_left h) (and.elim_right h))

theorem mem_inter_eq (a : A) (s₁ s₂ : finset A) : (a ∈ s₁ ∩ s₂) = (a ∈ s₁ ∧ a ∈ s₂) :=
propext !mem_inter_iff

theorem inter_comm (s₁ s₂ : finset A) : s₁ ∩ s₂ = s₂ ∩ s₁ :=
ext (λ a, by rewrite [*mem_inter_eq]; exact and.comm)

theorem inter_assoc (s₁ s₂ s₃ : finset A) : (s₁ ∩ s₂) ∩ s₃ = s₁ ∩ (s₂ ∩ s₃) :=
ext (λ a, by rewrite [*mem_inter_eq]; exact and.assoc)

theorem inter_left_comm (s₁ s₂ s₃ : finset A) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) :=
!left_comm inter_comm inter_assoc s₁ s₂ s₃

theorem inter_right_comm (s₁ s₂ s₃ : finset A) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ :=
!right_comm inter_comm inter_assoc s₁ s₂ s₃

theorem inter_self (s : finset A) : s ∩ s = s :=
ext (λ a, iff.intro
  (λ h, mem_of_mem_inter_right h)
  (λ h, mem_inter h h))

theorem inter_empty (s : finset A) : s ∩ ∅ = ∅ :=
ext (λ a, iff.intro
  (suppose a ∈ s ∩ ∅, absurd (mem_of_mem_inter_right this) !not_mem_empty)
  (suppose a ∈ ∅,     absurd this !not_mem_empty))

theorem empty_inter (s : finset A) : ∅ ∩ s = ∅ :=
calc ∅ ∩ s = s ∩ ∅ : inter_comm
       ... = ∅     : inter_empty

theorem singleton_inter_of_mem {a : A} {s : finset A} (H : a ∈ s) :
  '{a} ∩ s = '{a} :=
ext (take x,
  begin
    rewrite [mem_inter_eq, !mem_singleton_iff],
    exact iff.intro
      (suppose x = a ∧ x ∈ s, and.left this)
      (suppose x = a, and.intro this (eq.subst (eq.symm this) H))
  end)

theorem singleton_inter_of_not_mem {a : A} {s : finset A} (H : a ∉ s) :
  '{a} ∩ s = ∅ :=
ext (take x,
  begin
    rewrite [mem_inter_eq, !mem_singleton_iff, mem_empty_eq],
    exact iff.intro
      (suppose x = a ∧ x ∈ s, H (eq.subst (and.left this) (and.right this)))
      (false.elim)
  end)
end inter

/- distributivity laws -/
section inter
variable [h : decidable_eq A]
include h

theorem inter_distrib_left (s t u : finset A) : s ∩ (t ∪ u) = (s ∩ t) ∪ (s ∩ u) :=
ext (take x, by rewrite [mem_inter_eq, *mem_union_eq, *mem_inter_eq]; apply and.left_distrib)

theorem inter_distrib_right (s t u : finset A) : (s ∪ t) ∩ u = (s ∩ u) ∪ (t ∩ u) :=
ext (take x, by rewrite [mem_inter_eq, *mem_union_eq, *mem_inter_eq]; apply and.right_distrib)

theorem union_distrib_left (s t u : finset A) : s ∪ (t ∩ u) = (s ∪ t) ∩ (s ∪ u) :=
ext (take x, by rewrite [mem_union_eq, *mem_inter_eq, *mem_union_eq]; apply or.left_distrib)

theorem union_distrib_right (s t u : finset A) : (s ∩ t) ∪ u = (s ∪ u) ∩ (t ∪ u) :=
ext (take x, by rewrite [mem_union_eq, *mem_inter_eq, *mem_union_eq]; apply or.right_distrib)
end inter

/- disjoint -/
-- Mainly for internal use; library will use s₁ ∩ s₂ = ∅. Note that it does not require decidable equality.
definition disjoint (s₁ s₂ : finset A) : Prop :=
quot.lift_on₂ s₁ s₂ (λ l₁ l₂, disjoint (elt_of l₁) (elt_of l₂))
  (λ v₁ v₂ w₁ w₂ p₁ p₂, propext (iff.intro
    (λ d₁ a (ainw₁ : a ∈ elt_of w₁),
      have a ∈ elt_of v₁, from mem_perm (perm.symm p₁) ainw₁,
      have a ∉ elt_of v₂, from disjoint_left d₁ this,
      not_mem_perm p₂ this)
    (λ d₂ a (ainv₁ : a ∈ elt_of v₁),
      have a ∈ elt_of w₁, from mem_perm p₁ ainv₁,
      have a ∉ elt_of w₂, from disjoint_left d₂ this,
      not_mem_perm (perm.symm p₂) this)))

theorem disjoint.elim {s₁ s₂ : finset A} {x : A} :
  disjoint s₁ s₂ → x ∈ s₁ → x ∈ s₂ → false :=
quot.induction_on₂ s₁ s₂ (take u₁ u₂, assume H H1 H2, H x H1 H2)

theorem disjoint.intro {s₁ s₂ : finset A} : (∀{x : A}, x ∈ s₁ → x ∈ s₂ → false) → disjoint s₁ s₂ :=
quot.induction_on₂ s₁ s₂ (take u₁ u₂, assume H, H)

theorem inter_eq_empty_of_disjoint [h : decidable_eq A] {s₁ s₂ : finset A} (H : disjoint s₁ s₂) : s₁ ∩ s₂ = ∅ :=
ext (take x, iff_false_intro (assume H1,
  disjoint.elim H (mem_of_mem_inter_left H1) (mem_of_mem_inter_right H1)))

theorem disjoint_of_inter_eq_empty [h : decidable_eq A] {s₁ s₂ : finset A} (H : s₁ ∩ s₂ = ∅) : disjoint s₁ s₂ :=
disjoint.intro (take x H1 H2,
  have x ∈ s₁ ∩ s₂, from mem_inter H1 H2,
  !not_mem_empty (eq.subst H this))

theorem disjoint.comm {s₁ s₂ : finset A} : disjoint s₁ s₂ → disjoint s₂ s₁ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ d, list.disjoint.comm d)

theorem inter_eq_empty [h : decidable_eq A] {s₁ s₂ : finset A}
    (H : ∀x : A, x ∈ s₁ → x ∈ s₂ → false) : s₁ ∩ s₂ = ∅ :=
inter_eq_empty_of_disjoint (disjoint.intro H)

/- subset -/
definition subset (s₁ s₂ : finset A) : Prop :=
quot.lift_on₂ s₁ s₂
  (λ l₁ l₂, sublist (elt_of l₁) (elt_of l₂))
  (λ v₁ v₂ w₁ w₂ p₁ p₂, propext (iff.intro
    (λ s₁ a i, mem_perm p₂ (s₁ a (mem_perm (perm.symm p₁) i)))
    (λ s₂ a i, mem_perm (perm.symm p₂) (s₂ a (mem_perm p₁ i)))))

infix [priority finset.prio] ⊆ := subset

theorem empty_subset (s : finset A) : ∅ ⊆ s :=
quot.induction_on s (λ l, list.nil_sub (elt_of l))

theorem subset_univ [h : fintype A] (s : finset A) : s ⊆ univ :=
quot.induction_on s (λ l a i, fintype.complete a)

theorem subset.refl (s : finset A) : s ⊆ s :=
quot.induction_on s (λ l, list.sub.refl (elt_of l))

theorem subset.trans {s₁ s₂ s₃ : finset A} : s₁ ⊆ s₂ → s₂ ⊆ s₃ → s₁ ⊆ s₃ :=
quot.induction_on₃ s₁ s₂ s₃ (λ l₁ l₂ l₃ h₁ h₂, list.sub.trans h₁ h₂)

theorem mem_of_subset_of_mem {s₁ s₂ : finset A} {a : A} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h₁ h₂, h₁ a h₂)

theorem subset.antisymm {s₁ s₂ : finset A} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ :=
ext (take x, iff.intro (assume H, mem_of_subset_of_mem H₁ H) (assume H, mem_of_subset_of_mem H₂ H))

-- alternative name
theorem eq_of_subset_of_subset {s₁ s₂ : finset A} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ :=
subset.antisymm H₁ H₂

theorem subset_of_forall {s₁ s₂ : finset A} : (∀x, x ∈ s₁ → x ∈ s₂) → s₁ ⊆ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ H, H)

theorem subset_insert [h : decidable_eq A] (s : finset A) (a : A) : s ⊆ insert a s :=
subset_of_forall (take x, suppose x ∈ s, mem_insert_of_mem _ this)

theorem eq_empty_of_subset_empty {x : finset A} (H : x ⊆ ∅) : x = ∅ :=
subset.antisymm H (empty_subset x)

theorem subset_empty_iff (x : finset A) : x ⊆ ∅ ↔ x = ∅ :=
iff.intro eq_empty_of_subset_empty (take xeq, by rewrite xeq; apply subset.refl ∅)

section
variable [decA : decidable_eq A]
include decA

theorem erase_subset_erase (a : A) {s t : finset A} (H : s ⊆ t) : erase a s ⊆ erase a t :=
begin
  apply subset_of_forall,
  intro x,
  rewrite *mem_erase_eq,
  intro H',
  show x ∈ t ∧ x ≠ a, from and.intro (mem_of_subset_of_mem H (and.left H')) (and.right H')
end

theorem erase_subset  (a : A) (s : finset A) : erase a s ⊆ s :=
begin
  apply subset_of_forall,
  intro x,
  rewrite mem_erase_eq,
  intro H,
  apply and.left H
end

theorem erase_eq_of_not_mem {a : A} {s : finset A} (anins : a ∉ s) : erase a s = s :=
eq_of_subset_of_subset !erase_subset
  (subset_of_forall (take x, assume xs : x ∈ s,
    have x ≠ a, from assume H', anins (eq.subst H' xs),
    mem_erase_of_ne_of_mem this xs))

theorem erase_insert_subset (a : A) (s : finset A) : erase a (insert a s) ⊆ s :=
decidable.by_cases
  (assume ains : a ∈ s, by rewrite [insert_eq_of_mem ains]; apply erase_subset)
  (assume nains : a ∉ s, by rewrite [!erase_insert nains]; apply subset.refl)

theorem erase_subset_of_subset_insert {a : A} {s t : finset A} (H : s ⊆ insert a t) :
  erase a s ⊆ t :=
subset.trans (!erase_subset_erase H) !erase_insert_subset

theorem insert_erase_subset (a : A) (s : finset A) : s ⊆ insert a (erase a s) :=
decidable.by_cases
  (assume ains : a ∈ s, by rewrite [!insert_erase ains]; apply subset.refl)
  (assume nains : a ∉ s, by rewrite[erase_eq_of_not_mem nains]; apply subset_insert)

theorem insert_subset_insert (a : A) {s t : finset A} (H : s ⊆ t) : insert a s ⊆ insert a t :=
begin
  apply subset_of_forall,
  intro x,
  rewrite *mem_insert_eq,
  intro H',
  cases H' with [xeqa, xins],
    exact (or.inl xeqa),
  exact (or.inr (mem_of_subset_of_mem H xins))
end

theorem subset_insert_of_erase_subset {s t : finset A} {a : A} (H : erase a s ⊆ t) :
  s ⊆ insert a t :=
subset.trans (insert_erase_subset a s) (!insert_subset_insert H)

theorem subset_insert_iff (s t : finset A) (a : A) : s ⊆ insert a t ↔ erase a s ⊆ t :=
iff.intro !erase_subset_of_subset_insert !subset_insert_of_erase_subset

end

/- upto -/
section upto
definition upto (n : nat) : finset nat :=
to_finset_of_nodup (list.upto n) (nodup_upto n)

theorem card_upto : ∀ n, card (upto n) = n :=
list.length_upto

theorem lt_of_mem_upto {n a : nat} : a ∈ upto n → a < n :=
list.lt_of_mem_upto

theorem mem_upto_succ_of_mem_upto {n a : nat} : a ∈ upto n → a ∈ upto (succ n) :=
list.mem_upto_succ_of_mem_upto

theorem mem_upto_of_lt {n a : nat} : a < n → a ∈ upto n :=
list.mem_upto_of_lt

theorem mem_upto_iff (a n : nat) : a ∈ upto n ↔ a < n :=
iff.intro lt_of_mem_upto mem_upto_of_lt

theorem mem_upto_eq (a n : nat) : a ∈ upto n = (a < n) :=
propext !mem_upto_iff
end upto

theorem upto_zero : upto 0 = ∅ := rfl

theorem upto_succ (n : ℕ) : upto (succ n) = upto n ∪ '{n} :=
begin
  apply ext, intro x,
  rewrite [mem_union_iff, *mem_upto_iff, mem_singleton_iff, lt_succ_iff_le, nat.le_iff_lt_or_eq],
end

/- useful rules for calculations with quantifiers -/
theorem exists_mem_empty_iff {A : Type} (P : A → Prop) : (∃ x, x ∈ ∅ ∧ P x) ↔ false :=
iff.intro
  (assume H,
    obtain x (H1 : x ∈ ∅ ∧ P x), from H,
    !not_mem_empty (and.left H1))
  (assume H, false.elim H)

theorem exists_mem_empty_eq {A : Type} (P : A → Prop) : (∃ x, x ∈ ∅ ∧ P x) = false :=
propext !exists_mem_empty_iff

theorem exists_mem_insert_iff {A : Type} [d : decidable_eq A]
    (a : A) (s : finset A) (P : A → Prop) :
  (∃ x, x ∈ insert a s ∧ P x) ↔ P a ∨ (∃ x, x ∈ s ∧ P x) :=
iff.intro
  (assume H,
    obtain x [H1 H2], from H,
    or.elim (eq_or_mem_of_mem_insert H1)
      (suppose x = a, or.inl (eq.subst this H2))
      (suppose x ∈ s, or.inr (exists.intro x (and.intro this H2))))
  (assume H,
    or.elim H
      (suppose P a, exists.intro a (and.intro !mem_insert this))
      (suppose ∃ x, x ∈ s ∧ P x,
        obtain x [H2 H3], from this,
        exists.intro x (and.intro (!mem_insert_of_mem H2) H3)))

theorem exists_mem_insert_eq {A : Type} [d : decidable_eq A] (a : A) (s : finset A) (P : A → Prop) :
  (∃ x, x ∈ insert a s ∧ P x) = (P a ∨ (∃ x, x ∈ s ∧ P x)) :=
propext !exists_mem_insert_iff

theorem forall_mem_empty_iff {A : Type} (P : A → Prop) : (∀ x, x ∈ ∅ → P x) ↔ true :=
iff.intro
  (assume H, trivial)
  (assume H, take x, assume H', absurd H' !not_mem_empty)

theorem forall_mem_empty_eq {A : Type} (P : A → Prop) : (∀ x, x ∈ ∅ → P x) = true :=
propext !forall_mem_empty_iff

theorem forall_mem_insert_iff {A : Type} [d : decidable_eq A]
    (a : A) (s : finset A) (P : A → Prop) :
  (∀ x, x ∈ insert a s → P x) ↔ P a ∧ (∀ x, x ∈ s → P x) :=
iff.intro
  (assume H, and.intro (H _ !mem_insert) (take x, assume H', H _ (!mem_insert_of_mem H')))
  (assume H, take x, assume H' : x ∈ insert a s,
    or.elim (eq_or_mem_of_mem_insert H')
      (suppose x = a, eq.subst (eq.symm this) (and.left H))
      (suppose x ∈ s, and.right H _ this))

theorem forall_mem_insert_eq {A : Type} [d : decidable_eq A] (a : A) (s : finset A) (P : A → Prop) :
  (∀ x, x ∈ insert a s → P x) = (P a ∧ (∀ x, x ∈ s → P x)) :=
propext !forall_mem_insert_iff

end finset


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

/-!
# The `zip_with` operation on vectors.

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

namespace vector

section zip_with

variables {α β γ : Type*} {n : ℕ} (f : α → β → γ)

/-- Apply the function `f : α → β → γ` to each corresponding pair of elements from two vectors. -/
def zip_with : vector α n → vector β n → vector γ n :=
λ x y, ⟨list.zip_with f x.1 y.1, by simp⟩

@[simp]
lemma zip_with_to_list (x : vector α n) (y : vector β n) :
  (vector.zip_with f x y).to_list = list.zip_with f x.to_list y.to_list :=
rfl

@[simp]
lemma zip_with_nth (x : vector α n) (y : vector β n) (i) :
  (vector.zip_with f x y).nth i = f (x.nth i) (y.nth i) :=
begin
  dsimp only [vector.zip_with, vector.nth],
  cases x, cases y,
  simp only [list.nth_le_zip_with, subtype.coe_mk],
  congr,
end

@[simp]

@[to_additive]
lemma prod_mul_prod_eq_prod_zip_with [comm_monoid α] (x y : vector α n) :
  x.to_list.prod * y.to_list.prod = (vector.zip_with (*) x y).to_list.prod :=
list.prod_mul_prod_eq_prod_zip_with_of_length_eq x.to_list y.to_list
  ((to_list_length x).trans (to_list_length y).symm)

end zip_with

end vector


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

Free abelian groups as abelianization of free groups.
-/
import algebra.pi_instances
import group_theory.free_group
import group_theory.abelianization

universes u v

variables (α : Type u)

def free_abelian_group : Type u :=
additive $ abelianization $ free_group α

instance : add_comm_group (free_abelian_group α) :=
@additive.add_comm_group _ $ abelianization.comm_group _

variable {α}

namespace free_abelian_group

def of (x : α) : free_abelian_group α :=
abelianization.of $ free_group.of x

def lift {β : Type v} [add_comm_group β] (f : α → β) (x : free_abelian_group α) : β :=
@abelianization.lift _ _ (multiplicative β) _ (@free_group.to_group _ (multiplicative β) _ f) _ x

namespace lift
variables {β : Type v} [add_comm_group β] (f : α → β)
open free_abelian_group

instance is_add_group_hom : is_add_group_hom (lift f) :=
⟨λ x y, @is_group_hom.mul _ (multiplicative β) _ _ _ (abelianization.lift.is_group_hom _) x y⟩

@[simp] protected lemma add (x y : free_abelian_group α) :
  lift f (x + y) = lift f x + lift f y :=
is_add_group_hom.add _ _ _

@[simp] protected lemma neg (x : free_abelian_group α) : lift f (-x) = -lift f x :=
is_add_group_hom.neg _ _

@[simp] protected lemma sub (x y : free_abelian_group α) :
  lift f (x - y) = lift f x - lift f y :=
by simp

@[simp] protected lemma zero : lift f 0 = 0 :=
is_add_group_hom.zero _

@[simp] protected lemma of (x : α) : lift f (of x) = f x :=
by unfold of; unfold lift; simp

protected theorem unique (g : free_abelian_group α → β) [is_add_group_hom g]
  (hg : ∀ x, g (of x) = f x) {x} :
  g x = lift f x :=
@abelianization.lift.unique (free_group α) _ (multiplicative β) _ _ _ g
  ⟨λ x y, @is_add_group_hom.add (additive $ abelianization (free_group α)) _ _ _ _ _ x y⟩ (λ x,
  @free_group.to_group.unique α (multiplicative β) _ _ (g ∘ abelianization.of)
    ⟨λ m n, is_add_group_hom.add g (abelianization.of m) (abelianization.of n)⟩ hg _) _

protected theorem ext (g h : free_abelian_group α → β)
  [is_add_group_hom g] [is_add_group_hom h]
  (H : ∀ x, g (of x) = h (of x)) {x} :
  g x = h x :=
(lift.unique (g ∘ of) g (λ _, rfl)).trans $
eq.symm $ lift.unique _ _ $ λ x, eq.symm $ H x

lemma map_hom {α β γ} [add_comm_group β] [add_comm_group γ]
  (a : free_abelian_group α) (f : α → β) (g : β → γ) [is_add_group_hom g] :
  g (a.lift f) = a.lift (g ∘ f) :=
show (g ∘ lift f) a = a.lift (g ∘ f),
begin
  apply @lift.unique,
  assume a,
  simp only [(∘), lift.of]
end

def universal : (α → β) ≃ { f : free_abelian_group α → β // is_add_group_hom f } :=
{ to_fun := λ f, ⟨_, lift.is_add_group_hom f⟩,
  inv_fun := λ f, f.1 ∘ of,
  left_inv := λ f, funext $ λ x, lift.of f x,
  right_inv := λ f, subtype.eq $ funext $ λ x, eq.symm $ by letI := f.2; from
    lift.unique _ _ (λ _, rfl) }

end lift

local attribute [instance] quotient_group.left_rel normal_subgroup.to_is_subgroup

@[elab_as_eliminator]
protected theorem induction_on
  {C : free_abelian_group α → Prop}
  (z : free_abelian_group α)
  (C0 : C 0)
  (C1 : ∀ x, C $ of x)
  (Cn : ∀ x, C (of x) → C (-of x))
  (Cp : ∀ x y, C x → C y → C (x + y)) : C z :=
quotient.induction_on z $ λ x, quot.induction_on x $ λ L,
list.rec_on L C0 $ λ ⟨x, b⟩ tl ih,
bool.rec_on b (Cp _ _ (Cn _ (C1 x)) ih) (Cp _ _ (C1 x) ih)

instance is_add_group_hom_lift' {α} (β) [add_comm_group β] (a : free_abelian_group α) :
  is_add_group_hom (λf, (a.lift f : β)) :=
begin
  refine ⟨assume f g, free_abelian_group.induction_on a _ _ _ _⟩,
  { simp [is_add_group_hom.zero (free_abelian_group.lift f)] },
  { simp [lift.of], assume x, refl },
  { simp [is_add_group_hom.neg (free_abelian_group.lift f)],
    assume x h, show - (f x + g x) = -f x + - g x, exact neg_add _ _ },
  { simp [is_add_group_hom.add (free_abelian_group.lift f)],
    assume x y hx hy,
    rw [hx, hy],
    ac_refl }
end

variables {β : Type u}

instance : monad free_abelian_group.{u} :=
{ pure := λ α, of,
  bind := λ α β x f, lift f x }

@[elab_as_eliminator]
protected theorem induction_on'
  {C : free_abelian_group α → Prop}
  (z : free_abelian_group α)
  (C0 : C 0)
  (C1 : ∀ x, C $ pure x)
  (Cn : ∀ x, C (pure x) → C (-pure x))
  (Cp : ∀ x y, C x → C y → C (x + y)) : C z :=
free_abelian_group.induction_on z C0 C1 Cn Cp

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

@[simp] lemma map_zero (f : α → β) : f <$> (0 : free_abelian_group α) = 0 :=
lift.zero (of ∘ f)

@[simp] lemma map_add (f : α → β) (x y : free_abelian_group α) : f <$> (x + y) = f <$> x + f <$> y :=
lift.add _ _ _

@[simp] lemma map_neg (f : α → β) (x : free_abelian_group α) : f <$> (-x) = -(f <$> x) :=
lift.neg _ _

@[simp] lemma map_sub (f : α → β) (x y : free_abelian_group α) : f <$> (x - y) = f <$> x - f <$> y :=
lift.sub _ _ _

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

@[simp] lemma zero_bind (f : α → free_abelian_group β) : 0 >>= f = 0 :=
lift.zero f

@[simp] lemma add_bind (f : α → free_abelian_group β) (x y : free_abelian_group α) : x + y >>= f = (x >>= f) + (y >>= f) :=
lift.add _ _ _

@[simp] lemma neg_bind (f : α → free_abelian_group β) (x : free_abelian_group α) : -x >>= f = -(x >>= f) :=
lift.neg _ _

@[simp] lemma sub_bind (f : α → free_abelian_group β) (x y : free_abelian_group α) : x - y >>= f = (x >>= f) - (y >>= f) :=
lift.sub _ _ _

@[simp] lemma pure_seq (f : α → β) (x : free_abelian_group α) : pure f <*> x = f <$> x :=
pure_bind _ _

@[simp] lemma zero_seq (x : free_abelian_group α) : (0 : free_abelian_group (α → β)) <*> x = 0 :=
zero_bind _

@[simp] lemma add_seq (f g : free_abelian_group (α → β)) (x : free_abelian_group α) : f + g <*> x = (f <*> x) + (g <*> x) :=
add_bind _ _ _

@[simp] lemma neg_seq (f : free_abelian_group (α → β)) (x : free_abelian_group α) : -f <*> x = -(f <*> x) :=
neg_bind _ _

@[simp] lemma sub_seq (f g : free_abelian_group (α → β)) (x : free_abelian_group α) : f - g <*> x = (f <*> x) - (g <*> x) :=
sub_bind _ _ _

instance is_add_group_hom_seq (f : free_abelian_group (α → β)) : is_add_group_hom ((<*>) f) :=
⟨λ x y, show lift (<$> (x+y)) _ = _, by simp only [map_add]; exact
@@is_add_group_hom.add _ _ _ (@@free_abelian_group.is_add_group_hom_lift' (free_abelian_group β) _ _) _ _⟩

@[simp] lemma seq_zero (f : free_abelian_group (α → β)) : f <*> 0 = 0 :=
is_add_group_hom.zero _

@[simp]

@[simp] lemma seq_neg (f : free_abelian_group (α → β)) (x : free_abelian_group α) : f <*> (-x) = -(f <*> x) :=
is_add_group_hom.neg _ _

@[simp] lemma seq_sub (f : free_abelian_group (α → β)) (x y : free_abelian_group α) : f <*> (x - y) = (f <*> x) - (f <*> y) :=
is_add_group_hom.sub _ _ _

instance : is_lawful_monad free_abelian_group.{u} :=
{ id_map := λ α x, free_abelian_group.induction_on' x (map_zero id) (λ x, map_pure id x)
    (λ x ih, by rw [map_neg, ih]) (λ x y ihx ihy, by rw [map_add, ihx, ihy]),
  pure_bind := λ α β x f, pure_bind f x,
  bind_assoc := λ α β γ x f g, free_abelian_group.induction_on' x
    (by iterate 3 { rw zero_bind }) (λ x, by iterate 2 { rw pure_bind })
    (λ x ih, by iterate 3 { rw neg_bind }; rw ih)
    (λ x y ihx ihy, by iterate 3 { rw add_bind }; rw [ihx, ihy]) }

instance : is_comm_applicative free_abelian_group.{u} :=
{ commutative_prod := λ α β x y, free_abelian_group.induction_on' x
    (by rw [map_zero, zero_seq, seq_zero])
    (λ p, by rw [map_pure, pure_seq]; exact free_abelian_group.induction_on' y
      (by rw [map_zero, map_zero, zero_seq])
      (λ q, by rw [map_pure, map_pure, pure_seq, map_pure])
      (λ q ih, by rw [map_neg, map_neg, neg_seq, ih])
      (λ y₁ y₂ ih1 ih2, by rw [map_add, map_add, add_seq, ih1, ih2]))
    (λ p ih, by rw [map_neg, neg_seq, seq_neg, ih])
    (λ x₁ x₂ ih1 ih2, by rw [map_add, add_seq, seq_add, ih1, ih2]) }

end free_abelian_group


import field_theory.splitting_field ring_theory.polynomial
import data.polynomial

universes u

variables {α : Type u} [field α]

def adjoin_all_roots (f : polynomial α) : Type u :=
sorry

variables (β : Type u) (f : polynomial α)

variables [field β]

variables [algebra α β]

def is_splitting_field (f : polynomial α) : Prop :=
polynomial.splits (algebra_map α β) f ∧ β = adjoin_all_roots f

theorem splitting_theorem :
(is_splitting_field β f) →
∀ (p : polynomial α), (irreducible p → (∃ (x : β), polynomial.aeval α β x p = 0) →
polynomial.splits (algebra_map α β) p) :=
sorry


import tactic
import data.real.irrational

def positive_integer (x : ℝ) := x ∈ set.range (coe : ℕ → ℝ) ∧ x > 0

/-- There is a positive integer n such that √(n - 2) + √(n + 2) is also a positive integer. -/
lemma exercise : ∃ (n : ℕ), n > 0 ∧ positive_integer (real.sqrt (n - 2) + real.sqrt (n + 2)) :=
begin
  sorry
end


import game.sets.sets_level01
import data.set.basic
import tactic

namespace xena -- hide

variable X : Type -- hide

open_locale classical

theorem distr_dif_inter (A B C : set X) : A \ (B ∩ C) = (A \ B) ∪ (A \ C) :=
begin
  rw ext_iff,
  intro h,
  split,
  intro j,
  rw mem_sdiff_iff at j,
  rw mem_union_iff,
  rw mem_inter_iff at j,
  push_neg at j,
  cases j with d hd,
  cases hd with t ht,
  left,
  rw mem_sdiff_iff,
  split,
  exact d,
  exact t,
  right,
  rw mem_sdiff_iff,
  split,
  exact d,
  exact ht,
  intro k,
  rw mem_union_iff at k,
  rw mem_sdiff_iff,
  rw mem_inter_iff,
  push_neg,
  cases k with d hd,
  rw mem_sdiff_iff at d,
  cases d with y hy,
  split,
  exact y,
  left,
  exact hy,
  rw mem_sdiff_iff at hd,
  split,
  cases hd with t ht,
  exact t,
  cases hd with r hr,
  right,
  exact hr,
end

end xena -- hide