/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Yaël Dillies
-/
import order.locally_finite

/-!
# Intervals as finsets

This file provides basic results about all the `finset.Ixx`, which are defined in
`order.locally_finite`.

## TODO

This file was originally only about `finset.Ico a b` where `a b : ℕ`. No care has yet been taken to
generalize these lemmas properly and many lemmas about `Icc`, `Ioc`, `Ioo` are missing. In general,
what's to do is taking the lemmas in `data.x.intervals` and abstract away the concrete structure.
-/

variables {α : Type*}

namespace finset
section preorder
variables [preorder α] [locally_finite_order α] {a a₁ a₂ b b₁ b₂ c x : α}

@[simp] lemma nonempty_Icc : (Icc a b).nonempty ↔ a ≤ b :=
by rw [←coe_nonempty, coe_Icc, set.nonempty_Icc]

@[simp] lemma nonempty_Ico : (Ico a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ico, set.nonempty_Ico]

@[simp] lemma nonempty_Ioc : (Ioc a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ioc, set.nonempty_Ioc]

@[simp] lemma nonempty_Ioo [densely_ordered α] : (Ioo a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ioo, set.nonempty_Ioo]

@[simp] lemma Icc_eq_empty_iff : Icc a b = ∅ ↔ ¬a ≤ b :=
by rw [←coe_eq_empty, coe_Icc, set.Icc_eq_empty_iff]

@[simp] lemma Ico_eq_empty_iff : Ico a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ico, set.Ico_eq_empty_iff]

@[simp] lemma Ioc_eq_empty_iff : Ioc a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ioc, set.Ioc_eq_empty_iff]

@[simp] lemma Ioo_eq_empty_iff [densely_ordered α] : Ioo a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ioo, set.Ioo_eq_empty_iff]

alias Icc_eq_empty_iff ↔ _ finset.Icc_eq_empty
alias Ico_eq_empty_iff ↔ _ finset.Ico_eq_empty
alias Ioc_eq_empty_iff ↔ _ finset.Ioc_eq_empty

@[simp] lemma Ioo_eq_empty (h : ¬a < b) : Ioo a b = ∅ :=
eq_empty_iff_forall_not_mem.2 $ λ x hx, h ((mem_Ioo.1 hx).1.trans (mem_Ioo.1 hx).2)

@[simp] lemma Icc_eq_empty_of_lt (h : b < a) : Icc a b = ∅ := Icc_eq_empty h.not_le
@[simp] lemma Ico_eq_empty_of_le (h : b ≤ a) : Ico a b = ∅ := Ico_eq_empty h.not_lt
@[simp] lemma Ioc_eq_empty_of_le (h : b ≤ a) : Ioc a b = ∅ := Ioc_eq_empty h.not_lt
@[simp] lemma Ioo_eq_empty_of_le (h : b ≤ a) : Ioo a b = ∅ := Ioo_eq_empty h.not_lt

@[simp] lemma left_mem_Icc : a ∈ Icc a b ↔ a ≤ b := by simp only [mem_Icc, true_and, le_rfl]
@[simp] lemma left_mem_Ico : a ∈ Ico a b ↔ a < b := by simp only [mem_Ico, true_and, le_refl]
@[simp] lemma right_mem_Icc : b ∈ Icc a b ↔ a ≤ b := by simp only [mem_Icc, and_true, le_rfl]
@[simp] lemma right_mem_Ioc : b ∈ Ioc a b ↔ a < b := by simp only [mem_Ioc, and_true, le_rfl]

@[simp] lemma left_not_mem_Ioc : a ∉ Ioc a b := λ h, lt_irrefl _ (mem_Ioc.1 h).1
@[simp] lemma left_not_mem_Ioo : a ∉ Ioo a b := λ h, lt_irrefl _ (mem_Ioo.1 h).1
@[simp] lemma right_not_mem_Ico : b ∉ Ico a b := λ h, lt_irrefl _ (mem_Ico.1 h).2
@[simp] lemma right_not_mem_Ioo : b ∉ Ioo a b := λ h, lt_irrefl _ (mem_Ioo.1 h).2

lemma Icc_subset_Icc (ha : a₂ ≤ a₁) (hb : b₁ ≤ b₂) : Icc a₁ b₁ ⊆ Icc a₂ b₂ :=
by simpa [←coe_subset] using set.Icc_subset_Icc ha hb

lemma Ico_subset_Ico (ha : a₂ ≤ a₁) (hb : b₁ ≤ b₂) : Ico a₁ b₁ ⊆ Ico a₂ b₂ :=
by simpa [←coe_subset] using set.Ico_subset_Ico ha hb

lemma Ioc_subset_Ioc (ha : a₂ ≤ a₁) (hb : b₁ ≤ b₂) : Ioc a₁ b₁ ⊆ Ioc a₂ b₂ :=
by simpa [←coe_subset] using set.Ioc_subset_Ioc ha hb

lemma Ioo_subset_Ioo (ha : a₂ ≤ a₁) (hb : b₁ ≤ b₂) : Ioo a₁ b₁ ⊆ Ioo a₂ b₂ :=
by simpa [←coe_subset] using set.Ioo_subset_Ioo ha hb

lemma Ico_subset_Ioo_left (h : a₁ < a₂) : Ico a₂ b ⊆ Ioo a₁ b :=
by { rw [←coe_subset, coe_Ico, coe_Ioo], exact set.Ico_subset_Ioo_left h }

lemma Ioc_subset_Ioo_right (h : b₁ < b₂) : Ioc a b₁ ⊆ Ioo a b₂ :=
by { rw [←coe_subset, coe_Ioc, coe_Ioo], exact set.Ioc_subset_Ioo_right h }

lemma Icc_subset_Ico_right (h : b₁ < b₂) : Icc a b₁ ⊆ Ico a b₂ :=
by { rw [←coe_subset, coe_Icc, coe_Ico], exact set.Icc_subset_Ico_right h }

lemma Ioo_subset_Ico_self : Ioo a b ⊆ Ico a b :=
by { rw [←coe_subset, coe_Ioo, coe_Ico], exact set.Ioo_subset_Ico_self }

lemma Ioo_subset_Ioc_self : Ioo a b ⊆ Ioc a b :=
by { rw [←coe_subset, coe_Ioo, coe_Ioc], exact set.Ioo_subset_Ioc_self }

lemma Ico_subset_Icc_self : Ico a b ⊆ Icc a b :=
by { rw [←coe_subset, coe_Ico, coe_Icc], exact set.Ico_subset_Icc_self }

lemma Ioc_subset_Icc_self : Ioc a b ⊆ Icc a b :=
by { rw [←coe_subset, coe_Ioc, coe_Icc], exact set.Ioc_subset_Icc_self }

lemma Ioo_subset_Icc_self : Ioo a b ⊆ Icc a b := Ioo_subset_Ico_self.trans Ico_subset_Icc_self

lemma Icc_subset_Icc_iff (h₁ : a₁ ≤ b₁) : Icc a₁ b₁ ⊆ Icc a₂ b₂ ↔ a₂ ≤ a₁ ∧ b₁ ≤ b₂ :=
by rw [←coe_subset, coe_Icc, coe_Icc, set.Icc_subset_Icc_iff h₁]

lemma Icc_subset_Ioo_iff (h₁ : a₁ ≤ b₁) : Icc a₁ b₁ ⊆ Ioo a₂ b₂ ↔ a₂ < a₁ ∧ b₁ < b₂ :=
by rw [←coe_subset, coe_Icc, coe_Ioo, set.Icc_subset_Ioo_iff h₁]

lemma Icc_subset_Ico_iff (h₁ : a₁ ≤ b₁) : Icc a₁ b₁ ⊆ Ico a₂ b₂ ↔ a₂ ≤ a₁ ∧ b₁ < b₂ :=
by rw [←coe_subset, coe_Icc, coe_Ico, set.Icc_subset_Ico_iff h₁]

lemma Icc_subset_Ioc_iff (h₁ : a₁ ≤ b₁) : Icc a₁ b₁ ⊆ Ioc a₂ b₂ ↔ a₂ < a₁ ∧ b₁ ≤ b₂ :=
(Icc_subset_Ico_iff h₁.dual).trans and.comm

--TODO: `Ico_subset_Ioo_iff`, `Ioc_subset_Ioo_iff`

lemma Icc_ssubset_Icc_left (hI : a₂ ≤ b₂) (ha : a₂ < a₁) (hb : b₁ ≤ b₂) : Icc a₁ b₁ ⊂ Icc a₂ b₂ :=
by { rw [←coe_ssubset, coe_Icc, coe_Icc], exact set.Icc_ssubset_Icc_left hI ha hb }

lemma Icc_ssubset_Icc_right (hI : a₂ ≤ b₂) (ha : a₂ ≤ a₁) (hb : b₁ < b₂) : Icc a₁ b₁ ⊂ Icc a₂ b₂ :=
by { rw [←coe_ssubset, coe_Icc, coe_Icc], exact set.Icc_ssubset_Icc_right hI ha hb }

variables (a)

@[simp] lemma Ico_self : Ico a a = ∅ := Ico_eq_empty $ lt_irrefl _
@[simp] lemma Ioc_self : Ioc a a = ∅ := Ioc_eq_empty $ lt_irrefl _
@[simp] lemma Ioo_self : Ioo a a = ∅ := Ioo_eq_empty $ lt_irrefl _

variables {a}

/-- A set with upper and lower bounds in a locally finite order is a fintype -/
def _root_.set.fintype_of_mem_bounds {s : set α} [decidable_pred (∈ s)]
  (ha : a ∈ lower_bounds s) (hb : b ∈ upper_bounds s) : fintype s :=
set.fintype_subset (set.Icc a b) $ λ x hx, ⟨ha hx, hb hx⟩

lemma _root_.bdd_below.finite_of_bdd_above {s : set α} (h₀ : bdd_below s) (h₁ : bdd_above s) :
  s.finite :=
let ⟨a, ha⟩ := h₀, ⟨b, hb⟩ := h₁ in by { classical, exact ⟨set.fintype_of_mem_bounds ha hb⟩ }

section filter

lemma Ico_filter_lt_of_le_left [decidable_pred (< c)] (hca : c ≤ a) : (Ico a b).filter (< c) = ∅ :=
filter_false_of_mem (λ x hx, (hca.trans (mem_Ico.1 hx).1).not_lt)

lemma Ico_filter_lt_of_right_le [decidable_pred (< c)] (hbc : b ≤ c) :
  (Ico a b).filter (< c) = Ico a b :=
filter_true_of_mem (λ x hx, (mem_Ico.1 hx).2.trans_le hbc)

lemma Ico_filter_lt_of_le_right [decidable_pred (< c)] (hcb : c ≤ b) :
  (Ico a b).filter (< c) = Ico a c :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_Ico, and.right_comm],
  exact and_iff_left_of_imp (λ h, h.2.trans_le hcb),
end

lemma Ico_filter_le_of_le_left {a b c : α} [decidable_pred ((≤) c)] (hca : c ≤ a) :
  (Ico a b).filter ((≤) c) = Ico a b :=
filter_true_of_mem (λ x hx, hca.trans (mem_Ico.1 hx).1)

lemma Ico_filter_le_of_right_le {a b : α} [decidable_pred ((≤) b)] : (Ico a b).filter ((≤) b) = ∅ :=
filter_false_of_mem (λ x hx, (mem_Ico.1 hx).2.not_le)

lemma Ico_filter_le_of_left_le {a b c : α} [decidable_pred ((≤) c)] (hac : a ≤ c) :
  (Ico a b).filter ((≤) c) = Ico c b :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_Ico, and_comm, and.left_comm],
  exact and_iff_right_of_imp (λ h, hac.trans h.1),
end

variables (a b) [fintype α]

lemma filter_lt_lt_eq_Ioo [decidable_pred (λ j, a < j ∧ j < b)] :
  univ.filter (λ j, a < j ∧ j < b) = Ioo a b := by { ext, simp }

lemma filter_lt_le_eq_Ioc [decidable_pred (λ j, a < j ∧ j ≤ b)] :
  univ.filter (λ j, a < j ∧ j ≤ b) = Ioc a b := by { ext, simp }

lemma filter_le_lt_eq_Ico [decidable_pred (λ j, a ≤ j ∧ j < b)] :
  univ.filter (λ j, a ≤ j ∧ j < b) = Ico a b := by { ext, simp }

lemma filter_le_le_eq_Icc [decidable_pred (λ j, a ≤ j ∧ j ≤ b)] :
  univ.filter (λ j, a ≤ j ∧ j ≤ b) = Icc a b := by { ext, simp }

