/-
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.

Complete the API. See
https://github.com/leanprover-community/mathlib/pull/14448#discussion_r906109235
for some ideas.
-/

open_locale big_operators

variables {ι α : Type*}

namespace finset
section preorder
variables [preorder α]

section locally_finite_order
variables [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 }

end filter

section locally_finite_order_top
variables [locally_finite_order_top α]

lemma Icc_subset_Ici_self : Icc a b ⊆ Ici a := by simpa [←coe_subset] using set.Icc_subset_Ici_self
lemma Ico_subset_Ici_self : Ico a b ⊆ Ici a := by simpa [←coe_subset] using set.Ico_subset_Ici_self
lemma Ioc_subset_Ioi_self : Ioc a b ⊆ Ioi a := by simpa [←coe_subset] using set.Ioc_subset_Ioi_self
lemma Ioo_subset_Ioi_self : Ioo a b ⊆ Ioi a := by simpa [←coe_subset] using set.Ioo_subset_Ioi_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_Ico_self.trans Ico_subset_Ici_self

end locally_finite_order_top

section locally_finite_order_bot
variables [locally_finite_order_bot α]

lemma Icc_subset_Iic_self : Icc a b ⊆ Iic b := by simpa [←coe_subset] using set.Icc_subset_Iic_self
lemma Ioc_subset_Iic_self : Ioc a b ⊆ Iic b := by simpa [←coe_subset] using set.Ioc_subset_Iic_self
lemma Ico_subset_Iio_self : Ico a b ⊆ Iio b := by simpa [←coe_subset] using set.Ico_subset_Iio_self
lemma Ioo_subset_Iio_self : Ioo a b ⊆ Iio b := by simpa [←coe_subset] using set.Ioo_subset_Iio_self
lemma Ico_subset_Iic_self : Ico a b ⊆ Iic b := Ico_subset_Icc_self.trans Icc_subset_Iic_self
lemma Ioo_subset_Iic_self : Ioo a b ⊆ Iic b := Ioo_subset_Ioc_self.trans Ioc_subset_Iic_self

end locally_finite_order_bot
end locally_finite_order

section locally_finite_order_top
variables [locally_finite_order_top α] {a : α}

lemma Ioi_subset_Ici_self : Ioi a ⊆ Ici a := by simpa [←coe_subset] using set.Ioi_subset_Ici_self

lemma _root_.bdd_below.finite {s : set α} (hs : bdd_below s) : s.finite :=
let ⟨a, ha⟩ := hs in (Ici a).finite_to_set.subset $ λ x hx, mem_Ici.2 $ ha hx

variables [fintype α]

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

end locally_finite_order_top

section locally_finite_order_bot
variables [locally_finite_order_bot α] {a : α}

lemma Iio_subset_Iic_self : Iio a ⊆ Iic a := by simpa [←coe_subset] using set.Iio_subset_Iic_self

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

variables [fintype α]

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

end locally_finite_order_bot

variables [decidable_eq α] [locally_finite_order_top α] [locally_finite_order_bot α]

lemma disjoint_Ioi_Iio (a : α) :  disjoint (Ioi a) (Iio a) :=
disjoint_left.2 $ λ b hab hba, (mem_Ioi.1 hab).not_lt $ mem_Iio.1 hba

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 αᵒᵈ _ _ _ _

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 αᵒᵈ _ _ _ _

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 α]

section locally_finite_order
variables [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]

@[simp] lemma Ioc_union_Ioc_eq_Ioc {a b c : α} (h₁ : a ≤ b) (h₂ : b ≤ c) :
  Ioc a b ∪ Ioc b c = Ioc a c :=
by rw [←coe_inj, coe_union, coe_Ioc, coe_Ioc, coe_Ioc, set.Ioc_union_Ioc_eq_Ioc h₁ h₂]

lemma Ico_subset_Ico_union_Ico {a b c : α} :
  Ico a c ⊆ Ico a b ∪ Ico b c :=
by { rw [←coe_subset, coe_union, coe_Ico, coe_Ico, coe_Ico], exact set.Ico_subset_Ico_union_Ico }

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 locally_finite_order

variables [fintype α] [locally_finite_order_top α] [locally_finite_order_bot α]

lemma Ioi_disj_union_Iio (a : α) :
  (Ioi a).disj_union (Iio a) (disjoint_left.1 $ disjoint_Ioi_Iio a) = ({a} : finset α)ᶜ :=
by { ext, simp [eq_comm] }

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

@[to_additive] lemma prod_prod_Ioi_mul_eq_prod_prod_off_diag [fintype ι] [linear_order ι]
  [locally_finite_order_top ι] [locally_finite_order_bot ι] [comm_monoid α] (f : ι → ι → α) :
  ∏ i, ∏ j in Ioi i, f j i * f i j = ∏ i, ∏ j in {i}ᶜ, f j i :=
begin
  simp_rw [←Ioi_disj_union_Iio, prod_disj_union, prod_mul_distrib],
  congr' 1,
  rw [prod_sigma', prod_sigma'],
  refine prod_bij' (λ i hi, ⟨i.2, i.1⟩) _ _ (λ i hi, ⟨i.2, i.1⟩) _ _ _; simp,
end

end finset


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import data.fin.fin2
import logic.function.basic
import tactic.basic

/-!

# Tuples of types, and their categorical structure.

## Features

* `typevec n` - n-tuples of types
* `α ⟹ β`    - n-tuples of maps
* `f ⊚ g`     - composition

Also, support functions for operating with n-tuples of types, such as:

* `append1 α β`    - append type `β` to n-tuple `α` to obtain an (n+1)-tuple
* `drop α`         - drops the last element of an (n+1)-tuple
* `last α`         - returns the last element of an (n+1)-tuple
* `append_fun f g` - appends a function g to an n-tuple of functions
* `drop_fun f`     - drops the last function from an n+1-tuple
* `last_fun f`     - returns the last function of a tuple.

Since e.g. `append1 α.drop α.last` is propositionally equal to `α` but not definitionally equal
to it, we need support functions and lemmas to mediate between constructions.
-/

universes u v w

/--
n-tuples of types, as a category
-/
def typevec (n : ℕ) := fin2 n → Type*

instance {n} : inhabited (typevec.{u} n) := ⟨ λ _, punit ⟩

namespace typevec

variable {n : ℕ}

/-- arrow in the category of `typevec` -/
def arrow (α β : typevec n) := Π i : fin2 n, α i → β i

localized "infixl ` ⟹ `:40 := typevec.arrow" in mvfunctor

instance arrow.inhabited (α β : typevec n) [Π i, inhabited (β i)] : inhabited (α ⟹ β) :=
⟨ λ _ _, default ⟩

/-- identity of arrow composition -/
def id {α : typevec n} : α ⟹ α := λ i x, x