lemma filter_lt_eq_Ioi [order_top α] [decidable_pred ((<) a)] : univ.filter ((<) a) = Ioi a :=
by { ext, simp }

lemma filter_le_eq_Ici [order_top α] [decidable_pred ((≤) a)] : univ.filter ((≤) a) = Ici a :=
by { ext, simp }

lemma filter_gt_eq_Iio [order_bot α] [decidable_pred (< a)] : univ.filter (< a) = Iio a :=
by { ext, simp }

lemma filter_ge_eq_Iic [order_bot α] [decidable_pred (≤ a)] : univ.filter (≤ a) = Iic a :=
by { ext, simp }

end filter

section order_top
variables [order_top α]

lemma Icc_subset_Ici_self : Icc a b ⊆ Ici a := Icc_subset_Icc_right le_top
lemma Ico_subset_Ici_self : Ico a b ⊆ Ici a := Ico_subset_Icc_self.trans Icc_subset_Ici_self
lemma Ioc_subset_Ici_self : Ioc a b ⊆ Ici a := Ioc_subset_Icc_self.trans Icc_subset_Ici_self
lemma Ioo_subset_Ici_self : Ioo a b ⊆ Ici a := Ioo_subset_Icc_self.trans Icc_subset_Ici_self
lemma Ioi_subset_Ici_self : Ioi a ⊆ Ici a := Ioc_subset_Icc_self
lemma Ioc_subset_Ioi_self : Ioc a b ⊆ Ioi a := Ioc_subset_Ioc_right le_top
lemma Ioo_subset_Ioi_self : Ioo a b ⊆ Ioi a := Ioo_subset_Ioc_self.trans Ioc_subset_Ioi_self

lemma _root_.bdd_below.finite {s : set α} (hs : bdd_below s) : s.finite :=
hs.finite_of_bdd_above $ order_top.bdd_above s

end order_top

section order_bot
variables [order_bot α]

lemma Icc_subset_Iic_self : Icc a b ⊆ Iic b := Icc_subset_Icc_left bot_le
lemma Ico_subset_Iic_self : Ico a b ⊆ Iic b := Ico_subset_Icc_self.trans Icc_subset_Iic_self
lemma Ioc_subset_Iic_self : Ioc a b ⊆ Iic b := Ioc_subset_Icc_self.trans Icc_subset_Iic_self
lemma Ioo_subset_Iic_self : Ioo a b ⊆ Iic b := Ioo_subset_Icc_self.trans Icc_subset_Iic_self
lemma Iio_subset_Iic_self : Iio b ⊆ Iic b := Ico_subset_Icc_self
lemma Ico_subset_Iio_self : Ico a b ⊆ Iio b := Ico_subset_Ico_left bot_le
lemma Ioo_subset_Iio_self : Ioo a b ⊆ Iio b := Ioo_subset_Ico_self.trans Ico_subset_Iio_self

lemma _root_.bdd_above.finite {s : set α} (hs : bdd_above s) : s.finite := hs.dual.finite

end order_bot
end preorder

section partial_order
variables [partial_order α] [locally_finite_order α] {a b c : α}

@[simp] lemma Icc_self (a : α) : Icc a a = {a} := by rw [←coe_eq_singleton, coe_Icc, set.Icc_self]

@[simp] lemma Icc_eq_singleton_iff : Icc a b = {c} ↔ a = c ∧ b = c :=
by rw [←coe_eq_singleton, coe_Icc, set.Icc_eq_singleton_iff]

section decidable_eq
variables [decidable_eq α]

@[simp] lemma Icc_erase_left (a b : α) : (Icc a b).erase a = Ioc a b := by simp [←coe_inj]
@[simp] lemma Icc_erase_right (a b : α) : (Icc a b).erase b = Ico a b := by simp [←coe_inj]
@[simp] lemma Ico_erase_left (a b : α) : (Ico a b).erase a = Ioo a b := by simp [←coe_inj]
@[simp] lemma Ioc_erase_right (a b : α) : (Ioc a b).erase b = Ioo a b := by simp [←coe_inj]
@[simp] lemma Icc_diff_both (a b : α) : Icc a b \ {a, b} = Ioo a b := by simp [←coe_inj]

@[simp] lemma Ico_insert_right (h : a ≤ b) : insert b (Ico a b) = Icc a b :=
by rw [←coe_inj, coe_insert, coe_Icc, coe_Ico, set.insert_eq, set.union_comm, set.Ico_union_right h]

@[simp] lemma Ioc_insert_left (h : a ≤ b) : insert a (Ioc a b) = Icc a b :=
by rw [←coe_inj, coe_insert, coe_Ioc, coe_Icc, set.insert_eq, set.union_comm, set.Ioc_union_left h]

@[simp] lemma Ioo_insert_left (h : a < b) : insert a (Ioo a b) = Ico a b :=
by rw [←coe_inj, coe_insert, coe_Ioo, coe_Ico, set.insert_eq, set.union_comm, set.Ioo_union_left h]

@[simp] lemma Ioo_insert_right (h : a < b) : insert b (Ioo a b) = Ioc a b :=
by rw [←coe_inj, coe_insert, coe_Ioo, coe_Ioc, set.insert_eq, set.union_comm, set.Ioo_union_right h]

@[simp] lemma Icc_diff_Ico_self (h : a ≤ b) : Icc a b \ Ico a b = {b} := by simp [←coe_inj, h]
@[simp] lemma Icc_diff_Ioc_self (h : a ≤ b) : Icc a b \ Ioc a b = {a} := by simp [←coe_inj, h]
@[simp] lemma Icc_diff_Ioo_self (h : a ≤ b) : Icc a b \ Ioo a b = {a, b} := by simp [←coe_inj, h]
@[simp] lemma Ico_diff_Ioo_self (h : a < b) : Ico a b \ Ioo a b = {a} := by simp [←coe_inj, h]
@[simp] lemma Ioc_diff_Ioo_self (h : a < b) : Ioc a b \ Ioo a b = {b} := by simp [←coe_inj, h]

@[simp] lemma Ico_inter_Ico_consecutive (a b c : α) : Ico a b ∩ Ico b c = ∅ :=
begin
  refine eq_empty_of_forall_not_mem (λ x hx, _),
  rw [mem_inter, mem_Ico, mem_Ico] at hx,
  exact hx.1.2.not_le hx.2.1,
end

lemma Ico_disjoint_Ico_consecutive (a b c : α) : disjoint (Ico a b) (Ico b c) :=
le_of_eq $ Ico_inter_Ico_consecutive a b c

end decidable_eq

-- Those lemmas are purposefully the other way around

lemma Icc_eq_cons_Ico (h : a ≤ b) : Icc a b = (Ico a b).cons b right_not_mem_Ico :=
by { classical, rw [cons_eq_insert, Ico_insert_right h] }

lemma Icc_eq_cons_Ioc (h : a ≤ b) : Icc a b = (Ioc a b).cons a left_not_mem_Ioc :=
by { classical, rw [cons_eq_insert, Ioc_insert_left h] }

lemma Ico_filter_le_left {a b : α} [decidable_pred (≤ a)] (hab : a < b) :
  (Ico a b).filter (λ x, x ≤ a) = {a} :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_singleton, and.right_comm, ←le_antisymm_iff, eq_comm],
  exact and_iff_left_of_imp (λ h, h.le.trans_lt hab),
end

lemma card_Ico_eq_card_Icc_sub_one (a b : α) : (Ico a b).card = (Icc a b).card - 1 :=
begin
  classical,
  by_cases h : a ≤ b,
  { rw [←Ico_insert_right h, card_insert_of_not_mem right_not_mem_Ico],
    exact (nat.add_sub_cancel _ _).symm },
  { rw [Ico_eq_empty (λ h', h h'.le), Icc_eq_empty h, card_empty, zero_tsub] }
end

lemma card_Ioc_eq_card_Icc_sub_one (a b : α) : (Ioc a b).card = (Icc a b).card - 1 :=
@card_Ico_eq_card_Icc_sub_one (order_dual α) _ _ _ _

lemma card_Ioo_eq_card_Ico_sub_one (a b : α) : (Ioo a b).card = (Ico a b).card - 1 :=
begin
  classical,
  by_cases h : a ≤ b,
  { obtain rfl | h' := h.eq_or_lt,
    { rw [Ioo_self, Ico_self, card_empty] },
    rw [←Ioo_insert_left h', card_insert_of_not_mem left_not_mem_Ioo],
    exact (nat.add_sub_cancel _ _).symm },
  { rw [Ioo_eq_empty (λ h', h h'.le), Ico_eq_empty (λ h', h h'.le), card_empty, zero_tsub] }
end

lemma card_Ioo_eq_card_Ioc_sub_one (a b : α) : (Ioo a b).card = (Ioc a b).card - 1 :=
@card_Ioo_eq_card_Ico_sub_one (order_dual α) _ _ _ _

lemma card_Ioo_eq_card_Icc_sub_two (a b : α) : (Ioo a b).card = (Icc a b).card - 2 :=
by { rw [card_Ioo_eq_card_Ico_sub_one, card_Ico_eq_card_Icc_sub_one], refl }

section order_top
variables [order_top α]

@[simp] lemma Ici_erase [decidable_eq α] (a : α) : (Ici a).erase a = Ioi a := Icc_erase_left _ _
@[simp] lemma Ioi_insert [decidable_eq α] (a : α) : insert a (Ioi a) = Ici a :=
Ioc_insert_left le_top

-- Purposefully written the other way around
lemma Ici_eq_cons_Ioi (a : α) : Ici a = (Ioi a).cons a left_not_mem_Ioc :=
by { classical, rw [cons_eq_insert, Ioi_insert] }

end order_top

section order_bot
variables [order_bot α]

@[simp] lemma Iic_erase [decidable_eq α] (b : α) : (Iic b).erase b = Iio b := Icc_erase_right _ _
@[simp] lemma Iio_insert [decidable_eq α] (b : α) : insert b (Iio b) = Iic b :=
Ico_insert_right bot_le

-- Purposefully written the other way around
lemma Iic_eq_cons_Iio (b : α) : Iic b = (Iio b).cons b right_not_mem_Ico :=
by { classical, rw [cons_eq_insert, Iio_insert] }

end order_bot
end partial_order

section linear_order
variables [linear_order α] [locally_finite_order α] {a b : α}

lemma Ico_subset_Ico_iff {a₁ b₁ a₂ b₂ : α} (h : a₁ < b₁) :
  Ico a₁ b₁ ⊆ Ico a₂ b₂ ↔ a₂ ≤ a₁ ∧ b₁ ≤ b₂ :=
by rw [←coe_subset, coe_Ico, coe_Ico, set.Ico_subset_Ico_iff h]

lemma Ico_union_Ico_eq_Ico {a b c : α} (hab : a ≤ b) (hbc : b ≤ c) :
  Ico a b ∪ Ico b c = Ico a c :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico_eq_Ico hab hbc]

lemma Ico_union_Ico' {a b c d : α} (hcb : c ≤ b) (had : a ≤ d) :
  Ico a b ∪ Ico c d = Ico (min a c) (max b d) :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico' hcb had]

lemma Ico_union_Ico {a b c d : α} (h₁ : min a b ≤ max c d) (h₂ : min c d ≤ max a b) :
  Ico a b ∪ Ico c d = Ico (min a c) (max b d) :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico h₁ h₂]

lemma Ico_inter_Ico {a b c d : α} : Ico a b ∩ Ico c d = Ico (max a c) (min b d) :=
by rw [←coe_inj, coe_inter, coe_Ico, coe_Ico, coe_Ico, ←inf_eq_min, ←sup_eq_max, set.Ico_inter_Ico]

@[simp] lemma Ico_filter_lt (a b c : α) : (Ico a b).filter (λ x, x < c) = Ico a (min b c) :=
begin
  cases le_total b c,
  { rw [Ico_filter_lt_of_right_le h, min_eq_left h] },
  { rw [Ico_filter_lt_of_le_right h, min_eq_right h] }
end

@[simp] lemma Ico_filter_le (a b c : α) : (Ico a b).filter (λ x, c ≤ x) = Ico (max a c) b :=
begin
  cases le_total a c,
  { rw [Ico_filter_le_of_left_le h, max_eq_right h] },
  { rw [Ico_filter_le_of_le_left h, max_eq_left h] }
end