/-- arrow composition in the category of `typevec` -/
def comp {α β γ : typevec n} (g : β ⟹ γ) (f : α ⟹ β) : α ⟹ γ :=
λ i x, g i (f i x)

localized "infixr ` ⊚ `:80 := typevec.comp" in mvfunctor -- type as \oo

@[simp] theorem id_comp {α β : typevec n} (f : α ⟹ β) : id ⊚ f = f :=
rfl

@[simp] theorem comp_id {α β : typevec n} (f : α ⟹ β) : f ⊚ id = f :=
rfl

theorem comp_assoc {α β γ δ : typevec n} (h : γ ⟹ δ) (g : β ⟹ γ) (f : α ⟹ β) :
  (h ⊚ g) ⊚ f = h ⊚ g ⊚ f := rfl

/--
Support for extending a typevec by one element.
-/
def append1 (α : typevec n) (β : Type*) : typevec (n+1)
| (fin2.fs i) := α i
| fin2.fz      := β

infixl ` ::: `:67 := append1

/-- retain only a `n-length` prefix of the argument -/
def drop (α : typevec.{u} (n+1)) : typevec n := λ i, α i.fs

/-- take the last value of a `(n+1)-length` vector -/
def last (α : typevec.{u} (n+1)) : Type* := α fin2.fz

instance last.inhabited (α : typevec (n+1)) [inhabited (α fin2.fz)] : inhabited (last α) :=
⟨show α fin2.fz, from default⟩

theorem drop_append1 {α : typevec n} {β : Type*} {i : fin2 n} : drop (append1 α β) i = α i := rfl

theorem drop_append1' {α : typevec n} {β : Type*} : drop (append1 α β) = α :=
by ext; apply drop_append1

theorem last_append1 {α : typevec n} {β : Type*} : last (append1 α β) = β := rfl

@[simp]
theorem append1_drop_last (α : typevec (n+1)) : append1 (drop α) (last α) = α :=
funext $ λ i, by cases i; refl

/-- cases on `(n+1)-length` vectors -/
@[elab_as_eliminator] def append1_cases
  {C : typevec (n+1) → Sort u} (H : ∀ α β, C (append1 α β)) (γ) : C γ :=
by rw [← @append1_drop_last _ γ]; apply H

@[simp] theorem append1_cases_append1 {C : typevec (n+1) → Sort u}
  (H : ∀ α β, C (append1 α β)) (α β) :
  @append1_cases _ C H (append1 α β) = H α β := rfl

/-- append an arrow and a function for arbitrary source and target
type vectors -/
def split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') : α ⟹ α'
| (fin2.fs i) := f i
| fin2.fz      := g

/-- append an arrow and a function as well as their respective source
and target types / typevecs -/
def append_fun {α α' : typevec n} {β β' : Type*}
  (f : α ⟹ α') (g : β → β') : append1 α β ⟹ append1 α' β' := split_fun f g

infixl ` ::: ` := append_fun

/-- split off the prefix of an arrow -/
def drop_fun {α β : typevec (n+1)} (f : α ⟹ β) : drop α ⟹ drop β :=
λ i, f i.fs

/-- split off the last function of an arrow -/
def last_fun {α β : typevec (n+1)} (f : α ⟹ β) : last α → last β :=
f fin2.fz

/-- arrow in the category of `0-length` vectors -/
def nil_fun {α : typevec 0} {β : typevec 0} : α ⟹ β :=
λ i, fin2.elim0 i

theorem eq_of_drop_last_eq {α β : typevec (n+1)} {f g : α ⟹ β}
  (h₀ : drop_fun f = drop_fun g) (h₁ : last_fun f = last_fun g) : f = g :=
by replace h₀ := congr_fun h₀;
   ext1 (ieq | ⟨j, ieq⟩); apply_assumption

@[simp]

/-- turn an equality into an arrow -/
def arrow.mp {α β : typevec n} (h : α = β) : α ⟹ β
| i := eq.mp (congr_fun h _)

/-- turn an equality into an arrow, with reverse direction -/
def arrow.mpr {α β : typevec n} (h : α = β) : β ⟹ α
| i := eq.mpr (congr_fun h _)

/-- decompose a vector into its prefix appended with its last element -/
def to_append1_drop_last {α : typevec (n+1)} : α ⟹ drop α ::: last α :=
arrow.mpr (append1_drop_last _)

/-- stitch two bits of a vector back together -/
def from_append1_drop_last {α : typevec (n+1)} : drop α ::: last α ⟹ α :=
arrow.mp (append1_drop_last _)