@[simp] lemma Ico_diff_Ico_left (a b c : α) : (Ico a b) \ (Ico a c) = Ico (max a c) b :=
begin
  cases le_total a c,
  { ext x,
    rw [mem_sdiff, mem_Ico, mem_Ico, mem_Ico, max_eq_right h, and.right_comm, not_and, not_lt],
    exact and_congr_left' ⟨λ hx, hx.2 hx.1, λ hx, ⟨h.trans hx, λ _, hx⟩⟩ },
  { rw [Ico_eq_empty_of_le h, sdiff_empty, max_eq_left h] }
end

@[simp] lemma Ico_diff_Ico_right (a b c : α) : (Ico a b) \ (Ico c b) = Ico a (min b c) :=
begin
  cases le_total b c,
  { rw [Ico_eq_empty_of_le h, sdiff_empty, min_eq_left h] },
  { ext x,
    rw [mem_sdiff, mem_Ico, mem_Ico, mem_Ico, min_eq_right h, and_assoc, not_and', not_le],
    exact and_congr_right' ⟨λ hx, hx.2 hx.1, λ hx, ⟨hx.trans_le h, λ _, hx⟩⟩ }
end

end linear_order

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α] [decidable_eq α]
  [locally_finite_order α]

lemma image_add_left_Icc (a b c : α) : (Icc a b).image ((+) c) = Icc (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Icc],
  split,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Icc at hy,
    exact ⟨add_le_add_left hy.1 c, add_le_add_left hy.2 c⟩ },
  { intro hx,
    obtain ⟨y, hy⟩ := exists_add_of_le hx.1,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Icc.2 ⟨le_of_add_le_add_left hx.1, le_of_add_le_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ico (a b c : α) : (Ico a b).image ((+) c) = Ico (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ico],
  split,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ico at hy,
    exact ⟨add_le_add_left hy.1 c, add_lt_add_left hy.2 c⟩ },
  { intro hx,
    obtain ⟨y, hy⟩ := exists_add_of_le hx.1,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ico.2 ⟨le_of_add_le_add_left hx.1, lt_of_add_lt_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ioc (a b c : α) : (Ioc a b).image ((+) c) = Ioc (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ioc],
  refine ⟨_, λ hx, _⟩,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ioc at hy,
    exact ⟨add_lt_add_left hy.1 c, add_le_add_left hy.2 c⟩ },
  { obtain ⟨y, hy⟩ := exists_add_of_le hx.1.le,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ioc.2 ⟨lt_of_add_lt_add_left hx.1, le_of_add_le_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ioo (a b c : α) : (Ioo a b).image ((+) c) = Ioo (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ioo],
  refine ⟨_, λ hx, _⟩,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ioo at hy,
    exact ⟨add_lt_add_left hy.1 c, add_lt_add_left hy.2 c⟩ },
  { obtain ⟨y, hy⟩ := exists_add_of_le hx.1.le,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ioo.2 ⟨lt_of_add_lt_add_left hx.1, lt_of_add_lt_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_right_Icc (a b c : α) : (Icc a b).image (+ c) = Icc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Icc a b c }

lemma image_add_right_Ico (a b c : α) : (Ico a b).image (+ c) = Ico (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ico a b c }

lemma image_add_right_Ioc (a b c : α) : (Ioc a b).image (+ c) = Ioc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ioc a b c }

lemma image_add_right_Ioo (a b c : α) : (Ioo a b).image (+ c) = Ioo (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ioo a b c }

end ordered_cancel_add_comm_monoid
end finset


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Johan Commelin, Patrick Massot
-/

import algebra.order.with_zero
import algebra.punit_instances
import ring_theory.ideal.operations

/-!

# The basics of valuation theory.

The basic theory of valuations (non-archimedean norms) on a commutative ring,
following T. Wedhorn's unpublished notes “Adic Spaces” ([wedhorn_adic]).

The definition of a valuation we use here is Definition 1.22 of [wedhorn_adic].
A valuation on a ring `R` is a monoid homomorphism `v` to a linearly ordered
commutative monoid with zero, that in addition satisfies the following two axioms:
 * `v 0 = 0`
 * `∀ x y, v (x + y) ≤ max (v x) (v y)`

`valuation R Γ₀`is the type of valuations `R → Γ₀`, with a coercion to the underlying
function. If `v` is a valuation from `R` to `Γ₀` then the induced group
homomorphism `units(R) → Γ₀` is called `unit_map v`.

The equivalence "relation" `is_equiv v₁ v₂ : Prop` defined in 1.27 of [wedhorn_adic] is not strictly
speaking a relation, because `v₁ : valuation R Γ₁` and `v₂ : valuation R Γ₂` might
not have the same type. This corresponds in ZFC to the set-theoretic difficulty
that the class of all valuations (as `Γ₀` varies) on a ring `R` is not a set.
The "relation" is however reflexive, symmetric and transitive in the obvious
sense. Note that we use 1.27(iii) of [wedhorn_adic] as the definition of equivalence.

The support of a valuation `v : valuation R Γ₀` is `supp v`. If `J` is an ideal of `R`
with `h : J ⊆ supp v` then the induced valuation
on R / J = `ideal.quotient J` is `on_quot v h`.

## Main definitions

* `valuation R Γ₀`, the type of valuations on `R` with values in `Γ₀`
* `valuation.is_equiv`, the heterogeneous equivalence relation on valuations
* `valuation.supp`, the support of a valuation

* `add_valuation R Γ₀`, the type of additive valuations on `R` with values in a
  linearly ordered additive commutative group with a top element, `Γ₀`.

## Implementation Details
`add_valuation R Γ₀` is implemented as `valuation R (multiplicative (order_dual Γ₀))`.

-/

open_locale classical big_operators
noncomputable theory

open function ideal

variables {R : Type*} -- This will be a ring, assumed commutative in some sections

section
variables (R) (Γ₀ : Type*) [linear_ordered_comm_monoid_with_zero Γ₀] [ring R]