@[simp] theorem last_fun_split_fun {α α' : typevec (n+1)}
  (f : drop α ⟹ drop α') (g : last α → last α') :
  last_fun (split_fun f g) = g := rfl

@[simp] theorem drop_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  drop_fun (f ::: g) = f := rfl

@[simp] theorem last_fun_append_fun {α α' : typevec n} {β β' : Type*} (f : α ⟹ α') (g : β → β') :
  last_fun (f ::: g) = g := rfl

theorem split_drop_fun_last_fun {α α' : typevec (n+1)} (f : α ⟹ α') :
  split_fun (drop_fun f) (last_fun f) = f :=
eq_of_drop_last_eq rfl rfl

theorem split_fun_inj
  {α α' : typevec (n+1)} {f f' : drop α ⟹ drop α'} {g g' : last α → last α'}
  (H : split_fun f g = split_fun f' g') : f = f' ∧ g = g' :=
by rw [← drop_fun_split_fun f g, H, ← last_fun_split_fun f g, H]; simp

theorem append_fun_inj {α α' : typevec n} {β β' : Type*} {f f' : α ⟹ α'} {g g' : β → β'} :
  f ::: g = f' ::: g' →  f = f' ∧ g = g' :=
split_fun_inj

theorem split_fun_comp {α₀ α₁ α₂ : typevec (n+1)}
    (f₀ : drop α₀ ⟹ drop α₁) (f₁ : drop α₁ ⟹ drop α₂)
    (g₀ : last α₀ → last α₁) (g₁ : last α₁ → last α₂) :
  split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) = split_fun f₁ g₁ ⊚ split_fun f₀ g₀ :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_comp_split_fun
  {α γ : typevec n} {β δ : Type*} {ε : typevec (n + 1)}
    (f₀ : drop ε ⟹ α) (f₁ : α ⟹ γ)
    (g₀ : last ε → β) (g₁ : β → δ) :
  append_fun f₁ g₁ ⊚ split_fun f₀ g₀ = split_fun (f₁ ⊚ f₀) (g₁ ∘ g₀) :=
(split_fun_comp _ _ _ _).symm

lemma append_fun_comp {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  f₁ ⊚ f₀ ::: g₁ ∘ g₀ = (f₁ ::: g₁) ⊚ (f₀ ::: g₀) :=
eq_of_drop_last_eq rfl rfl

lemma append_fun_comp' {α₀ α₁ α₂ : typevec n} {β₀ β₁ β₂ : Type*}
    (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  (f₁ ::: g₁) ⊚ (f₀ ::: g₀) = f₁ ⊚ f₀ ::: g₁ ∘ g₀ :=
eq_of_drop_last_eq rfl rfl

lemma nil_fun_comp {α₀ : typevec 0} (f₀ : α₀ ⟹ fin2.elim0) : nil_fun ⊚ f₀ = f₀ :=
funext $ λ x, fin2.elim0 x

theorem append_fun_comp_id {α : typevec n} {β₀ β₁ β₂ : Type*}
    (g₀ : β₀ → β₁) (g₁ : β₁ → β₂) :
  @id _ α ::: g₁ ∘ g₀ = (id ::: g₁) ⊚ (id ::: g₀) :=
eq_of_drop_last_eq rfl rfl

@[simp]
theorem drop_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  drop_fun (f₁ ⊚ f₀) = drop_fun f₁ ⊚ drop_fun f₀ := rfl

@[simp]
theorem last_fun_comp {α₀ α₁ α₂ : typevec (n+1)} (f₀ : α₀ ⟹ α₁) (f₁ : α₁ ⟹ α₂) :
  last_fun (f₁ ⊚ f₀) = last_fun f₁ ∘ last_fun f₀ := rfl

theorem append_fun_aux {α α' : typevec n} {β β' : Type*}
  (f : α ::: β ⟹ α' ::: β') : drop_fun f ::: last_fun f = f :=
eq_of_drop_last_eq rfl rfl

theorem append_fun_id_id {α : typevec n} {β : Type*} :
  @typevec.id n α ::: @_root_.id β = typevec.id :=
eq_of_drop_last_eq rfl rfl

instance subsingleton0 : subsingleton (typevec 0) :=
⟨ λ a b, funext $ λ a, fin2.elim0 a  ⟩

run_cmd do
  mk_simp_attr `typevec,
  tactic.add_doc_string `simp_attr.typevec
"simp set for the manipulation of typevec and arrow expressions"

local prefix `♯`:0 := cast (by try { simp }; congr' 1; try { simp })

/-- cases distinction for 0-length type vector -/
protected def cases_nil {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  Π v, β v :=
λ v, ♯ f

/-- cases distinction for (n+1)-length type vector -/
protected def cases_cons (n : ℕ) {β : typevec (n+1) → Sort*}
  (f : Π t (v : typevec n), β (v ::: t)) :
  Π v, β v :=
λ v : typevec (n+1), ♯ f v.last v.drop

protected lemma cases_nil_append1 {β : typevec 0 → Sort*} (f : β fin2.elim0) :
  typevec.cases_nil f fin2.elim0 = f := rfl

protected lemma cases_cons_append1 (n : ℕ) {β : typevec (n+1) → Sort*}
      (f : Π t (v : typevec n), β (v ::: t))
      (v : typevec n) (α) :
  typevec.cases_cons n f (v ::: α) = f α v := rfl

/-- cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₃ {β : Π v v' : typevec 0, v ⟹ v' → Sort*}
  (f : β fin2.elim0 fin2.elim0 nil_fun) :
  Π v v' fs, β v v' fs :=
λ v v' fs,
begin
  refine cast _ f; congr' 1; ext; try { intros; casesm fin2 0 }, refl
end

/-- cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₃ (n : ℕ) {β : Π v v' : typevec (n+1), v ⟹ v' → Sort*}
  (F : Π t t' (f : t → t') (v v' : typevec n) (fs : v ⟹ v'), β (v ::: t) (v' ::: t') (fs ::: f)) :
  Π v v' fs, β v v' fs :=
begin
  intros v v',
  rw [←append1_drop_last v, ←append1_drop_last v'],
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

/-- specialized cases distinction for an arrow in the category of 0-length type vectors -/
def typevec_cases_nil₂ {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  Π f, β f :=
begin
  intro g, have : g = nil_fun, ext ⟨ ⟩,
  rw this, exact f
end

/-- specialized cases distinction for an arrow in the category of (n+1)-length type vectors -/
def typevec_cases_cons₂ (n : ℕ) (t t' : Type*) (v v' : typevec (n))
  {β : (v ::: t) ⟹ (v' ::: t') → Sort*} (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) :
  Π fs, β fs :=
begin
  intro fs,
  rw [←split_drop_fun_last_fun fs],
  apply F
end

lemma typevec_cases_nil₂_append_fun {β : fin2.elim0 ⟹ fin2.elim0 → Sort*}
  (f : β nil_fun) :
  typevec_cases_nil₂ f nil_fun = f := rfl

lemma typevec_cases_cons₂_append_fun (n : ℕ) (t t' : Type*)
  (v v' : typevec (n)) {β : (v ::: t) ⟹ (v' ::: t') → Sort*}
  (F : Π (f : t → t') (fs : v ⟹ v'), β (fs ::: f)) (f fs) :
  typevec_cases_cons₂ n t t' v v' F (fs ::: f) = F f fs := rfl

/- for lifting predicates and relations -/

/-- `pred_last α p x` predicates `p` of the last element of `x : α.append1 β`. -/
def pred_last (α : typevec n) {β : Type*} (p : β → Prop) : Π ⦃i⦄, (α.append1 β) i → Prop
| (fin2.fs i) := λ x, true
| fin2.fz      := p

/-- `rel_last α r x y` says that `p` the last elements of `x y : α.append1 β` are related by `r` and
all the other elements are equal. -/
def rel_last (α : typevec n) {β γ : Type*} (r : β → γ → Prop) :
  Π ⦃i⦄, (α.append1 β) i → (α.append1 γ) i → Prop
| (fin2.fs i) := eq
| fin2.fz      := r

section liftp'
open nat

/-- `repeat n t` is a `n-length` type vector that contains `n` occurences of `t` -/
def repeat : Π (n : ℕ) (t : Sort*), typevec n
| 0 t := fin2.elim0
| (nat.succ i) t := append1 (repeat i t) t

/-- `prod α β` is the pointwise product of the components of `α` and `β` -/
def prod : Π {n} (α β : typevec.{u} n), typevec n
| 0 α β := fin2.elim0
| (n+1) α β := prod (drop α) (drop β) ::: (last α × last β)

localized "infix ` ⊗ `:45 := typevec.prod" in mvfunctor

/-- `const x α` is an arrow that ignores its source and constructs a `typevec` that
contains nothing but `x` -/
protected def const {β} (x : β) : Π {n} (α : typevec n), α ⟹ repeat _ β
| (succ n) α (fin2.fs i) := const (drop α) _
| (succ n) α fin2.fz := λ _, x

open function (uncurry)

/-- vector of equality on a product of vectors -/
def repeat_eq : Π {n} (α : typevec n), α ⊗ α ⟹ repeat _ Prop
| 0 α := nil_fun
| (succ n) α := repeat_eq (drop α) ::: uncurry eq

lemma const_append1 {β γ} (x : γ) {n} (α : typevec n) :
  typevec.const x (α ::: β) = append_fun (typevec.const x α) (λ _, x) :=
by ext i : 1; cases i; refl

lemma eq_nil_fun {α β : typevec 0} (f : α ⟹ β) : f = nil_fun :=
by ext x; cases x

lemma id_eq_nil_fun {α : typevec 0} : @id _ α = nil_fun :=
by ext x; cases x

lemma const_nil {β} (x : β) (α : typevec 0) : typevec.const x α = nil_fun :=
by ext i : 1; cases i; refl

@[typevec]
lemma repeat_eq_append1 {β} {n} (α : typevec n) :
  repeat_eq (α ::: β) = split_fun (repeat_eq α) (uncurry eq) :=
by induction n; refl

@[typevec]
lemma repeat_eq_nil (α : typevec 0) : repeat_eq α = nil_fun :=
by ext i : 1; cases i; refl

/-- predicate on a type vector to constrain only the last object -/
def pred_last' (α : typevec n) {β : Type*} (p : β → Prop) : α ::: β ⟹ repeat (n+1) Prop :=
split_fun (typevec.const true α) p

/-- predicate on the product of two type vectors to constrain only their last object -/
def rel_last' (α : typevec n) {β : Type*} (p : β → β → Prop) :
  (α ::: β ⊗ α ::: β) ⟹ repeat (n+1) Prop :=
split_fun (repeat_eq α) (uncurry p)

/-- given `F : typevec.{u} (n+1) → Type u`, `curry F : Type u → typevec.{u} → Type u`,
i.e. its first argument can be fed in separately from the rest of the vector of arguments -/
def curry (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n) : Type* :=
F (β ::: α)

instance curry.inhabited (F : typevec.{u} (n+1) → Type*) (α : Type u) (β : typevec.{u} n)
  [I : inhabited (F $ β ::: α)]:
  inhabited (curry F α β) := I

/-- arrow to remove one element of a `repeat` vector -/
def drop_repeat (α : Type*) : Π {n}, drop (repeat (succ n) α) ⟹ repeat n α
| (succ n) (fin2.fs i) := drop_repeat i
| (succ n) fin2.fz := _root_.id

/-- projection for a repeat vector -/
def of_repeat {α : Sort*} : Π {n i}, repeat n α i → α
| ._ fin2.fz := _root_.id
| ._ (fin2.fs i) := @of_repeat _ i

lemma const_iff_true {α : typevec n} {i x p} : of_repeat (typevec.const p α i x) ↔ p :=
by induction i; [refl, erw [typevec.const,@i_ih (drop α) x]]

-- variables  {F : typevec.{u} n → Type*} [mvfunctor F]
variables {α β γ : typevec.{u} n}
variables (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

/-- left projection of a `prod` vector -/
def prod.fst : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ α
| (succ n) α β (fin2.fs i) := @prod.fst _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.fst

/-- right projection of a `prod` vector -/
def prod.snd : Π {n} {α β : typevec.{u} n}, α ⊗ β ⟹ β
| (succ n) α β (fin2.fs i) := @prod.snd _ (drop α) (drop β) i
| (succ n) α β fin2.fz := _root_.prod.snd

/-- introduce a product where both components are the same -/
def prod.diag : Π {n} {α : typevec.{u} n}, α ⟹ α ⊗ α
| (succ n) α (fin2.fs i) x := @prod.diag _ (drop α) _ x
| (succ n) α fin2.fz x := (x,x)

/-- constructor for `prod` -/
def prod.mk : Π {n} {α β : typevec.{u} n} (i : fin2 n), α i → β i → (α ⊗ β) i
| (succ n) α β (fin2.fs i) := prod.mk i
| (succ n) α β fin2.fz := _root_.prod.mk

@[simp]
lemma prod_fst_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.fst i (prod.mk i a b) = a :=
by induction i; simp [prod.fst, prod.mk, *] at *

@[simp]
lemma prod_snd_mk {α β : typevec n} (i : fin2 n) (a : α i) (b : β i) :
  typevec.prod.snd i (prod.mk i a b) = b :=
by induction i; simp [prod.snd, prod.mk, *] at *

/-- `prod` is functorial -/
protected def prod.map : Π {n} {α α' β β' : typevec.{u} n}, (α ⟹ β) → (α' ⟹ β') → α ⊗ α' ⟹ β ⊗ β'
| (succ n) α α' β β' x y (fin2.fs i) a :=
  @prod.map _ (drop α) (drop α') (drop β) (drop β') (drop_fun x) (drop_fun y) _ a
| (succ n) α α' β β' x y fin2.fz a := (x _ a.1,y _ a.2)

localized "infix ` ⊗' `:45 := typevec.prod.map" in mvfunctor

theorem fst_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.fst ⊚ (f ⊗' g) = f ⊚ typevec.prod.fst :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_prod_mk {α α' β β' : typevec n} (f : α ⟹ β) (g : α' ⟹ β') :
  typevec.prod.snd ⊚ (f ⊗' g) = g ⊚ typevec.prod.snd :=
by ext i; induction i; [refl, apply i_ih]

theorem fst_diag {α : typevec n} : typevec.prod.fst ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

theorem snd_diag {α : typevec n} : typevec.prod.snd ⊚ (prod.diag : α ⟹ _) = id :=
by ext i; induction i; [refl, apply i_ih]

lemma repeat_eq_iff_eq {α : typevec n} {i x y} :
  of_repeat (repeat_eq α i (prod.mk _ x y)) ↔ x = y :=
by induction i; [refl, erw [repeat_eq,@i_ih (drop α) x y]]

/-- given a predicate vector `p` over vector `α`, `subtype_ p` is the type of vectors
that contain an `α` that satisfies `p` -/
def subtype_ : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), typevec n
| ._ α p fin2.fz := _root_.subtype (λ x, p fin2.fz x)
| ._ α p (fin2.fs i) := subtype_ (drop_fun p) i

/-- projection on `subtype_` -/
def subtype_val : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop), subtype_ p ⟹ α
| (succ n) α p (fin2.fs i) := @subtype_val n _ _ i
| (succ n) α p fin2.fz := _root_.subtype.val

/-- arrow that rearranges the type of `subtype_` to turn a subtype of vector into
a vector of subtypes -/
def to_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x // of_repeat $ p i x }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype (drop_fun p) i x
| (succ n) α p fin2.fz x := x

/-- arrow that rearranges the type of `subtype_` to turn a vector of subtypes
into a subtype of vector -/
def of_subtype : Π {n} {α : typevec.{u} n} (p : α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x // of_repeat $ p i x })
| (succ n) α p (fin2.fs i) x := of_subtype _ i x
| (succ n) α p fin2.fz x := x

/-- similar to `to_subtype` adapted to relations (i.e. predicate on product) -/
def to_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) }) ⟹ subtype_ p
| (succ n) α p (fin2.fs i) x := to_subtype' (drop_fun p) i x
| (succ n) α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `of_subtype` adapted to relations (i.e. predicate on product) -/
def of_subtype' : Π {n} {α : typevec.{u} n} (p : α ⊗ α ⟹ repeat n Prop),
  subtype_ p ⟹ (λ (i : fin2 n), { x : α i × α i // of_repeat $ p i (prod.mk _ x.1 x.2) })
| ._ α p (fin2.fs i) x := of_subtype' _ i x
| ._ α p fin2.fz x := ⟨x.val,cast (by congr; simp [prod.mk]) x.property⟩

/-- similar to `diag` but the target vector is a `subtype_`
guaranteeing the equality of the components -/
def diag_sub  : Π {n} {α : typevec.{u} n}, α ⟹ subtype_ (repeat_eq α)
| (succ n) α (fin2.fs i) x := @diag_sub _ (drop α) _ x
| (succ n) α fin2.fz x := ⟨(x,x), rfl⟩

lemma subtype_val_nil {α : typevec.{u} 0} (ps : α ⟹ repeat 0 Prop) :
  typevec.subtype_val ps = nil_fun :=
funext $ by rintro ⟨ ⟩; refl

lemma diag_sub_val {n} {α : typevec.{u} n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by ext i; induction i; [refl, apply i_ih]

lemma prod_id : Π {n} {α β : typevec.{u} n}, (id ⊗' id) = (id : α ⊗ β ⟹ _) :=
begin
  intros, ext i a, induction i,
  { cases a, refl },
  { apply i_ih },
end

lemma append_prod_append_fun {n} {α α' β β' : typevec.{u} n}
  {φ φ' ψ ψ' : Type u}
  {f₀ : α ⟹ α'} {g₀ : β ⟹ β'}
  {f₁ : φ → φ'}  {g₁ : ψ → ψ'} :
  (f₀ ⊗' g₀) ::: _root_.prod.map f₁ g₁ = ((f₀ ::: f₁) ⊗' (g₀ ::: g₁)) :=
by ext i a; cases i; [cases a, skip]; refl

end liftp'

@[simp]
lemma drop_fun_diag {α} :
  drop_fun (@prod.diag (n+1) α) = prod.diag :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (subtype_val p) = subtype_val _ := rfl

@[simp]
lemma last_fun_subtype_val {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (subtype_val p) = subtype.val := rfl

@[simp]
lemma drop_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (to_subtype p) = to_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_to_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (to_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  drop_fun (of_subtype p) = of_subtype _ :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_of_subtype {α} (p : α ⟹ repeat (n+1) Prop) :
  last_fun (of_subtype p) = _root_.id :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma drop_fun_rel_last {α : typevec n} {β}
  (R : β → β → Prop) :
  drop_fun (rel_last' α R) = repeat_eq α := rfl

attribute [simp] drop_append1'
open_locale mvfunctor

@[simp]
lemma drop_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  drop_fun (f ⊗' f') = (drop_fun f ⊗' drop_fun f') :=
by { ext i : 2, induction i; simp [drop_fun,*]; refl }

@[simp]
lemma last_fun_prod {α α' β β' : typevec (n+1)} (f : α ⟹ β) (f' : α' ⟹ β') :
  last_fun (f ⊗' f') = _root_.prod.map (last_fun f) (last_fun f') :=
by { ext i : 1, induction i; simp [last_fun,*]; refl }

@[simp]
lemma drop_fun_from_append1_drop_last {α : typevec (n+1)} :
  drop_fun (@from_append1_drop_last _ α) = id := rfl

@[simp]
lemma last_fun_from_append1_drop_last {α : typevec (n+1)} :
  last_fun (@from_append1_drop_last _ α) = _root_.id := rfl

@[simp]
lemma drop_fun_id {α : typevec (n+1)} :
  drop_fun (@typevec.id _ α) = id := rfl

@[simp]
lemma prod_map_id {α β : typevec n} :
  (@typevec.id _ α ⊗' @typevec.id _ β) = id :=
by { ext i : 2, induction i; simp only [typevec.prod.map,*,drop_fun_id],
     cases x, refl, refl }

@[simp]
lemma subtype_val_diag_sub {α : typevec n} :
  subtype_val (repeat_eq α) ⊚ diag_sub = prod.diag :=
by { clear_except, ext i, induction i; [refl, apply i_ih], }

@[simp]
lemma to_subtype_of_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  to_subtype p ⊚ of_subtype p = id :=
by ext i x; induction i; dsimp only [id, to_subtype, comp, of_subtype] at *; simp *

@[simp]
lemma subtype_val_to_subtype {α : typevec n} (p : α ⟹ repeat n Prop) :
  subtype_val p ⊚ to_subtype p = λ _, subtype.val :=
by ext i x; induction i; dsimp only [to_subtype, comp, subtype_val] at *; simp *

@[simp]
lemma to_subtype_of_subtype_assoc {α β : typevec n} (p : α ⟹ repeat n Prop)
  (f : β ⟹ subtype_ p) :
  @to_subtype n _ p ⊚ of_subtype _ ⊚ f = f :=
by rw [← comp_assoc,to_subtype_of_subtype]; simp

@[simp]
lemma to_subtype'_of_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  to_subtype' r ⊚ of_subtype' r = id :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, of_subtype'] at *; simp [subtype.eta, *]

lemma subtype_val_to_subtype' {α : typevec n} (r : α ⊗ α ⟹ repeat n Prop) :
  subtype_val r ⊚ to_subtype' r = λ i x, prod.mk i x.1.fst x.1.snd :=
by ext i x; induction i; dsimp only [id, to_subtype', comp, subtype_val, prod.mk] at *; simp *

end typevec


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import tactic.interval_cases
import algebra.big_operators.order
import data.nat.multiplicity

/-!
# IMO 2019 Q4

Find all pairs `(k, n)` of positive integers such that
```
  k! = (2 ^ n - 1)(2 ^ n - 2)(2 ^ n - 4)···(2 ^ n - 2 ^ (n - 1))
```
We show in this file that this property holds iff `(k, n) = (1, 1) ∨ (k, n) = (3, 2)`.

Proof sketch:
The idea of the proof is to count the factors of 2 on both sides. The LHS has less than `k` factors
of 2, and the RHS has exactly `n * (n - 1) / 2` factors of 2. So we know that `n * (n - 1) / 2 < k`.
Now for `n ≥ 6` we have `RHS < 2 ^ (n ^ 2) < (n(n-1)/2)! < k!`. We then treat the cases `n < 6`
individually.
-/

open_locale nat big_operators
open finset multiplicity nat (hiding zero_le prime)

theorem imo2019_q4_upper_bound {k n : ℕ} (hk : k > 0)
  (h : (k! : ℤ) = ∏ i in range n, (2 ^ n - 2 ^ i)) : n < 6 :=
begin
  have prime_2 : prime (2 : ℤ),
  { exact prime_iff_prime_int.mp prime_two },
  have h2 : n * (n - 1) / 2 < k,
  { suffices : multiplicity 2 (k! : ℤ) = (n * (n - 1) / 2 : ℕ),
    { rw [← part_enat.coe_lt_coe, ← this], change multiplicity ((2 : ℕ) : ℤ) _ < _,
      simp_rw [int.coe_nat_multiplicity, multiplicity_two_factorial_lt hk.lt.ne.symm] },
    rw [h, multiplicity.finset.prod prime_2, ← sum_range_id, nat.cast_sum],
    apply sum_congr rfl, intros i hi,
    rw [multiplicity_sub_of_gt, multiplicity_pow_self_of_prime prime_2],
    rwa [multiplicity_pow_self_of_prime prime_2, multiplicity_pow_self_of_prime prime_2,
      part_enat.coe_lt_coe, ←mem_range] },
  rw [←not_le], intro hn,
  apply ne_of_lt _ h.symm,
  suffices : (∏ i in range n, 2 ^ n : ℤ) < ↑k!,
  { apply lt_of_le_of_lt _ this, apply prod_le_prod,
    { intros, rw [sub_nonneg], apply pow_le_pow, norm_num, apply le_of_lt, rwa [← mem_range] },
    { intros, apply sub_le_self, apply pow_nonneg, norm_num } },
  suffices : 2 ^ (n * n) < (n * (n - 1) / 2)!,
  { rw [prod_const, card_range, ← pow_mul], rw [← int.coe_nat_lt_coe_nat_iff] at this,
    clear h, convert this.trans _, norm_cast, rwa [int.coe_nat_lt_coe_nat_iff, factorial_lt],
    refine nat.div_pos _ (by norm_num),
    refine le_trans _ (mul_le_mul hn (pred_le_pred hn) (zero_le _) (zero_le _)),
    norm_num },
  refine le_induction _ _ n hn, { norm_num },
  intros n' hn' ih,
  have h5 : 1 ≤ 2 * n', { linarith },
  have : 2 ^ (2 + 2) ≤ (n' * (n' - 1) / 2).succ,
  { change succ (6 * (6 - 1) / 2) ≤ _,
    apply succ_le_succ, apply nat.div_le_div_right,
    exact mul_le_mul hn' (pred_le_pred hn') (zero_le _) (zero_le _) },
  rw [triangle_succ], apply lt_of_lt_of_le _ factorial_mul_pow_le_factorial,
  refine lt_of_le_of_lt _ (mul_lt_mul ih (nat.pow_le_pow_of_le_left this _)
    (pow_pos (by norm_num) _) (zero_le _)),
  rw [← pow_mul, ← pow_add], apply pow_le_pow_of_le_right, norm_num,
  rw [add_mul 2 2],
  convert add_le_add_left (add_le_add_left h5 (2 * n')) (n' * n') using 1, ring
end

theorem imo2019_q4 {k n : ℕ} (hk : k > 0) (hn : n > 0) :
  (k! : ℤ) = (∏ i in range n, (2 ^ n - 2 ^ i)) ↔ (k, n) = (1, 1) ∨ (k, n) = (3, 2) :=
begin
  /- The implication `←` holds. -/
  split, swap,
  { rintro (h|h); simp [prod.ext_iff] at h; rcases h with ⟨rfl, rfl⟩;
    norm_num [prod_range_succ, succ_mul] },
  intro h,
  /- We know that n < 6. -/
  have := imo2019_q4_upper_bound hk h,
  interval_cases n,
  /- n = 1 -/
  { left, congr, norm_num at h, rw [factorial_eq_one] at h, apply antisymm h,
    apply succ_le_of_lt hk },
  /- n = 2 -/
  { right, congr, norm_num [prod_range_succ] at h, norm_cast at h, rw [← factorial_inj],
    exact h, rw [h], norm_num },
  all_goals { exfalso, norm_num [prod_range_succ] at h, norm_cast at h, },
  /- n = 3 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 5 _ _ _ h; norm_num },
  /- n = 4 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 7 _ _ _ h; norm_num },
  /- n = 5 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 10 _ _ _ h; norm_num },
end


namespace prop_09

variables X Y : Prop

theorem prop_9 (h : X ∨ Y) (h2 : ¬ X) : Y :=
show Y, from or.elim h
    (assume h1: X,
     show Y, from (classical.by_contradiction
        (assume Y,
         h2 h1)))
    (assume h3: Y,
     h3)

-- end namespace
end prop_09


class Vec (X : Type u)

class IsLin {X Y} [Vec X] [Vec Y] (f : X → Y)

structure ℝ where
  value : Float

instance instFoo1 {X : Type u} {Y : Type v} [Vec X] [Vec Y] : Vec (X × Y) := sorry
instance instProblem {α : Type u} {X : Type v} [Vec X] : Vec (α → X) := sorry

instance (priority := default+1) instFoo2 : Vec ℝ := sorry

--------------

instance comp_is_lin {X Y Z : Type} [Vec X] [Vec Y] [Vec Z]
  (f : Y → Z) (g : X → Y) [IsLin f] [IsLin g]
  : IsLin (λ x => f (g x)) := sorry

----------------

class Trait (X : Type u) where
  R : Type v

attribute [reducible] Trait.R

class SemiInner (X : Type u) (R : Type v) where
  semiInner : X → X → R

@[reducible] instance (X) (R : Type u) [SemiInner X R] : Trait X := ⟨R⟩

class SemiHilbert (X) (R : Type u) [Vec R] extends Vec X, SemiInner X R

@[infer_tc_goals_rl]
instance (X R) [Trait X] [Vec R] [SemiHilbert X R] (ι : Type v) : SemiHilbert (ι → X) R := sorry
instance : SemiHilbert ℝ ℝ := sorry

--------------

def norm {X} [Trait X] [inst : SemiInner X (Trait.R X)] (x : X) : Trait.R X := sorry
def sum {n} (f : Fin n → ℝ) : ℝ := sorry

variable (n m : Nat)

-- these all should work
example : Trait (Fin n → Fin m → ℝ) := by infer_instance
example : SemiInner ℝ (Trait.R ℝ) := by infer_instance
example : SemiHilbert (Fin n → ℝ) ℝ := by infer_instance
example : SemiHilbert (Fin n → ℝ) (Trait.R ℝ) := by infer_instance
example : Trait (Fin n → Fin m → (Trait.R ℝ)) := by infer_instance
example : SemiHilbert (Trait.R ℝ) ℝ := by infer_instance

-- set_option synthInstance.maxHeartbeats 50 in
-- set_option pp.explicit true in
-- set_option trace.Meta.synthInstance true in

-- This should not timeout but failt in finite number of steps like in Lean 3
example : IsLin  (λ (x : ℝ) => sum λ i : Fin n => norm x) := by infer_instance


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

import .basic

open form classical

variable {σ : nat}

/- general facts about non-modal logical constants -/

lemma neg_tt_iff_ff {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ ~p) = tt ↔ ¬(w ⊩⦃M⦄ p) :=
by unfold forces_form; induction (forces_form M p w); simp; simp

lemma neg_ff_iff_tt {M : model} {w : wrld σ} {p : form σ} :
  ¬(w ⊩⦃M⦄ ~p) ↔ (w ⊩⦃M⦄ p) = tt :=
by unfold forces_form; induction (forces_form M p w); simp; simp

lemma impl_iff_implies {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ p ⊃ q) = tt ↔ ((w ⊩⦃M⦄ p) → (w ⊩⦃M⦄ q)) :=
by unfold forces_form; induction (forces_form M p w); repeat {induction (forces_form M q w), simp, simp}

lemma impl_tt_iff_ff_or_tt {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ p ⊃ q) = tt ↔ ¬(w ⊩⦃M⦄ p) ∨ (w ⊩⦃M⦄ q) = tt :=
by unfold forces_form; induction (forces_form M p w); repeat {induction (forces_form M q w), simp, simp}

lemma ff_or_tt_and_tt_implies_tt_right {M : model} {w : wrld σ} {p q : form σ} :
  (¬(w ⊩⦃M⦄ p) ∨ (w ⊩⦃M⦄ q) = tt) → (w ⊩⦃M⦄ p) = tt → (w ⊩⦃M⦄ q) = tt :=
by simp; induction (forces_form M p w); repeat {induction (forces_form M q w), simp, simp}

lemma bot_is_insatisf {w : wrld σ} :
  ¬ ∃ (M : model), (w ⊩⦃M⦄ bot σ) = tt :=
by intro h; cases h; exact (bool.no_confusion h_h)

/- Modal logical constants (=>) -/

lemma forall_wrld_tt_nec_tt {M : model} {w : wrld σ} {p : form σ} :
  (∀ v ∈ M.wrlds, w ∈ M.wrlds → M.access w v → (v ⊩⦃M⦄ p) = tt) → (w ⊩⦃M⦄ ◻p) = tt :=
begin
  intro h,
  unfold forces_form,
  induction (prop_decidable _),
  { simp, contradiction },
  { simp, assumption }
end

lemma exists_wlrd_tt_pos_tt {M : model} {w : wrld σ} {p : form σ} :
  (∃ v ∈ M.wrlds, w ∈ M.wrlds ∧ M.access w v = tt ∧ (v ⊩⦃M⦄ p) = tt) → (w ⊩⦃M⦄ ◇p) = tt :=
begin
  intro h,
  unfold forces_form,
  induction (prop_decidable _),
  { simp, intro hf, cases h, cases h_h, cases h_h_h, cases h_h_h_right,
    apply tt_eq_ff_eq_false,
    rw eq.symm h_h_h_right_right,
    apply hf, repeat {assumption} },
  { simp, intro hf, cases h, cases h_h, cases h_h_h, cases h_h_h_right,
    apply bot_is_insatisf, apply exists.intro, apply impl_iff_implies.1,
    apply h_1, repeat {assumption} }
end

/- Modal logical constants (<=) -/

lemma nec_tt_forall_wrld_tt {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ ◻p) = tt → (∀ v ∈ M.wrlds, w ∈ M.wrlds → M.access w v = tt → (v ⊩⦃M⦄ p) = tt) :=
begin
  unfold forces_form,
  induction (prop_decidable _),
  repeat {simp}
end

lemma pos_tt_exists_wlrd_tt {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ ◇p) = tt → (∃ v ∈ M.wrlds, w ∈ M.wrlds ∧ M.access w v = tt ∧ (v ⊩⦃M⦄ p) = tt) :=
begin
  unfold forces_form,
  simp, intro h,
  apply classical.by_contradiction, intro h',
  have nh : ∀ v ∈ M.wrlds, w ∈ M.wrlds → M.access w v = tt → (v ⊩⦃M⦄ p) ≠ tt :=
    begin
      intros v wmem vmem rwv ptt, apply h',
      repeat {split},
      assumption,
      exact vmem,
      repeat {assumption}
    end,
  apply h, intros v wmem vmem rwv,
  apply eq_ff_of_not_eq_tt,
  apply nh, repeat {assumption}
end

lemma pos_ff_forall_wrld_ff {M : model} {w : wrld σ} {p : form σ} :
  ¬(w ⊩⦃M⦄ ◇p) → (∀ v ∈ M.wrlds, w ∈ M.wrlds → M.access w v = tt → ¬(v ⊩⦃M⦄ p)) :=
by unfold forces_form; simp; exact id

/- Some facts about PL -/

lemma is_true_pl1 {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ p ⊃ (q ⊃ p)) = tt :=
begin
  apply impl_iff_implies.2,
  intro, apply impl_iff_implies.2,
  intro, assumption
end

lemma is_true_pl2 {M : model} {w : wrld σ} {p q r : form σ} :
  (w ⊩⦃M⦄ (p ⊃ (q ⊃ r)) ⊃ ((p ⊃ q) ⊃ (p ⊃ r))) = tt :=
begin
  apply impl_iff_implies.2,
  intro h₁, apply impl_iff_implies.2,
  intro h₂, apply impl_iff_implies.2,
  intro h₃, apply impl_iff_implies.1 ((impl_iff_implies.1 h₁) h₃),
  apply impl_iff_implies.1 h₂, assumption
end

lemma is_true_pl3 {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ ((~p) ⊃ ~q) ⊃ (((~p) ⊃ q) ⊃ p)) = tt :=
begin
  unfold forces_form,
  induction (forces_form M p w),
  repeat { induction (forces_form M q w), repeat {simp} },
end

/- Some facts about K -/

lemma nec_impl_to_nec_to_nec {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ ◻(p ⊃ q)) = tt → (w ⊩⦃M⦄ ◻p) = tt → (w ⊩⦃M⦄ ◻q) = tt :=
begin
  unfold forces_form, simp at *, intros hlpq hlp v wmem vmem rwv,
  apply ff_or_tt_and_tt_implies_tt_right,
    rw or.comm, simp, apply hlpq, repeat {assumption},
    apply hlp, repeat {assumption},
end

lemma nec_nec_to_nec_impl {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ ◻p) = tt → (w ⊩⦃M⦄ ◻q) = tt → (w ⊩⦃M⦄ ◻(p ⊃ q)) = tt  :=
begin
  unfold forces_form, simp at *,
  intros hp hq v wmem vmem rwv,
  rw or.comm, apply or.intro_right, apply hq, repeat {assumption}
end

lemma nec_impl_to_nec_impl_nec {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ ◻(p ⊃ q)) = tt → (¬(w ⊩⦃M⦄ ◻p) ∨ (w ⊩⦃M⦄ ◻q) = tt) :=
begin
  intro, cases prop_decidable ((w ⊩⦃M⦄ ◻p) = tt),
  simp at h, left, simp at *, assumption,
  right, apply nec_impl_to_nec_to_nec a h
end

lemma is_true_k {M : model} {w : wrld σ} {p q : form σ} :
  (w ⊩⦃M⦄ (◻(p ⊃ q)) ⊃ ((◻p) ⊃ ◻q)) = tt :=
impl_iff_implies.2 (λ h, impl_tt_iff_ff_or_tt.2 (nec_impl_to_nec_impl_nec h))

/- Some facts about T -/

lemma nec_to_tt {M : model} {w : wrld σ} {wm : w ∈ M.wrlds} {p : form σ} :
  (w ⊩⦃M⦄ ◻p) = tt → (w ⊩⦃M⦄ p) = tt :=
begin
  unfold forces_form, simp at *,
  intro f, apply f, repeat {assumption},
  apply M.refl, assumption
end

lemma is_true_t {M : model} {w : wrld σ} {w ∈ M.wrlds} {p : form σ} :
  (w ⊩⦃M⦄ (◻p) ⊃ p) = tt :=
by apply impl_iff_implies.2; apply nec_to_tt; repeat {assumption}

/- Some facts about S4 -/

lemma nec_to_nec_of_nec {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ ◻p) = tt → (w ⊩⦃M⦄ ◻◻p) = tt :=
begin
  unfold forces_form, simp at *,
  intros f v wmem vmem rwv u vmem' umem rvu,
  apply f, repeat {assumption},
  refine M.trans _ _ _ _ _ _ rwv rvu,
  repeat {assumption}
end

lemma is_true_s4 {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ (◻p) ⊃ ◻◻p) = tt :=
by apply impl_iff_implies.2; apply nec_to_nec_of_nec

/- Some facts about B -/

lemma tt_to_pos_of_nec {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ p) = tt → (w ⊩⦃M⦄ ◻◇p) = tt :=
begin
  unfold forces_form, simp at *,
  intros h v vmem wmem rwv, intros f,
  apply tt_eq_ff_eq_false,
  rw (eq.symm h),
  apply f w wmem vmem,
  apply M.symm,
  exact wmem,
  exact vmem,
  exact rwv
end

lemma is_true_b {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ p ⊃ ◻◇p) = tt :=
by apply impl_iff_implies.2; apply tt_to_pos_of_nec

/- general facts about contexts -/

lemma ctx_tt_iff_mem_tt {Γ : ctx σ} {M : model} {w : wrld σ} :
  (w ⊩⦃M⦄ Γ) = tt ↔ (∀ p, p ∈ Γ → (w ⊩⦃M⦄ p) = tt) :=
begin
  unfold forces_ctx,
  induction (classical.prop_decidable _),
  { apply iff.intro,
    simp, intro,
    simp, assumption },
  { simp }
end

lemma mem_tt_to_ctx_tt (Γ : ctx σ) {M : model} {w : wrld σ} :
  (∀ (p : form σ) (h : p ∈ Γ), (w ⊩⦃M⦄ p) = tt) → (w ⊩⦃M⦄ Γ) = tt :=
ctx_tt_iff_mem_tt.2

lemma ctx_tt_to_mem_tt {Γ : ctx σ} {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ Γ) = tt → p ∈ Γ → (w ⊩⦃M⦄ p) = tt :=
by intro; apply ctx_tt_iff_mem_tt.1; assumption

/- the empty context -/

lemma empty_ctx_tt {M : model} {w : wrld σ} :
  (w ⊩⦃M⦄ ·) = tt :=
begin
  apply ctx_tt_iff_mem_tt.2,
  intros, exfalso, assumption
end

/- context projections -/

lemma cons_ctx_tt_iff_and {Γ : ctx σ} {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ (Γ ⸴ p)) = tt ↔ (w ⊩⦃M⦄ Γ) = tt ∧ (w ⊩⦃M⦄ p) = tt :=
begin
  unfold forces_ctx,
  induction (classical.prop_decidable (∀ p, p ∈ Γ → forces_form M p w = tt)),
  { simp, apply iff.intro,
    { intro h', exfalso,
      apply h, intros q qmem, apply h',
      apply set.mem_insert_of_mem, assumption },
    { intros h' q qmem,
      cases h', cases qmem,
      rw qmem, assumption,
      apply h'_left, assumption } },

  { simp, apply iff.intro,
    { intro h', split,
      { assumption },
      { apply h', apply set.mem_insert } },
    { intros h' q qmem,
      cases h', cases qmem,
      rw qmem, assumption,
      apply h'_left, assumption } },
end

lemma cons_ctx_tt_to_ctx_tt {Γ : ctx σ} {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ (Γ ⸴ p)) = tt → (w ⊩⦃M⦄ Γ) = tt :=
by intro h; apply and.elim_left; apply cons_ctx_tt_iff_and.1 h

lemma ctx_tt_cons_tt_to_cons_ctx_tt {Γ : ctx σ} {M : model} {w : wrld σ} {p : form σ} :
  (w ⊩⦃M⦄ Γ) = tt → (w ⊩⦃M⦄ p) → (w ⊩⦃M⦄ (Γ ⸴ p)) :=
by intros hg hp; apply cons_ctx_tt_iff_and.2; split; assumption; assumption

/- sub-contexts -/

lemma ctx_tt_to_subctx_tt {Γ Δ : ctx σ} {M : model} {w : wrld σ} :
  (w ⊩⦃M⦄ Γ) → Δ ⊆ Γ → (w ⊩⦃M⦄ Δ) :=
begin
  intros h s,
  apply ctx_tt_iff_mem_tt.2,
  intros p pmem,
  apply ctx_tt_iff_mem_tt.1 h,
  apply s, exact pmem
end

/- the deduction metatheorem -/

lemma sem_deduction {Γ : ctx σ} {p q : form σ} :
  (Γ ⸴ p ⊨ₛ₅ q) → (Γ ⊨ₛ₅ p ⊃ q) :=
begin
  intro h, cases h,
  apply sem_csq.is_true,
  intros M w wmem ant,
  apply impl_iff_implies.2,
  { intro hp, apply h, assumption,
    apply ctx_tt_cons_tt_to_cons_ctx_tt,
    repeat {assumption} }
end