/-- The type of `Γ₀`-valued valuations on `R`. -/
@[nolint has_inhabited_instance]
structure valuation extends monoid_with_zero_hom R Γ₀ :=
(map_add' : ∀ x y, to_fun (x + y) ≤ max (to_fun x) (to_fun y))

/-- The `monoid_with_zero_hom` underlying a valuation. -/
add_decl_doc valuation.to_monoid_with_zero_hom

end

namespace valuation

variables {Γ₀   : Type*}
variables {Γ'₀  : Type*}
variables {Γ''₀ : Type*} [linear_ordered_comm_monoid_with_zero Γ''₀]

section basic

variables (R) (Γ₀) [ring R]

section monoid
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]

/-- A valuation is coerced to the underlying function `R → Γ₀`. -/
instance : has_coe_to_fun (valuation R Γ₀) (λ _, R → Γ₀) :=
{ coe := λ v, v.to_monoid_with_zero_hom.to_fun }

/-- A valuation is coerced to a monoid morphism R → Γ₀. -/
instance : has_coe (valuation R Γ₀) (monoid_with_zero_hom R Γ₀) :=
⟨valuation.to_monoid_with_zero_hom⟩

variables {R} {Γ₀} (v : valuation R Γ₀) {x y z : R}

@[simp, norm_cast] lemma coe_coe : ((v : monoid_with_zero_hom R Γ₀) : R → Γ₀) = v := rfl

@[simp] lemma map_zero : v 0 = 0 := v.map_zero'
@[simp] lemma map_one  : v 1 = 1 := v.map_one'
@[simp] lemma map_mul  : ∀ x y, v (x * y) = v x * v y := v.map_mul'
@[simp] lemma map_add  : ∀ x y, v (x + y) ≤ max (v x) (v y) := v.map_add'

lemma map_add_le {x y g} (hx : v x ≤ g) (hy : v y ≤ g) : v (x + y) ≤ g :=
le_trans (v.map_add x y) $ max_le hx hy

lemma map_add_lt {x y g} (hx : v x < g) (hy : v y < g) : v (x + y) < g :=
lt_of_le_of_lt (v.map_add x y) $ max_lt hx hy

lemma map_sum_le {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hf : ∀ i ∈ s, v (f i) ≤ g) :
  v (∑ i in s, f i) ≤ g :=
begin
  refine finset.induction_on s
    (λ _, trans_rel_right (≤) v.map_zero zero_le') (λ a s has ih hf, _) hf,
  rw finset.forall_mem_insert at hf, rw finset.sum_insert has,
  exact v.map_add_le hf.1 (ih hf.2)
end

lemma map_sum_lt {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g ≠ 0)
  (hf : ∀ i ∈ s, v (f i) < g) : v (∑ i in s, f i) < g :=
begin
  refine finset.induction_on s
    (λ _, trans_rel_right (<) v.map_zero (zero_lt_iff.2 hg)) (λ a s has ih hf, _) hf,
  rw finset.forall_mem_insert at hf, rw finset.sum_insert has,
  exact v.map_add_lt hf.1 (ih hf.2)
end

lemma map_sum_lt' {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : 0 < g)
  (hf : ∀ i ∈ s, v (f i) < g) : v (∑ i in s, f i) < g :=
v.map_sum_lt (ne_of_gt hg) hf

@[simp] lemma map_pow  : ∀ x (n:ℕ), v (x^n) = (v x)^n :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_pow

@[ext] lemma ext {v₁ v₂ : valuation R Γ₀} (h : ∀ r, v₁ r = v₂ r) : v₁ = v₂ :=
by { rcases v₁ with ⟨⟨⟩⟩, rcases v₂ with ⟨⟨⟩⟩, congr, funext r, exact h r }

lemma ext_iff {v₁ v₂ : valuation R Γ₀} : v₁ = v₂ ↔ ∀ r, v₁ r = v₂ r :=
⟨λ h r, congr_arg _ h, ext⟩

-- The following definition is not an instance, because we have more than one `v` on a given `R`.
-- In addition, type class inference would not be able to infer `v`.

/-- A valuation gives a preorder on the underlying ring. -/
def to_preorder : preorder R := preorder.lift v

/-- If `v` is a valuation on a division ring then `v(x) = 0` iff `x = 0`. -/
@[simp] lemma zero_iff [nontrivial Γ₀] {K : Type*} [division_ring K]
  (v : valuation K Γ₀) {x : K} : v x = 0 ↔ x = 0 :=
v.to_monoid_with_zero_hom.map_eq_zero

lemma ne_zero_iff [nontrivial Γ₀] {K : Type*} [division_ring K]
  (v : valuation K Γ₀) {x : K} : v x ≠ 0 ↔ x ≠ 0 :=
v.to_monoid_with_zero_hom.map_ne_zero

theorem unit_map_eq (u : units R) :
  (units.map (v : R →* Γ₀) u : Γ₀) = v u := rfl

/-- A ring homomorphism `S → R` induces a map `valuation R Γ₀ → valuation S Γ₀`. -/
def comap {S : Type*} [ring S] (f : S →+* R) (v : valuation R Γ₀) :
  valuation S Γ₀ :=
{ to_fun := v ∘ f,
  map_add' := λ x y, by simp only [comp_app, map_add, f.map_add],
  .. v.to_monoid_with_zero_hom.comp f.to_monoid_with_zero_hom, }

@[simp] lemma comap_id : v.comap (ring_hom.id R) = v := ext $ λ r, rfl

lemma comap_comp {S₁ : Type*} {S₂ : Type*} [ring S₁] [ring S₂] (f : S₁ →+* S₂) (g : S₂ →+* R) :
  v.comap (g.comp f) = (v.comap g).comap f :=
ext $ λ r, rfl

/-- A `≤`-preserving group homomorphism `Γ₀ → Γ'₀` induces a map `valuation R Γ₀ → valuation R Γ'₀`.
-/
def map (f : monoid_with_zero_hom Γ₀ Γ'₀) (hf : monotone f) (v : valuation R Γ₀) :
  valuation R Γ'₀ :=
{ to_fun := f ∘ v,
  map_add' := λ r s,
    calc f (v (r + s)) ≤ f (max (v r) (v s))     : hf (v.map_add r s)
                   ... = max (f (v r)) (f (v s)) : hf.map_max,
  .. monoid_with_zero_hom.comp f v.to_monoid_with_zero_hom }

/-- Two valuations on `R` are defined to be equivalent if they induce the same preorder on `R`. -/
def is_equiv (v₁ : valuation R Γ₀) (v₂ : valuation R Γ'₀) : Prop :=
∀ r s, v₁ r ≤ v₁ s ↔ v₂ r ≤ v₂ s

end monoid

section group
variables [linear_ordered_comm_group_with_zero Γ₀] {R} {Γ₀} (v : valuation R Γ₀) {x y z : R}

@[simp] lemma map_inv {K : Type*} [division_ring K]
  (v : valuation K Γ₀) {x : K} : v x⁻¹ = (v x)⁻¹ :=
v.to_monoid_with_zero_hom.map_inv x

@[simp] lemma map_zpow {K : Type*} [division_ring K] (v : valuation K Γ₀) {x : K} {n : ℤ} :
  v (x^n) = (v x)^n :=
v.to_monoid_with_zero_hom.map_zpow x n

lemma map_units_inv (x : units R) : v (x⁻¹ : units R) = (v x)⁻¹ :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_units_inv x

@[simp] lemma map_neg (x : R) : v (-x) = v x :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_neg x

lemma map_sub_swap (x y : R) : v (x - y) = v (y - x) :=
v.to_monoid_with_zero_hom.to_monoid_hom.map_sub_swap x y

lemma map_sub (x y : R) : v (x - y) ≤ max (v x) (v y) :=
calc v (x - y) = v (x + -y)         : by rw [sub_eq_add_neg]
           ... ≤ max (v x) (v $ -y) : v.map_add _ _
           ... = max (v x) (v y)    : by rw map_neg

lemma map_sub_le {x y g} (hx : v x ≤ g) (hy : v y ≤ g) : v (x - y) ≤ g :=
begin
  rw sub_eq_add_neg,
  exact v.map_add_le hx (le_trans (le_of_eq (v.map_neg y)) hy)
end

lemma map_add_of_distinct_val (h : v x ≠ v y) : v (x + y) = max (v x) (v y) :=
begin
  suffices : ¬v (x + y) < max (v x) (v y),
    from or_iff_not_imp_right.1 (le_iff_eq_or_lt.1 (v.map_add x y)) this,
  intro h',
  wlog vyx : v y < v x using x y,
  { apply lt_or_gt_of_ne h.symm },
  { rw max_eq_left_of_lt vyx at h',
    apply lt_irrefl (v x),
    calc v x = v ((x+y) - y)         : by simp
         ... ≤ max (v $ x + y) (v y) : map_sub _ _ _
         ... < v x                   : max_lt h' vyx },
  { apply this h.symm,
    rwa [add_comm, max_comm] at h' }
end

lemma map_eq_of_sub_lt (h : v (y - x) < v x) : v y = v x :=
begin
  have := valuation.map_add_of_distinct_val v (ne_of_gt h).symm,
  rw max_eq_right (le_of_lt h) at this,
  simpa using this
end

/-- The subgroup of elements whose valuation is less than a certain unit.-/
def lt_add_subgroup (v : valuation R Γ₀) (γ : units Γ₀) : add_subgroup R :=
{ carrier   := {x | v x < γ},
  zero_mem' := by { have h := units.ne_zero γ, contrapose! h, simpa using h },
  add_mem'  := λ x y x_in y_in, lt_of_le_of_lt (v.map_add x y) (max_lt x_in y_in),
  neg_mem'  := λ x x_in, by rwa [set.mem_set_of_eq, map_neg] }

end group
end basic -- end of section

namespace is_equiv
variables [ring R]
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]
variables {v : valuation R Γ₀}
variables {v₁ : valuation R Γ₀} {v₂ : valuation R Γ'₀} {v₃ : valuation R Γ''₀}

@[refl] lemma refl : v.is_equiv v :=
λ _ _, iff.refl _

@[symm] lemma symm (h : v₁.is_equiv v₂) : v₂.is_equiv v₁ :=
λ _ _, iff.symm (h _ _)

@[trans] lemma trans (h₁₂ : v₁.is_equiv v₂) (h₂₃ : v₂.is_equiv v₃) : v₁.is_equiv v₃ :=
λ _ _, iff.trans (h₁₂ _ _) (h₂₃ _ _)

lemma of_eq {v' : valuation R Γ₀} (h : v = v') : v.is_equiv v' :=
by { subst h }

lemma map {v' : valuation R Γ₀} (f : monoid_with_zero_hom Γ₀ Γ'₀) (hf : monotone f)
  (inf : injective f) (h : v.is_equiv v') :
  (v.map f hf).is_equiv (v'.map f hf) :=
let H : strict_mono f := hf.strict_mono_of_injective inf in
λ r s,
calc f (v r) ≤ f (v s) ↔ v r ≤ v s   : by rw H.le_iff_le
                   ... ↔ v' r ≤ v' s : h r s
                   ... ↔ f (v' r) ≤ f (v' s) : by rw H.le_iff_le

/-- `comap` preserves equivalence. -/
lemma comap {S : Type*} [ring S] (f : S →+* R) (h : v₁.is_equiv v₂) :
  (v₁.comap f).is_equiv (v₂.comap f) :=
λ r s, h (f r) (f s)

lemma val_eq (h : v₁.is_equiv v₂) {r s : R} :
  v₁ r = v₁ s ↔ v₂ r = v₂ s :=
by simpa only [le_antisymm_iff] using and_congr (h r s) (h s r)

lemma ne_zero (h : v₁.is_equiv v₂) {r : R} :
  v₁ r ≠ 0 ↔ v₂ r ≠ 0 :=
begin
  have : v₁ r ≠ v₁ 0 ↔ v₂ r ≠ v₂ 0 := not_iff_not_of_iff h.val_eq,
  rwa [v₁.map_zero, v₂.map_zero] at this,
end

end is_equiv -- end of namespace

section

lemma is_equiv_of_map_strict_mono [linear_ordered_comm_monoid_with_zero Γ₀]
  [linear_ordered_comm_monoid_with_zero Γ'₀]
  [ring R] {v : valuation R Γ₀}
  (f : monoid_with_zero_hom Γ₀ Γ'₀) (H : strict_mono f) :
  is_equiv (v.map f (H.monotone)) v :=
λ x y, ⟨H.le_iff_le.mp, λ h, H.monotone h⟩

lemma is_equiv_of_val_le_one [linear_ordered_comm_group_with_zero Γ₀]
  [linear_ordered_comm_group_with_zero Γ'₀]
  {K : Type*} [division_ring K]
  (v : valuation K Γ₀) (v' : valuation K Γ'₀) (h : ∀ {x:K}, v x ≤ 1 ↔ v' x ≤ 1) :
  v.is_equiv v' :=
begin
  intros x y,
  by_cases hy : y = 0, { simp [hy, zero_iff], },
  rw show y = 1 * y, by rw one_mul,
  rw [← (inv_mul_cancel_right₀ hy x)],
  iterate 2 {rw [v.map_mul _ y, v'.map_mul _ y]},
  rw [v.map_one, v'.map_one],
  split; intro H,
  { apply mul_le_mul_right',
    replace hy := v.ne_zero_iff.mpr hy,
    replace H := le_of_le_mul_right hy H,
    rwa h at H, },
  { apply mul_le_mul_right',
    replace hy := v'.ne_zero_iff.mpr hy,
    replace H := le_of_le_mul_right hy H,
    rwa h, },
end

end

section supp
variables [comm_ring R]
variables [linear_ordered_comm_monoid_with_zero Γ₀] [linear_ordered_comm_monoid_with_zero Γ'₀]
variables (v : valuation R Γ₀)

/-- The support of a valuation `v : R → Γ₀` is the ideal of `R` where `v` vanishes. -/
def supp : ideal R :=
{ carrier   := {x | v x = 0},
  zero_mem' := map_zero v,
  add_mem'  := λ x y hx hy, le_zero_iff.mp $
    calc v (x + y) ≤ max (v x) (v y) : v.map_add x y
               ... ≤ 0               : max_le (le_zero_iff.mpr hx) (le_zero_iff.mpr hy),
  smul_mem' := λ c x hx, calc v (c * x)
                        = v c * v x : map_mul v c x
                    ... = v c * 0 : congr_arg _ hx
                    ... = 0 : mul_zero _ }

@[simp] lemma mem_supp_iff (x : R) : x ∈ supp v ↔ v x = 0 := iff.rfl
-- @[simp] lemma mem_supp_iff' (x : R) : x ∈ (supp v : set R) ↔ v x = 0 := iff.rfl

/-- The support of a valuation is a prime ideal. -/
instance [nontrivial Γ₀] [no_zero_divisors Γ₀] : ideal.is_prime (supp v) :=
⟨λ (h : v.supp = ⊤), one_ne_zero $ show (1 : Γ₀) = 0,
from calc 1 = v 1 : v.map_one.symm
        ... = 0   : show (1:R) ∈ supp v, by { rw h, trivial },
 λ x y hxy, begin
    show v x = 0 ∨ v y = 0,
    change v (x * y) = 0 at hxy,
    rw [v.map_mul x y] at hxy,
    exact eq_zero_or_eq_zero_of_mul_eq_zero hxy
  end⟩

lemma map_add_supp (a : R) {s : R} (h : s ∈ supp v) : v (a + s) = v a :=
begin
  have aux : ∀ a s, v s = 0 → v (a + s) ≤ v a,
  { intros a' s' h', refine le_trans (v.map_add a' s') (max_le (le_refl _) _), simp [h'], },
  apply le_antisymm (aux a s h),
  calc v a = v (a + s + -s) : by simp
       ... ≤ v (a + s)      : aux (a + s) (-s) (by rwa ←ideal.neg_mem_iff at h)
end

/-- If `hJ : J ⊆ supp v` then `on_quot_val hJ` is the induced function on R/J as a function.
Note: it's just the function; the valuation is `on_quot hJ`. -/
def on_quot_val {J : ideal R} (hJ : J ≤ supp v) :
  R ⧸ J → Γ₀ :=
λ q, quotient.lift_on' q v $ λ a b h,
calc v a = v (b + (a - b)) : by simp
     ... = v b             : v.map_add_supp b (hJ h)

/-- The extension of valuation v on R to valuation on R/J if J ⊆ supp v -/
def on_quot {J : ideal R} (hJ : J ≤ supp v) :
  valuation (R ⧸ J) Γ₀ :=
{ to_fun := v.on_quot_val hJ,
  map_zero' := v.map_zero,
  map_one'  := v.map_one,
  map_mul'  := λ xbar ybar, quotient.ind₂' v.map_mul xbar ybar,
  map_add'  := λ xbar ybar, quotient.ind₂' v.map_add xbar ybar }

@[simp] lemma on_quot_comap_eq {J : ideal R} (hJ : J ≤ supp v) :
  (v.on_quot hJ).comap (ideal.quotient.mk J) = v :=
ext $ λ r,
begin
  refine @quotient.lift_on_mk _ _ (J.quotient_rel) v (λ a b h, _) _,
  calc v a = v (b + (a - b)) : by simp
       ... = v b             : v.map_add_supp b (hJ h)
end

lemma comap_supp {S : Type*} [comm_ring S] (f : S →+* R) :
  supp (v.comap f) = ideal.comap f v.supp :=
ideal.ext $ λ x,
begin
  rw [mem_supp_iff, ideal.mem_comap, mem_supp_iff],
  refl,
end

lemma self_le_supp_comap (J : ideal R) (v : valuation (R ⧸ J) Γ₀) :
  J ≤ (v.comap (ideal.quotient.mk J)).supp :=
by { rw [comap_supp, ← ideal.map_le_iff_le_comap], simp }

@[simp] lemma comap_on_quot_eq (J : ideal R) (v : valuation (R ⧸ J) Γ₀) :
  (v.comap (ideal.quotient.mk J)).on_quot (v.self_le_supp_comap J) = v :=
ext $ by { rintro ⟨x⟩, refl }

/-- The quotient valuation on R/J has support supp(v)/J if J ⊆ supp v. -/
lemma supp_quot {J : ideal R} (hJ : J ≤ supp v) :
  supp (v.on_quot hJ) = (supp v).map (ideal.quotient.mk J) :=
begin
  apply le_antisymm,
  { rintro ⟨x⟩ hx,
    apply ideal.subset_span,
    exact ⟨x, hx, rfl⟩ },
  { rw ideal.map_le_iff_le_comap,
    intros x hx, exact hx }
end

lemma supp_quot_supp : supp (v.on_quot (le_refl _)) = 0 :=
by { rw supp_quot, exact ideal.map_quotient_self _ }

end supp -- end of section

end valuation

section add_monoid

variables (R) [ring R] (Γ₀ : Type*) [linear_ordered_add_comm_monoid_with_top Γ₀]

/-- The type of `Γ₀`-valued additive valuations on `R`. -/
@[nolint has_inhabited_instance]
def add_valuation := valuation R (multiplicative (order_dual Γ₀))

end add_monoid

namespace add_valuation
variables {Γ₀ : Type*} {Γ'₀ : Type*}

section basic

section monoid

variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables (R) (Γ₀) [ring R]

/-- A valuation is coerced to the underlying function `R → Γ₀`. -/
instance : has_coe_to_fun (add_valuation R Γ₀) (λ _, R → Γ₀) :=
{ coe := λ v, v.to_monoid_with_zero_hom.to_fun }

variables {R} {Γ₀} (v : add_valuation R Γ₀) {x y z : R}

section

variables (f : R → Γ₀) (h0 : f 0 = ⊤) (h1 : f 1 = 0)
variables (hadd : ∀ x y, min (f x) (f y) ≤ f (x + y)) (hmul : ∀ x y, f (x * y) = f x + f y)

/-- An alternate constructor of `add_valuation`, that doesn't reference
  `multiplicative (order_dual Γ₀)` -/
def of : add_valuation R Γ₀ :=
{ to_fun := f,
  map_one' := h1,
  map_zero' := h0,
  map_add' := hadd,
  map_mul' := hmul }

variables {h0} {h1} {hadd} {hmul} {r : R}

@[simp]
theorem of_apply : (of f h0 h1 hadd hmul) r = f r := rfl

end

@[simp] lemma map_zero : v 0 = ⊤ := v.map_zero
@[simp] lemma map_one  : v 1 = 0 := v.map_one
@[simp] lemma map_mul  : ∀ x y, v (x * y) = v x + v y := v.map_mul
@[simp] lemma map_add  : ∀ x y, min (v x) (v y) ≤ v (x + y) := v.map_add

lemma map_le_add {x y g} (hx : g ≤ v x) (hy : g ≤ v y) : g ≤ v (x + y) := v.map_add_le hx hy

lemma map_lt_add {x y g} (hx : g < v x) (hy : g < v y) : g < v (x + y) := v.map_add_lt hx hy

lemma map_le_sum {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hf : ∀ i ∈ s, g ≤ v (f i)) :
  g ≤ v (∑ i in s, f i) := v.map_sum_le hf

lemma map_lt_sum {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g ≠ ⊤)
  (hf : ∀ i ∈ s, g < v (f i)) : g < v (∑ i in s, f i) := v.map_sum_lt hg hf

lemma map_lt_sum' {ι : Type*} {s : finset ι} {f : ι → R} {g : Γ₀} (hg : g < ⊤)
  (hf : ∀ i ∈ s, g < v (f i)) : g < v (∑ i in s, f i) := v.map_sum_lt' hg hf

@[simp] lemma map_pow  : ∀ x (n:ℕ), v (x^n) = n • (v x) := v.map_pow

@[ext] lemma ext {v₁ v₂ : add_valuation R Γ₀} (h : ∀ r, v₁ r = v₂ r) : v₁ = v₂ :=
valuation.ext h

lemma ext_iff {v₁ v₂ : add_valuation R Γ₀} : v₁ = v₂ ↔ ∀ r, v₁ r = v₂ r :=
valuation.ext_iff

-- The following definition is not an instance, because we have more than one `v` on a given `R`.
-- In addition, type class inference would not be able to infer `v`.

/-- A valuation gives a preorder on the underlying ring. -/
def to_preorder : preorder R := preorder.lift v

/-- If `v` is an additive valuation on a division ring then `v(x) = ⊤` iff `x = 0`. -/
@[simp] lemma top_iff [nontrivial Γ₀] {K : Type*} [division_ring K]
  (v : add_valuation K Γ₀) {x : K} : v x = ⊤ ↔ x = 0 :=
v.zero_iff

lemma ne_top_iff [nontrivial Γ₀] {K : Type*} [division_ring K]
  (v : add_valuation K Γ₀) {x : K} : v x ≠ ⊤ ↔ x ≠ 0 := v.ne_zero_iff

/-- A ring homomorphism `S → R` induces a map `add_valuation R Γ₀ → add_valuation S Γ₀`. -/
def comap {S : Type*} [ring S] (f : S →+* R) (v : add_valuation R Γ₀) :
  add_valuation S Γ₀ :=
v.comap f

@[simp] lemma comap_id : v.comap (ring_hom.id R) = v := v.comap_id

lemma comap_comp {S₁ : Type*} {S₂ : Type*} [ring S₁] [ring S₂] (f : S₁ →+* S₂) (g : S₂ →+* R) :
  v.comap (g.comp f) = (v.comap g).comap f :=
v.comap_comp f g

/-- A `≤`-preserving, `⊤`-preserving group homomorphism `Γ₀ → Γ'₀` induces a map
  `add_valuation R Γ₀ → add_valuation R Γ'₀`.
-/
def map (f : Γ₀ →+ Γ'₀) (ht : f ⊤ = ⊤) (hf : monotone f) (v : add_valuation R Γ₀) :
  add_valuation R Γ'₀ :=
v.map
{ to_fun := f,
  map_mul' := f.map_add,
  map_one' := f.map_zero,
  map_zero' := ht } (λ x y h, hf h)

/-- Two additive valuations on `R` are defined to be equivalent if they induce the same
  preorder on `R`. -/
def is_equiv (v₁ : add_valuation R Γ₀) (v₂ : add_valuation R Γ'₀) : Prop :=
v₁.is_equiv v₂

end monoid

section group
variables [linear_ordered_add_comm_group_with_top Γ₀] [ring R] (v : add_valuation R Γ₀) {x y z : R}

@[simp] lemma map_inv {K : Type*} [division_ring K]
  (v : add_valuation K Γ₀) {x : K} : v x⁻¹ = - (v x) :=
v.map_inv

lemma map_units_inv (x : units R) : v (x⁻¹ : units R) = - (v x) :=
v.map_units_inv x

@[simp] lemma map_neg (x : R) : v (-x) = v x :=
v.map_neg x

lemma map_sub_swap (x y : R) : v (x - y) = v (y - x) :=
v.map_sub_swap x y

lemma map_sub (x y : R) : min (v x) (v y) ≤ v (x - y) :=
v.map_sub x y

lemma map_le_sub {x y g} (hx : g ≤ v x) (hy : g ≤ v y) : g ≤ v (x - y) := v.map_sub_le hx hy

lemma map_add_of_distinct_val (h : v x ≠ v y) : v (x + y) = min (v x) (v y) :=
v.map_add_of_distinct_val h

lemma map_eq_of_lt_sub (h : v x < v (y - x)) : v y = v x :=
v.map_eq_of_sub_lt h

end group

end basic

namespace is_equiv
variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables [ring R]
variables {Γ''₀ : Type*} [linear_ordered_add_comm_monoid_with_top Γ''₀]
variables {v : add_valuation R Γ₀}
variables {v₁ : add_valuation R Γ₀} {v₂ : add_valuation R Γ'₀} {v₃ : add_valuation R Γ''₀}

@[refl] lemma refl : v.is_equiv v := valuation.is_equiv.refl

@[symm] lemma symm (h : v₁.is_equiv v₂) : v₂.is_equiv v₁ := h.symm

@[trans] lemma trans (h₁₂ : v₁.is_equiv v₂) (h₂₃ : v₂.is_equiv v₃) : v₁.is_equiv v₃ :=
h₁₂.trans h₂₃

lemma of_eq {v' : add_valuation R Γ₀} (h : v = v') : v.is_equiv v' :=
valuation.is_equiv.of_eq h

lemma map {v' : add_valuation R Γ₀} (f : Γ₀ →+ Γ'₀) (ht : f ⊤ = ⊤) (hf : monotone f)
  (inf : injective f) (h : v.is_equiv v') :
  (v.map f ht hf).is_equiv (v'.map f ht hf) :=
h.map
{ to_fun := f,
  map_mul' := f.map_add,
  map_one' := f.map_zero,
  map_zero' := ht } (λ x y h, hf h) inf

/-- `comap` preserves equivalence. -/
lemma comap {S : Type*} [ring S] (f : S →+* R) (h : v₁.is_equiv v₂) :
  (v₁.comap f).is_equiv (v₂.comap f) :=
h.comap f

lemma val_eq (h : v₁.is_equiv v₂) {r s : R} :
  v₁ r = v₁ s ↔ v₂ r = v₂ s :=
h.val_eq

end is_equiv

section supp
variables [linear_ordered_add_comm_monoid_with_top Γ₀] [linear_ordered_add_comm_monoid_with_top Γ'₀]
variables [comm_ring R]
variables (v : add_valuation R Γ₀)

/-- The support of an additive valuation `v : R → Γ₀` is the ideal of `R` where `v x = ⊤` -/
def supp : ideal R := v.supp

@[simp] lemma mem_supp_iff (x : R) : x ∈ supp v ↔ v x = ⊤ := v.mem_supp_iff x

lemma map_add_supp (a : R) {s : R} (h : s ∈ supp v) : v (a + s) = v a :=
v.map_add_supp a h

/-- If `hJ : J ⊆ supp v` then `on_quot_val hJ` is the induced function on R/J as a function.
Note: it's just the function; the valuation is `on_quot hJ`. -/
def on_quot_val {J : ideal R} (hJ : J ≤ supp v) : (R ⧸ J) → Γ₀ := v.on_quot_val hJ

/-- The extension of valuation v on R to valuation on R/J if J ⊆ supp v -/
def on_quot {J : ideal R} (hJ : J ≤ supp v) :
  add_valuation (R ⧸ J) Γ₀ :=
v.on_quot hJ

@[simp] lemma on_quot_comap_eq {J : ideal R} (hJ : J ≤ supp v) :
  (v.on_quot hJ).comap (ideal.quotient.mk J) = v :=
v.on_quot_comap_eq hJ

lemma comap_supp {S : Type*} [comm_ring S] (f : S →+* R) :
  supp (v.comap f) = ideal.comap f v.supp :=
v.comap_supp f

lemma self_le_supp_comap (J : ideal R) (v : add_valuation (R ⧸ J) Γ₀) :
  J ≤ (v.comap (ideal.quotient.mk J)).supp :=
v.self_le_supp_comap J

@[simp] lemma comap_on_quot_eq (J : ideal R) (v : add_valuation (R ⧸ J) Γ₀) :
  (v.comap (ideal.quotient.mk J)).on_quot (v.self_le_supp_comap J) = v :=
v.comap_on_quot_eq J

/-- The quotient valuation on R/J has support supp(v)/J if J ⊆ supp v. -/
lemma supp_quot {J : ideal R} (hJ : J ≤ supp v) :
  supp (v.on_quot hJ) = (supp v).map (ideal.quotient.mk J) :=
v.supp_quot hJ

lemma supp_quot_supp : supp (v.on_quot (le_refl _)) = 0 :=
v.supp_quot_supp

end supp -- end of section

attribute [irreducible] add_valuation

end add_valuation


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

import set_theory.ordinal.arithmetic
import set_theory.ordinal.exponential

/-!
# Cantor Normal Form

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

The Cantor normal form of an ordinal is generally defined as its base `ω` expansion, with its
non-zero exponents in decreasing order. Here, we more generally define a base `b` expansion
`ordinal.CNF` in this manner, which is well-behaved for any `b ≥ 2`.

# Implementation notes

We implement `ordinal.CNF` as an association list, where keys are exponents and values are
coefficients. This is because this structure intrinsically reflects two key properties of the Cantor
normal form:

- It is ordered.
- It has finitely many entries.

# Todo

- Add API for the coefficients of the Cantor normal form.
- Prove the basic results relating the CNF to the arithmetic operations on ordinals.
-/

noncomputable theory

universe u

open order

namespace ordinal

/-- Inducts on the base `b` expansion of an ordinal. -/
@[elab_as_eliminator] noncomputable def CNF_rec (b : ordinal)
  {C : ordinal → Sort*} (H0 : C 0) (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : ∀ o, C o
| o :=
  if ho : o = 0 then by rwa ho else
    let hwf := mod_opow_log_lt_self b ho in H o ho (CNF_rec (o % b ^ log b o))
using_well_founded {dec_tac := `[assumption]}

@[simp] theorem CNF_rec_zero {C : ordinal → Sort*} (b : ordinal)
  (H0 : C 0) (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : @CNF_rec b C H0 H 0 = H0 :=
by { rw [CNF_rec, dif_pos rfl], refl }

theorem CNF_rec_pos (b : ordinal) {o : ordinal} {C : ordinal → Sort*} (ho : o ≠ 0)
  (H0 : C 0) (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) :
  @CNF_rec b C H0 H o = H o ho (@CNF_rec b C H0 H _) :=
by rw [CNF_rec, dif_neg ho]

/-- The Cantor normal form of an ordinal `o` is the list of coefficients and exponents in the
base-`b` expansion of `o`.

We special-case `CNF 0 o = CNF 1 o = [(0, o)]` for `o ≠ 0`.

`CNF b (b ^ u₁ * v₁ + b ^ u₂ * v₂) = [(u₁, v₁), (u₂, v₂)]` -/
@[pp_nodot] def CNF (b o : ordinal) : list (ordinal × ordinal) :=
CNF_rec b [] (λ o ho IH, (log b o, o / b ^ log b o) :: IH) o

@[simp] theorem CNF_zero (b : ordinal) : CNF b 0 = [] := CNF_rec_zero b _ _

/-- Recursive definition for the Cantor normal form. -/
theorem CNF_ne_zero {b o : ordinal} (ho : o ≠ 0) :
  CNF b o = (log b o, o / b ^ log b o) :: CNF b (o % b ^ log b o) :=
CNF_rec_pos b ho _ _

theorem zero_CNF {o : ordinal} (ho : o ≠ 0) : CNF 0 o = [⟨0, o⟩] := by simp [CNF_ne_zero ho]

theorem one_CNF {o : ordinal} (ho : o ≠ 0) : CNF 1 o = [⟨0, o⟩] := by simp [CNF_ne_zero ho]

theorem CNF_of_le_one {b o : ordinal} (hb : b ≤ 1) (ho : o ≠ 0) : CNF b o = [⟨0, o⟩] :=
begin
  rcases le_one_iff.1 hb with rfl | rfl,
  { exact zero_CNF ho },
  { exact one_CNF ho }
end

/-- Evaluating the Cantor normal form of an ordinal returns the ordinal. -/
theorem CNF_foldr (b o : ordinal) : (CNF b o).foldr (λ p r, b ^ p.1 * p.2 + r) 0 = o :=
CNF_rec b (by { rw CNF_zero, refl })
  (λ o ho IH, by rw [CNF_ne_zero ho, list.foldr_cons, IH, div_add_mod]) o

/-- Every exponent in the Cantor normal form `CNF b o` is less or equal to `log b o`. -/
theorem CNF_fst_le_log {b o : ordinal.{u}} {x : ordinal × ordinal} :
  x ∈ CNF b o → x.1 ≤ log b o :=
begin
  refine CNF_rec b _ (λ o ho H, _) o,
  { rw CNF_zero,
    exact false.elim },
  { rw [CNF_ne_zero ho, list.mem_cons_iff],
    rintro (rfl | h),
    { exact le_rfl },
    { exact (H h).trans (log_mono_right _ (mod_opow_log_lt_self b ho).le) } }
end

/-- Every exponent in the Cantor normal form `CNF b o` is less or equal to `o`. -/
theorem CNF_fst_le {b o : ordinal.{u}} {x : ordinal × ordinal} (h : x ∈ CNF b o) : x.1 ≤ o :=
(CNF_fst_le_log h).trans $ log_le_self _ _

/-- Every coefficient in a Cantor normal form is positive. -/
theorem CNF_lt_snd {b o : ordinal.{u}} {x : ordinal × ordinal} : x ∈ CNF b o → 0 < x.2 :=
begin
  refine CNF_rec b _ (λ o ho IH, _) o,
  { simp },
  { rcases eq_zero_or_pos b with rfl | hb,
    { rw [zero_CNF ho, list.mem_singleton],
      rintro rfl,
      exact ordinal.pos_iff_ne_zero.2 ho },
    { rw CNF_ne_zero ho,
      rintro (rfl | h),
      { simp,
        rw div_pos,
        { exact opow_log_le_self _ ho },
        { exact (opow_pos _ hb).ne' } },
      { exact IH h } } }
end

/-- Every coefficient in the Cantor normal form `CNF b o` is less than `b`. -/
theorem CNF_snd_lt {b o : ordinal.{u}} (hb : 1 < b) {x : ordinal × ordinal} :
  x ∈ CNF b o → x.2 < b :=
begin
  refine CNF_rec b _ (λ o ho IH, _) o,
  { simp },
  { rw CNF_ne_zero ho,
    rintro (rfl | h),
    { simpa using div_opow_log_lt o hb },
    { exact IH h } }
end

/-- The exponents of the Cantor normal form are decreasing. -/
theorem CNF_sorted (b o : ordinal) : ((CNF b o).map prod.fst).sorted (>) :=
begin
  refine CNF_rec b _ (λ o ho IH, _) o,
  { simp },
  { cases le_or_lt b 1 with hb hb,
    { simp [CNF_of_le_one hb ho] },
    { cases lt_or_le o b with hob hbo,
      { simp [CNF_of_lt ho hob] },
      { rw [CNF_ne_zero ho, list.map_cons, list.sorted_cons],
        refine ⟨λ a H, _, IH⟩,
        rw list.mem_map at H,
        rcases H with ⟨⟨a, a'⟩, H, rfl⟩,
        exact (CNF_fst_le_log H).trans_lt (log_mod_opow_log_lt_log_self hb ho hbo) } } }
end

end ordinal


import set_theory.ordinal
import impartial
import data.set

universes u v

open pgame

local infix ` ≈ ` := pgame.equiv

/-- The defineition of nim, nim O is the game where each player can move to nim O' where O' < O
    If O is finite then this game can be veiwed as a pile of stones where each player can take a
	positie number of stones from it on their turn -/
noncomputable def nim : ordinal → pgame
| O₁ := ⟨ O₁.out.α, O₁.out.α,
					λ O₂, have hwf : (ordinal.typein O₁.out.r O₂) < O₁, from begin nth_rewrite_rhs 0 ←ordinal.type_out O₁, exact ordinal.typein_lt_type _ _ end, nim (ordinal.typein O₁.out.r O₂),
					λ O₂, have hwf : (ordinal.typein O₁.out.r O₂) < O₁, from begin nth_rewrite_rhs 0 ←ordinal.type_out O₁, exact ordinal.typein_lt_type _ _ end, nim (ordinal.typein O₁.out.r O₂)⟩
using_well_founded {dec_tac := tactic.assumption}

namespace nim

@[simp] lemma nim_def (O : ordinal) : nim O = pgame.mk
					O.out.α O.out.α
					(λ O₂, nim (ordinal.typein O.out.r O₂))
					(λ O₂, nim (ordinal.typein O.out.r O₂)) :=
by rw nim

lemma nim_wf_lemma {O₁ : ordinal} (O₂ : O₁.out.α) : (ordinal.typein O₁.out.r O₂) < O₁ :=
begin
	nth_rewrite_rhs 0 ← ordinal.type_out O₁, exact ordinal.typein_lt_type _ _
end

@[instance] lemma nim_impartial : ∀ (O : ordinal), impartial (nim O)
| O :=
begin
	rw [impartial_def, nim_def, neg_def],
	split,
	split,
	{ rw pgame.le_def,
	  split,
		{ intro i,
			let hwf : (ordinal.typein O.out.r i) < O := nim_wf_lemma i,
			exact or.inl ⟨ i, (@impartial_neg_equiv_self (nim (ordinal.typein O.out.r i)) (nim_impartial (ordinal.typein O.out.r i))).1 ⟩ },
		{ intro j,
			let hwf : (ordinal.typein O.out.r j) < O := nim_wf_lemma j,
			exact or.inr ⟨ j, (@impartial_neg_equiv_self (nim (ordinal.typein O.out.r j)) (nim_impartial (ordinal.typein O.out.r j))).1 ⟩ } },
	{ rw pgame.le_def,
		split,
		{ intro i,
			let hwf : (ordinal.typein O.out.r i) < O := nim_wf_lemma i,
			exact or.inl ⟨ i, (@impartial_neg_equiv_self (nim (ordinal.typein O.out.r i)) (nim_impartial (ordinal.typein O.out.r i))).2 ⟩ },
		{ intro j,
			let hwf : (ordinal.typein O.out.r j) < O := nim_wf_lemma j,
			exact or.inr  ⟨ j, (@impartial_neg_equiv_self (nim (ordinal.typein O.out.r j)) (nim_impartial (ordinal.typein O.out.r j))).2 ⟩ } },
	split,
	{ intro i,
		let hwf : (ordinal.typein O.out.r i) < O := nim_wf_lemma i,
		rw move_left_mk,
		exact nim_impartial (ordinal.typein O.out.r i) },
	{ intro j,
		let hwf : (ordinal.typein O.out.r j) < O := nim_wf_lemma j,
		rw move_right_mk,
		exact nim_impartial (ordinal.typein O.out.r j) }
end
using_well_founded {dec_tac := tactic.assumption}

lemma nim_zero_p_position : (nim (0:ordinal)).p_position :=
begin
	rw nim_def,
	split;
	rw le_def_lt;
	split;
	intro i;
	try {rw left_moves_mk at i};
	try {rw right_moves_mk at i};
	try {	have h := ordinal.typein_lt_type (quotient.out (0:ordinal)).r i,
				rw ordinal.type_out at h,
				have hcontra := ordinal.zero_le (ordinal.typein (quotient.out (0:ordinal)).r i),
				have h := not_le_of_lt h,
				contradiction };
	try { exact pempty.elim i }
end

lemma nim_non_zero_n_position (O : ordinal) (hO : O ≠ 0) : (nim O).n_position :=
begin
	rw nim_def,
	rw ←ordinal.pos_iff_ne_zero at hO,
	split;
	rw lt_def_le,
	{ left,
		use (ordinal.principal_seg_out hO).top,
		rw [move_left_mk, ordinal.typein_top, ordinal.type_out],
		exact nim_zero_p_position.2 },
	{ right,
		use (ordinal.principal_seg_out hO).top,
		rw [move_right_mk, ordinal.typein_top, ordinal.type_out],
		exact nim_zero_p_position.1 }
end

lemma nim_sum_p_position_iff_eq (O₁ O₂ : ordinal) : (nim O₁ + nim O₂).p_position ↔ O₁ = O₂ :=
begin
	split,
	{ contrapose,
		intros hneq hp,
		wlog h : O₁ ≤ O₂ using [O₁ O₂, O₂ O₁],
		exact ordinal.le_total O₁ O₂,
		{ have h : O₁ < O₂ := lt_of_le_of_ne h hneq,
			rw ←no_good_left_moves_iff_p_position at hp,
			equiv_rw left_moves_add (nim O₁) (nim O₂) at hp,
			rw nim_def O₂ at hp,
			specialize hp (sum.inr (ordinal.principal_seg_out h).top),
			rw [id, add_move_left_inr, move_left_mk, ordinal.typein_top, ordinal.type_out] at hp,
			cases hp,
			have hcontra := (impartial_add_self (nim O₁)).1,
			rw ←pgame.not_lt at hcontra,
			contradiction },
		exact this (λ h, hneq h.symm) (p_position_of_equiv add_comm_equiv hp) },
	{ intro h,
		rw h,
		exact impartial_add_self (nim O₂) }
end

lemma nim_sum_n_position_iff_neq (O₁ O₂ : ordinal) : (nim O₁ + nim O₂).n_position ↔ O₁ ≠ O₂ :=
begin
	split,
	{ intros hn heq,
		cases hn,
		rw ←nim_sum_p_position_iff_eq at heq,
		cases heq with h,
		rw ←pgame.not_lt at h,
		contradiction },
	{ contrapose,
		intro hnp,
		rw [not_not, ←nim_sum_p_position_iff_eq],
		cases impartial_position_cases (nim O₁ + nim O₂),
		assumption,
		contradiction }
end

/-- This definition will be used in the proof of the Sprague-Grundy theorem. It takes a function
	from some type to ordinals and returns a nonempty set of ordinals with empty intersection with
	the image of the function. It is guarantied that the smallest ordinal not in the image will be
	in the set, i.e. we can use this to find the mex -/
def nonmoves {α : Type u} (M : α → ordinal.{u}) : set ordinal.{u} := { O : ordinal | ¬ ∃ a : α, M a = O }

lemma nonmoves_nonempty {α : Type u} (M : α → ordinal.{u}) : ∃ O : ordinal, O ∈ nonmoves M :=
begin
	classical,
	by_contra h,
	rw nonmoves at h,
	simp only [not_exists, classical.not_forall, set.mem_set_of_eq, classical.not_not] at h,

	have hle : cardinal.univ.{u (u+1)} ≤ cardinal.lift.{u (u+1)} (cardinal.mk α),
	{	split,
		fconstructor,
		{ rintro ⟨ O ⟩,
			exact ⟨ (classical.indefinite_description _ $ h O).val ⟩ },
		{ rintros ⟨ O₁ ⟩ ⟨ O₂ ⟩ heq,
			ext,
			transitivity,
			symmetry,
			exact (classical.indefinite_description _ (h O₁)).prop,
			injection heq with heq,
			rw subtype.val_eq_coe at heq,
			rw heq,
			exact (classical.indefinite_description _ (h O₂)).prop } },

	have hlt : cardinal.lift.{u (u+1)} (cardinal.mk α) < cardinal.univ.{u (u+1)} :=
	  cardinal.lt_univ.2 ⟨ cardinal.mk α, rfl ⟩,

	cases hlt,
	contradiction
end

/-- The Grundy value of an impartial game, the ordinal which corresponds to the game of nim that the game is equivalent to -/
noncomputable def Grundy_value : Π (G : pgame.{u}) [G.impartial], ordinal.{u}
| G :=
begin
	introI,
	exact ordinal.omin (nonmoves (λ i, Grundy_value (G.move_left i))) (nonmoves_nonempty (λ i, Grundy_value (G.move_left i))),
end
using_well_founded {dec_tac := pgame_wf_tac}

lemma Grundy_value_def (G : pgame) [G.impartial] : Grundy_value G = ordinal.omin (nonmoves (λ i, Grundy_value (G.move_left i))) (nonmoves_nonempty (λ i, Grundy_value (G.move_left i))) :=
begin
	rw Grundy_value,
	refl
end

/-- The Sprague-Grundy theorem which states that every impartial game is equivalent to a game of nim, namely the game of nim corresponding to the games Grundy value -/
theorem Sprague_Grundy : ∀ (G : pgame.{u}) [_h : G.impartial], G ≈ nim (@Grundy_value G _h)
| G :=
begin
	classical,
	introI,
	rw [equiv_iff_sum_p_position, ←no_good_left_moves_iff_p_position],
	intro i,
	equiv_rw left_moves_add G (nim $ Grundy_value G) at i,
	cases i with i₁ i₂,
	{ rw add_move_left_inl,
		apply n_position_of_equiv (add_congr (Sprague_Grundy $ G.move_left i₁).symm (equiv_refl _)),
		rw nim_sum_n_position_iff_neq,
		intro heq,
		have heq := symm heq,
		rw Grundy_value_def G at heq,
		have h := ordinal.omin_mem (nonmoves (λ (i : G.left_moves), Grundy_value (G.move_left i))) (nonmoves_nonempty _),
		rw heq at h,
		have hcontra : ∃ (i' : G.left_moves), (λ (i'' : G.left_moves), Grundy_value (G.move_left i'')) i' = Grundy_value (G.move_left i₁) := ⟨ i₁, rfl ⟩,
		contradiction },
	{ rw [add_move_left_inr, ←good_left_move_iff_n_position],
		revert i₂,
		rw nim_def,
		intro i₂,

		have h' : ∃ i : G.left_moves, (Grundy_value $ G.move_left i) = ordinal.typein (quotient.out $ Grundy_value G).r i₂,
		{ have hlt : ordinal.typein (quotient.out $ Grundy_value G).r i₂ < ordinal.type (quotient.out $ Grundy_value G).r := ordinal.typein_lt_type _ _,
			rw ordinal.type_out at hlt,
			revert i₂ hlt,
			rw Grundy_value_def,
			intros i₂ hlt,
			have hnotin : ordinal.typein (quotient.out (ordinal.omin (nonmoves (λ (i : G.left_moves), Grundy_value (G.move_left i))) _)).r i₂ ∉ (nonmoves (λ (i : G.left_moves), Grundy_value (G.move_left i))),
			{ intro hin,
				have hge := ordinal.omin_le hin,
				have hcontra := (le_not_le_of_lt hlt).2,
				contradiction },
			unfold nonmoves at hnotin,
			simpa using hnotin },

		cases h' with i hi,
		use (left_moves_add _ _).symm (sum.inl i),
		rw [add_move_left_inl, move_left_mk],
		apply p_position_of_equiv,
		apply add_congr,
		symmetry,
		exact Sprague_Grundy (G.move_left i),
		refl,
		rw hi,
		exact impartial_add_self _ }
end
using_well_founded {dec_tac := pgame_wf_tac}

end nim


import computability.DFA
import computability.language
import data.fintype.basic
import data.list

import language

universes u v w

namespace DFA

variables {α : Type u}
variables {σ τ : Type v}

section basics

variables {A : DFA α σ} (p : σ) (a : α) (x y : list α)

@[simp] lemma eval_from_nil : A.eval_from p [] = p :=
list.foldl_nil _ _

@[simp] lemma eval_from_cons : A.eval_from p (a :: x) = A.eval_from (A.step p a) x :=
list.foldl_cons _ _ _ _

@[simp] lemma eval_def : A.eval x = A.eval_from A.start x := rfl

attribute [simp] mem_accepts

end basics

section intersection

/-!
### Intersection automaton

Here we construct from two DFAs a DFA whose language is the intersection of the two DFAs, and prove it.
-/

variables (A : DFA α σ) (B : DFA α τ) (s : σ) (t : τ) (a : α) (x : list α)

/--
Given two DFAs, returns a DFA whose language is the intersection of the two DFAs' languages.
-/
def inter : DFA α (σ × τ):=
{
  step := λ ⟨s, t⟩ a, ⟨A.step s a, B.step t a⟩,
  start := ⟨A.start, B.start⟩,
  accept := { st | st.1 ∈ A.accept ∧ st.2 ∈ B.accept}
}

@[simp] lemma inter_step : (inter A B).step (s, t) a = (A.step s a, B.step t a) := rfl
@[simp] lemma inter_start : (inter A B).start = (A.start, B.start) := rfl
@[simp] lemma inter_accept : (s, t) ∈ (inter A B).accept  ↔ s ∈ A.accept ∧ t ∈ B.accept :=
iff.refl _

@[simp]
lemma inter_eval_from : eval_from (inter A B) (s, t) x = (eval_from A s x, eval_from B t x) :=
begin
  induction x with a x ih generalizing s t,
  { tauto },
  { simp [ih _ _] }
end

@[simp]
lemma inter_accepts : accepts (inter A B) = (accepts A) ⊓ (accepts B) :=
by {ext, simp}

end intersection

section complement
/-!
### Complement automaton

Here we construct a DFA whose language is the complement of the given DFA's language.
-/

variables (A : DFA α σ) (s : σ) (a : α) (x : list α)

/--
Given a DFA, returns a DFA whose language is the complement of the given DFA's language.
-/
def compl : DFA α σ :=
{
  step := A.step,
  start := A.start,
  accept := { s | s ∉ A.accept }
}

@[simp] lemma compl_step : A.compl.step = A.step := rfl
@[simp] lemma compl_start : A.compl.start = A.start := rfl
@[simp] lemma compl_accept : s ∈ A.compl.accept ↔ s ∉ A.accept := by refl

@[simp]
lemma compl_eval_from : eval_from A.compl s x = eval_from A s x :=
begin
  induction x with a x ih generalizing s,
  { tauto },
  { simp [ih _] }
end

@[simp]
lemma compl_accepts : accepts (compl A) = (accepts A)ᶜ :=
by {ext, simp}

end complement

section relation
/-!
### Equivalence relation on `list α`
Here we give the basics of the equivalence relation on `list α` that we get for every DFA `A`,
defined as:
`x ≈ y ↔ A.eval x = A.eval y`.
-/

variables (A : DFA α σ)

/--
A relation on `list α`, identifying `x, y` if `A.eval x = A.eval y`.
-/
definition rel : list α → list α → Prop :=
λ x y, A.eval x = A.eval y

@[simp] lemma rel_def {x y : list α} : rel A x y ↔ A.eval x = A.eval y := by refl

lemma rel_refl : reflexive (rel A) := λ _, by rw rel_def
lemma rel_symm : symmetric (rel A) := λ _ _ hxy, eq.symm hxy
lemma rel_trans : transitive (rel A) := λ _ _ _ hxy hyz, eq.trans hxy hyz
lemma rel_equiv : equivalence (rel A) := ⟨rel_refl A, rel_symm A, rel_trans A⟩

instance space.setoid : setoid (list α) := setoid.mk A.rel A.rel_equiv

definition space := quotient (space.setoid A)

variable {A}

definition space.mk (x : list α) : space A := @quotient.mk _ (space.setoid A) x

@[simp] lemma space.mk_def (x : list α) : space.mk x = @quotient.mk _ (space.setoid A) x := rfl
@[simp] lemma space.mk_def' (x : list α) : @quotient.mk' _ (space.setoid A) x = space.mk x := rfl

variable (A)

-- The canonical map. We show it is injective, as a part of the proof of Myhill-Nerode.
def to_states : space A → σ :=
begin
  apply quot.lift A.eval,
  intros x y rab,
  rw (rel_def A).1 rab
end

@[simp] lemma to_states_def (x : list α) : to_states A (space.mk x) = A.eval x := rfl

lemma injective_to_states : function.injective (to_states A) :=
begin
  apply @quotient.ind₂' (list α) (list α) _ _ (λ ex ey, to_states A ex = to_states A ey → ex = ey) ,
  intros x y h,
  repeat {rw space.mk_def' _ at h, rw f_def A _ at h},
  simp,
  exact h,
end

-- What we actually care about, sadly noncomputable :(
noncomputable instance fintype_space_of_fintype_states [fintype σ] : fintype (space A) :=
fintype.of_injective (to_states A) (injective_to_states A)

end relation

end DFA


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.matrix
import linear_algebra.matrix.bilinear_form

/-!
# Lie algebras of skew-adjoint endomorphisms of a bilinear form

When a module carries a bilinear form, the Lie algebra of endomorphisms of the module contains a
distinguished Lie subalgebra: the skew-adjoint endomorphisms. Such subalgebras are important
because they provide a simple, explicit construction of the so-called classical Lie algebras.

This file defines the Lie subalgebra of skew-adjoint endomorphims cut out by a bilinear form on
a module and proves some basic related results. It also provides the corresponding definitions and
results for the Lie algebra of square matrices.

## Main definitions

  * `skew_adjoint_lie_subalgebra`
  * `skew_adjoint_lie_subalgebra_equiv`
  * `skew_adjoint_matrices_lie_subalgebra`
  * `skew_adjoint_matrices_lie_subalgebra_equiv`

## Tags

lie algebra, skew-adjoint, bilinear form
-/

universes u v w w₁

section skew_adjoint_endomorphisms
open bilin_form

variables {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M]
variables (B : bilin_form R M)

lemma bilin_form.is_skew_adjoint_bracket (f g : module.End R M)
  (hf : f ∈ B.skew_adjoint_submodule) (hg : g ∈ B.skew_adjoint_submodule) :
  ⁅f, g⁆ ∈ B.skew_adjoint_submodule :=
begin
  rw mem_skew_adjoint_submodule at *,
  have hfg : is_adjoint_pair B B (f * g) (g * f), { rw ←neg_mul_neg g f, exact hf.mul hg, },
  have hgf : is_adjoint_pair B B (g * f) (f * g), { rw ←neg_mul_neg f g, exact hg.mul hf, },
  change bilin_form.is_adjoint_pair B B (f * g - g * f) (-(f * g - g * f)), rw neg_sub,
  exact hfg.sub hgf,
end

/-- Given an `R`-module `M`, equipped with a bilinear form, the skew-adjoint endomorphisms form a
Lie subalgebra of the Lie algebra of endomorphisms. -/
def skew_adjoint_lie_subalgebra : lie_subalgebra R (module.End R M) :=
{ lie_mem' := B.is_skew_adjoint_bracket, ..B.skew_adjoint_submodule }

variables {N : Type w} [add_comm_group N] [module R N] (e : N ≃ₗ[R] M)

/-- An equivalence of modules with bilinear forms gives equivalence of Lie algebras of skew-adjoint
endomorphisms. -/
def skew_adjoint_lie_subalgebra_equiv :
  skew_adjoint_lie_subalgebra (B.comp (↑e : N →ₗ[R] M) ↑e) ≃ₗ⁅R⁆ skew_adjoint_lie_subalgebra B :=
begin
  apply lie_equiv.of_subalgebras _ _ e.lie_conj,
  ext f,
  simp only [lie_subalgebra.mem_coe, submodule.mem_map_equiv, lie_subalgebra.mem_map_submodule,
    coe_coe],
  exact (bilin_form.is_pair_self_adjoint_equiv (-B) B e f).symm,
end

@[simp] lemma skew_adjoint_lie_subalgebra_equiv_apply
  (f : skew_adjoint_lie_subalgebra (B.comp ↑e ↑e)) :
  ↑(skew_adjoint_lie_subalgebra_equiv B e f) = e.lie_conj f :=
by simp [skew_adjoint_lie_subalgebra_equiv]

@[simp] lemma skew_adjoint_lie_subalgebra_equiv_symm_apply (f : skew_adjoint_lie_subalgebra B) :
  ↑((skew_adjoint_lie_subalgebra_equiv B e).symm f) = e.symm.lie_conj f :=
by simp [skew_adjoint_lie_subalgebra_equiv]

end skew_adjoint_endomorphisms

section skew_adjoint_matrices
open_locale matrix

variables {R : Type u} {n : Type w} [comm_ring R] [decidable_eq n] [fintype n]
variables (J : matrix n n R)

lemma matrix.lie_transpose (A B : matrix n n R) : ⁅A, B⁆ᵀ = ⁅Bᵀ, Aᵀ⁆ :=
show (A * B - B * A)ᵀ = (Bᵀ * Aᵀ - Aᵀ * Bᵀ), by simp

lemma matrix.is_skew_adjoint_bracket (A B : matrix n n R)
  (hA : A ∈ skew_adjoint_matrices_submodule J) (hB : B ∈ skew_adjoint_matrices_submodule J) :
  ⁅A, B⁆ ∈ skew_adjoint_matrices_submodule J :=
begin
  simp only [mem_skew_adjoint_matrices_submodule] at *,
  change ⁅A, B⁆ᵀ ⬝ J = J ⬝ -⁅A, B⁆, change Aᵀ ⬝ J = J ⬝ -A at hA, change Bᵀ ⬝ J = J ⬝ -B at hB,
  simp only [←matrix.mul_eq_mul] at *,
  rw [matrix.lie_transpose, lie_ring.of_associative_ring_bracket,
    lie_ring.of_associative_ring_bracket, sub_mul, mul_assoc, mul_assoc, hA, hB, ←mul_assoc,
    ←mul_assoc, hA, hB],
  noncomm_ring,
end

/-- The Lie subalgebra of skew-adjoint square matrices corresponding to a square matrix `J`. -/
def skew_adjoint_matrices_lie_subalgebra : lie_subalgebra R (matrix n n R) :=
{ lie_mem' := J.is_skew_adjoint_bracket, ..(skew_adjoint_matrices_submodule J) }

@[simp] lemma mem_skew_adjoint_matrices_lie_subalgebra (A : matrix n n R) :
  A ∈ skew_adjoint_matrices_lie_subalgebra J ↔ A ∈ skew_adjoint_matrices_submodule J :=
iff.rfl

/-- An invertible matrix `P` gives a Lie algebra equivalence between those endomorphisms that are
skew-adjoint with respect to a square matrix `J` and those with respect to `PᵀJP`. -/
def skew_adjoint_matrices_lie_subalgebra_equiv (P : matrix n n R) (h : invertible P) :
  skew_adjoint_matrices_lie_subalgebra J ≃ₗ⁅R⁆ skew_adjoint_matrices_lie_subalgebra (Pᵀ ⬝ J ⬝ P) :=
lie_equiv.of_subalgebras _ _ (P.lie_conj h).symm
begin
  ext A,
  suffices : P.lie_conj h A ∈ skew_adjoint_matrices_submodule J ↔
    A ∈ skew_adjoint_matrices_submodule (Pᵀ ⬝ J ⬝ P),
  { simp only [lie_subalgebra.mem_coe, submodule.mem_map_equiv, lie_subalgebra.mem_map_submodule,
      coe_coe], exact this, },
  simp [matrix.is_skew_adjoint, J.is_adjoint_pair_equiv' _ _ P (is_unit_of_invertible P)],
end

lemma skew_adjoint_matrices_lie_subalgebra_equiv_apply
  (P : matrix n n R) (h : invertible P) (A : skew_adjoint_matrices_lie_subalgebra J) :
  ↑(skew_adjoint_matrices_lie_subalgebra_equiv J P h A) = P⁻¹ ⬝ ↑A ⬝ P :=
by simp [skew_adjoint_matrices_lie_subalgebra_equiv]

/-- An equivalence of matrix algebras commuting with the transpose endomorphisms restricts to an
equivalence of Lie algebras of skew-adjoint matrices. -/
def skew_adjoint_matrices_lie_subalgebra_equiv_transpose {m : Type w} [decidable_eq m] [fintype m]
  (e : matrix n n R ≃ₐ[R] matrix m m R) (h : ∀ A, (e A)ᵀ = e (Aᵀ)) :
  skew_adjoint_matrices_lie_subalgebra J ≃ₗ⁅R⁆ skew_adjoint_matrices_lie_subalgebra (e J) :=
lie_equiv.of_subalgebras _ _ e.to_lie_equiv
begin
  ext A,
  suffices : J.is_skew_adjoint (e.symm A) ↔ (e J).is_skew_adjoint A, by simpa [this],
  simp [matrix.is_skew_adjoint, matrix.is_adjoint_pair, ← matrix.mul_eq_mul,
    ← h, ← function.injective.eq_iff e.injective],
end

@[simp] lemma skew_adjoint_matrices_lie_subalgebra_equiv_transpose_apply
  {m : Type w} [decidable_eq m] [fintype m]
  (e : matrix n n R ≃ₐ[R] matrix m m R) (h : ∀ A, (e A)ᵀ = e (Aᵀ))
  (A : skew_adjoint_matrices_lie_subalgebra J) :
  (skew_adjoint_matrices_lie_subalgebra_equiv_transpose J e h A : matrix m m R) = e A :=
rfl

lemma mem_skew_adjoint_matrices_lie_subalgebra_unit_smul (u : Rˣ) (J A : matrix n n R) :
  A ∈ skew_adjoint_matrices_lie_subalgebra (u • J) ↔
  A ∈ skew_adjoint_matrices_lie_subalgebra J :=
begin
  change A ∈ skew_adjoint_matrices_submodule (u • J) ↔ A ∈ skew_adjoint_matrices_submodule J,
  simp only [mem_skew_adjoint_matrices_submodule, matrix.is_skew_adjoint, matrix.is_adjoint_pair],
  split; intros h,
  { simpa using congr_arg (λ B, u⁻¹ • B) h, },
  { simp [h], },
end

end skew_adjoint_matrices


/-
Copyright (c) 2023 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import ..default

open form classical

@[reducible] def wrld := set form

/- Kripke models -/

structure model :=
  (W : set wrld)
  (R : wrld → wrld → Prop)
  (val : ℕ → wrld → Prop)
  (refl : ∀ w ∈ W, R w w)
  (trans : ∀ w ∈ W, ∀ v ∈ W, ∀ u ∈ W, R w v → R v u → R w u)

local attribute [instance] prop_decidable

@[simp]
def forces_form (M : model) : form → wrld → Prop
|  (#p)   := λ v, M.val p v
| (bot) := λ v, false
| (p ⊃ q) := λ v, (∀ w ∈ M.W, v ∈ M.W → M.R v w → forces_form p w → forces_form q w)
| (p & q) := λ v, forces_form p v ∧ forces_form q v
| (p ∨ q) := λ v, forces_form p v ∨ forces_form q v

/- Forcing -/

notation w `⊩` `⦃` M `⦄ ` p := forces_form M p w

/- Local logical consequence -/

def forces_ctx (M : model) (Γ : set form) : wrld → Prop :=
λ w, ∀ p, p ∈ Γ → forces_form M p w

notation w `⊩` `⦃` M `⦄ ` p := forces_ctx M p w

def sem_csq (Γ : set form) (p : form) :=
∀ (M : model) (w ∈ M.W), (w ⊩⦃M⦄ Γ) → (w ⊩⦃M⦄ p)

notation Γ ` ⊨ᵢ ` p := sem_csq Γ p

/- a helpful lemma -/

lemma ctx_tt_to_subctx_tt {Γ Δ : set form} {M : model} {w : wrld} :
  (w ⊩⦃M⦄ Γ) → Δ ⊆ Γ → (w ⊩⦃M⦄ Δ) :=
by { intros h s p pmem, apply h, apply s, assumption}


/-
The aim here is to write a solver that can handle ∨ and ∧ in both hypotheses and goals.
This requires dealing with multiple goals. -/

open tactic
open list
open expr

meta def and_and_or : list expr → list expr → expr → tactic unit
-- first argument is list of hypotheses yet to be processed
-- second argument is target
| (cons h t) (cons `(%%a ∨ %%b) u) e :=
  seq'
    (do ex ← to_expr ``(or.elim %%h),
    apply ex >> skip)
    (do nm ← get_unused_name `h,
    h' ← intro nm,
    tp ← infer_type h',
    and_and_or (cons h' t) (cons tp u) e)
| (cons h t) (cons `(%%a ∧ %%b) u) e :=
do nm₁ ← get_unused_name `h,
  nm₂ ← get_unused_name `h,
  ea ← to_expr ``(and.left %%h),
  eb ← to_expr ``(and.right %%h),
  ha ← assertv nm₁ a ea,
  hb ← assertv nm₂ b eb,
  clear h,
  and_and_or
    (cons ha (cons hb t))
    (cons a (cons b u))
    e
| (cons _ t) (cons _ u) e := and_and_or t u e
| nil (cons _ t) _ := fail "Unsynchronized lists as arguments to and_and_or"
| (cons _ t) nil _ := fail "Unsynchronized lists as arguments to and_and_or"
| nil nil `(%%a ∨ %%b) :=
  (applyc ``or.inl >> and_and_or nil nil a) <|>
  (applyc ``or.inr >> and_and_or nil nil b)
| nil nil `(%%a ∧ %%b) :=
  seq' (applyc ``and.intro) (target >>= and_and_or nil nil)
| nil nil _ := assumption

meta def tactic.interactive.main_tactic : tactic unit :=
do t ← target,
  l ← local_context,
  tps ← l.mmap infer_type,
  and_and_or l tps t

example (P Q R : Prop) (h₁ : P) (h₂ : Q ∧ R): (P ∧ Q ∧ R) :=
by main_tactic

example (P Q R : Prop) (h : Q ∧ R) : (P ∨ Q ∨ R) :=
by main_tactic

example (P Q R : Prop) (h : (P ∨ Q) ∧ (P ∨ R)) : (P ∨ Q ∧ R) :=
by main_tactic

example (P Q R : Prop) (h : (P ∨ Q) ∧ (P ∨ R) ∧ (Q ∨ R)) :
  (P ∧ Q) ∨ (P ∧ R) ∨ (Q ∧ R) :=
by main_tactic


axiom appendNil {α} (as : List α) : as ++ [] = as
axiom appendAssoc {α} (as bs cs : List α) : (as ++ bs) ++ cs = as ++ (bs ++ cs)
axiom reverseEq {α} (as : List α) : as.reverse.reverse = as

theorem ex1 {α} (as bs : List α) : as.reverse.reverse ++ [] ++ [] ++ bs ++ bs = as ++ (bs ++ bs) := by
  rw [appendNil, appendNil, reverseEq];
  traceState;
  rw [←appendAssoc];

theorem ex2 {α} (as bs : List α) : as.reverse.reverse ++ [] ++ [] ++ bs ++ bs = as ++ (bs ++ bs) := by
rewrite [reverseEq, reverseEq]; -- Error on second reverseEq
done

axiom zeroAdd (x : Nat) : 0 + x = x

theorem ex2 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [zeroAdd] at h₁ h₂;
traceState;
subst x;
subst y;
exact rfl

theorem ex3 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [zeroAdd] at *;
subst x;
subst y;
exact rfl

theorem ex4 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [appendAssoc] at *; -- Error
done

theorem ex5 (m n k : Nat) (h : 0 + n = m) (h : k = m) : k = n := by
rw [zeroAdd] at *;
traceState; -- `h` is still a name for `h : k = m`
refine Eq.trans h ?hole;
apply Eq.symm;
assumption

theorem ex6 (p q r : Prop) (h₁ : q → r) (h₂ : p ↔ q) (h₃ : p) : r := by
rw [←h₂] at h₁;
exact h₁ h₃

theorem ex7 (p q r : Prop) (h₁ : q → r) (h₂ : p ↔ q) (h₃ : p) : r := by
rw [h₂] at h₃;
exact h₁ h₃

example (α : Type) (p : Prop) (a b c : α) (h : p → a = b) : a = c := by
  rw [h _]  -- should manifest goal `⊢ p`, like `rw [h]` would